(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 16: Separation Logic
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap Setoid Classes.Morphisms SepCancel.

Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Shared notations and definitions; main material starts afterward. *)

Definition heap := fmap nat nat.

Local Hint Extern 1 (_ <= _) => linear_arithmetic : core.
Local Hint Extern 1 (@eq nat _ _) => linear_arithmetic : core.

Ltac simp := repeat (simplify; subst; propositional;
                     try match goal with
                         | [ H : ex _ |- _ ] => invert H
                         end); try linear_arithmetic.

(** * Encore of last mixed-embedding language from last time *)

(* Let's work with a variant of the imperative language from last time. *)

Inductive loop_outcome acc :=
| Done (a : acc)
| Again (a : acc).

Inductive cmd : Set -> Type :=
| Return {result : Set} (r : result) : cmd result
| Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
| Read (a : nat) : cmd nat
| Write (a v : nat) : cmd unit
| Loop {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) : cmd acc
| Fail {result} : cmd result

(* But let's also add memory allocation and deallocation. *)
| Alloc (numWords : nat) : cmd nat
| Free (base numWords : nat) : cmd unit.

Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).

(* These helper functions respectively initialize a new span of memory and
 * remove a span of memory that the program is done with. *)

Fixpoint initialize (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => initialize h base numWords' $+ (base + numWords', 0)
  end.

Fixpoint deallocate (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => deallocate (h $- base) (base+1) numWords'
  end.

(* Let's do the semantics a bit differently this time, falling back on classic
 * small-step operational semantics. *)
Inductive step : forall A, heap * cmd A -> heap * cmd A -> Prop :=
| StepBindRecur : forall result result' (c1 c1' : cmd result') (c2 : result' -> cmd result) h h',
  step (h, c1) (h', c1')
  -> step (h, Bind c1 c2) (h', Bind c1' c2)
| StepBindProceed : forall (result result' : Set) (v : result') (c2 : result' -> cmd result) h,
  step (h, Bind (Return v) c2) (h, c2 v)

| StepLoop : forall (acc : Set) (init : acc) (body : acc -> cmd (loop_outcome acc)) h,
  step (h, Loop init body) (h, o <- body init; match o with
                                               | Done a => Return a
                                               | Again a => Loop a body
                                               end)

| StepRead : forall h a v,
  h $? a = Some v
  -> step (h, Read a) (h, Return v)
| StepWrite : forall h a v v',
  h $? a = Some v
  -> step (h, Write a v') (h $+ (a, v'), Return tt)
| StepAlloc : forall h numWords a,
  (forall i, i < numWords -> h $? (a + i) = None)
  -> step (h, Alloc numWords) (initialize h a numWords, Return a)
| StepFree : forall h a numWords,
  step (h, Free a numWords) (deallocate h a numWords, Return tt).

Definition trsys_of (h : heap) {result} (c : cmd result) := {|
  Initial := {(h, c)};
  Step := step (A := result)
|}.

(* Now let's get into the first distinctive feature of separation logic: an
 * assertion language that takes advantage of *partiality* of heaps.  We give our
 * definitions inside a module, which will shortly be used as a parameter to
 * another module (from the book library), to get some free automation for
 * implications between these assertions. *)
Module Import S <: SEP.
  Definition hprop := heap -> Prop.
  (* A [hprop] is a regular old assertion over heaps. *)

  (* Implication *)
  Definition himp (p q : hprop) := forall h, p h -> q h.

  (* Equivalence *)
  Definition heq (p q : hprop) := forall h, p h <-> q h.

  (* Lifting a pure proposition: it must hold, and the heap must be empty. *)
  Definition lift (P : Prop) : hprop :=
    fun h => P /\ h = $0.

  (* Separating conjunction, one of the two big ideas of separation logic.
   * When does [star p q] apply to [h]?  When [h] can be partitioned into two
   * subheaps [h1] and [h2], respectively compatible with [p] and [q].  See book
   * module [Map] for definitions of [split] and [disjoint]. *)
  Definition star (p q : hprop) : hprop :=
    fun h => exists h1 h2, split h h1 h2 /\ disjoint h1 h2 /\ p h1 /\ q h2.

  (* Existential quantification *)
  Definition exis A (p : A -> hprop) : hprop :=
    fun h => exists x, p x h.

  (* Convenient notations *)
  Notation "[| P |]" := (lift P) : sep_scope.
  Infix "*" := star : sep_scope.
  Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
  Delimit Scope sep_scope with sep.
  Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
  Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).

  Local Open Scope sep_scope.

  (* And now we prove some key algebraic properties, whose details aren't so
   * important.  The library automation uses these properties. *)

  Lemma iff_two : forall A (P Q : A -> Prop),
    (forall x, P x <-> Q x)
    -> (forall x, P x -> Q x) /\ (forall x, Q x -> P x).
  Proof.
    firstorder.
  Qed.

  Local Ltac t := (unfold himp, heq, lift, star, exis; propositional; subst);
                  repeat (match goal with
                          | [ H : forall x, _ <-> _ |- _  ] =>
                            apply iff_two in H
                          | [ H : ex _ |- _ ] => destruct H
                          | [ H : split _ _ $0 |- _ ] => apply split_empty_fwd in H
                          end; propositional; subst); eauto 15.

  Theorem himp_heq : forall p q, p === q
    <-> (p ===> q /\ q ===> p).
  Proof.
    t.
  Qed.

  Theorem himp_refl : forall p, p ===> p.
  Proof.
    t.
  Qed.

  Theorem himp_trans : forall p q r, p ===> q -> q ===> r -> p ===> r.
  Proof.
    t.
  Qed.

  Theorem lift_left : forall p (Q : Prop) r,
    (Q -> p ===> r)
    -> p * [| Q |] ===> r.
  Proof.
    t.
  Qed.

  Theorem lift_right : forall p q (R : Prop),
    p ===> q
    -> R
    -> p ===> q * [| R |].
  Proof.
    t.
  Qed.

  Local Hint Resolve split_empty_bwd' : core.

  Theorem extra_lift : forall (P : Prop) p,
    P
    -> p === [| P |] * p.
  Proof.
    t.
    apply split_empty_fwd' in H1; subst; auto.
  Qed.

  Theorem star_comm : forall p q, p * q === q * p.
  Proof.
    t.
  Qed.

  Theorem star_assoc : forall p q r, p * (q * r) === (p * q) * r.
  Proof.
    t.
  Qed.

  Theorem star_cancel : forall p1 p2 q1 q2, p1 ===> p2
    -> q1 ===> q2
    -> p1 * q1 ===> p2 * q2.
  Proof.
    t.
  Qed.

  Theorem exis_gulp : forall A p (q : A -> _),
    p * exis q === exis (fun x => p * q x).
  Proof.
    t.
  Qed.

  Theorem exis_left : forall A (p : A -> _) q,
    (forall x, p x ===> q)
    -> exis p ===> q.
  Proof.
    t.
  Qed.

  Theorem exis_right : forall A p (q : A -> _) x,
    p ===> q x
    -> p ===> exis q.
  Proof.
    t.
  Qed.
End S.

Export S.
(* Instantiate our big automation engine to these definitions. *)
Module Import Se := SepCancel.Make(S).

(* ** Some extra predicates outside the set that the engine knows about *)

(* Capturing single-mapping heaps *)
Definition heap1 (a v : nat) : heap := $0 $+ (a, v).
Definition ptsto (a v : nat) : hprop :=
  fun h => h = heap1 a v.

(* Helpful notations, some the same as above *)
Notation "[| P |]" := (lift P) : sep_scope.
Notation emp := (lift True).
Infix "*" := star : sep_scope.
Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
Delimit Scope sep_scope with sep.
Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).
Infix "|->" := ptsto (at level 30) : sep_scope.

(* For describing a "struct" in memory at consecutive addresses *)
Fixpoint multi_ptsto (a : nat) (vs : list nat) : hprop :=
  match vs with
  | nil => emp
  | v :: vs' => a |-> v * multi_ptsto (a + 1) vs'
  end%sep.

Infix "|-->" := multi_ptsto (at level 30) : sep_scope.

(* We'll use this one to describe the struct returned by [Alloc]. *)
Fixpoint zeroes (n : nat) : list nat :=
  match n with
  | O => nil
  | S n' => zeroes n' ++ 0 :: nil
  end.

(* For recording merely that a range of cells is mapped into our memory space *)
Fixpoint allocated (a n : nat) : hprop :=
  match n with
  | O => emp
  | S n' => (exists v, a |-> v) * allocated (a+1) n'
  end%sep.

Infix "|->?" := allocated (at level 30) : sep_scope.

(** * Finally, the Hoare logic *)

Inductive hoare_triple : forall {result}, hprop -> cmd result -> (result -> hprop) -> Prop :=
(* First, four basic rules that look exactly the same as before *)
| HtReturn : forall P {result : Set} (v : result),
    hoare_triple P (Return v) (fun r => P * [| r = v |])%sep
| HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
    hoare_triple P c1 Q
    -> (forall r, hoare_triple (Q r) (c2 r) R)
    -> hoare_triple P (Bind c1 c2) R
| HtLoop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) I,
    (forall acc, hoare_triple (I (Again acc)) (body acc) I)
    -> hoare_triple (I (Again init)) (Loop init body) (fun r => I (Done r))
| HtFail : forall {result},
    hoare_triple (fun _ => False) (Fail (result := result)) (fun _ _ => False)

(* Now the new rules for primitive heap operations: *)

| HtRead : forall a R,
    hoare_triple (exists v, a |-> v * R v)%sep (Read a) (fun r => a |-> r * R r)%sep
(* To read from an address, it must be mapped into the address space with some
 * value.  Afterward, that address is known to point to the result value [r].
 * An additional *frame* predicate [R] is along for the ride. *)

| HtWrite : forall a v',
    hoare_triple (exists v, a |-> v)%sep (Write a v') (fun _ => a |-> v')%sep
(* To write to an address, just show that it's mapped into the address space.
 * Afterward, that address points to the value we've written.  Note that this
 * rule is in the *small-footprint* style, with no frame predicate baked in. *)

| HtAlloc : forall numWords,
    hoare_triple emp%sep (Alloc numWords) (fun r => r |--> zeroes numWords)%sep
(* Allocation works in any memory, transitioning to a state where the result
 * value points to a sequence of zeroes. *)

| HtFree : forall a numWords,
    hoare_triple (a |->? numWords)%sep (Free a numWords) (fun _ => emp)%sep
(* Deallocation requires an argument pointing to the appropriate number of
 * words, taking us to a state where those addresses are unmapped. *)

| HtConsequence : forall {result} (c : cmd result) P Q (P' : hprop) (Q' : _ -> hprop),
    hoare_triple P c Q
    -> P' ===> P
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple P' c Q'
(* This is essentially the same rule of consequence from before. *)

| HtFrame : forall {result} (c : cmd result) P Q R,
    hoare_triple P c Q
    -> hoare_triple (P * R)%sep c (fun r => Q r * R)%sep.
(* The *frame rule* is the other big idea of separation logic.  We can extend
 * any Hoare triple by starring an arbitrary assertion [R] into both
 * precondition and postcondition.  Note that rule [HtRead] built in a variant
 * of the frame rule, where the frame predicate [R] may depend on the value [v]
 * being read.  The other operations can use this generic frame rule instead. *)

Notation "{{ P }} c {{ r ~> Q }}" :=
  (hoare_triple P%sep c (fun r => Q%sep)) (at level 90, c at next level).

Lemma HtStrengthen : forall {result} (c : cmd result) P Q (Q' : _ -> hprop),
    hoare_triple P c Q
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple P c Q'.
Proof.
  simplify.
  eapply HtConsequence; eauto.
  reflexivity.
Qed.

Lemma HtWeaken : forall {result} (c : cmd result) P Q (P' : hprop),
    hoare_triple P c Q
    -> P' ===> P
    -> hoare_triple P' c Q.
Proof.
  simplify.
  eapply HtConsequence; eauto.
  reflexivity.
Qed.

(* Now, we carry out a moderately laborious soundness proof!  It's safe to skip
 * ahead to the text "Examples", but a few representative lemma highlights
 * include [invert_Read], [preservation], [progress], and the main theorem
 * [hoare_triple_sound]. *)

Lemma invert_Return : forall {result : Set} (r : result) P Q,
  hoare_triple P (Return r) Q
  -> forall h, P h -> Q r h.
Proof.
  induct 1; propositional; eauto.

  exists h, $0; propositional; eauto.
  unfold lift; propositional.

  unfold himp in *; eauto.

  unfold star, himp in *; simp; eauto 7.
Qed.

Local Hint Constructors hoare_triple : core.

Lemma invert_Bind : forall {result' result} (c1 : cmd result') (c2 : result' -> cmd result) P Q,
  hoare_triple P (Bind c1 c2) Q
  -> exists R, hoare_triple P c1 R
               /\ forall r, hoare_triple (R r) (c2 r) Q.
Proof.
  induct 1; propositional; eauto.

  invert IHhoare_triple; propositional.
  eexists; propositional.
  eapply HtWeaken.
  eassumption.
  auto.
  eapply HtStrengthen.
  apply H4.
  auto.

  simp.
  exists (fun r => x r * R)%sep.
  propositional.
  eapply HtFrame; eauto.
  eapply HtFrame; eauto.
Qed.

Lemma invert_Loop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) P Q,
    hoare_triple P (Loop init body) Q
    -> exists I, (forall acc, hoare_triple (I (Again acc)) (body acc) I)
                 /\ (forall h, P h -> I (Again init) h)
                 /\ (forall r h, I (Done r) h -> Q r h).
Proof.
  induct 1; propositional; eauto.

  invert IHhoare_triple; propositional.
  exists x; propositional; eauto.
  unfold himp in *; eauto.

  simp.
  exists (fun o => x o * R)%sep; propositional; eauto.
  unfold star in *; simp; eauto 7.
  unfold star in *; simp; eauto 7.
Qed.

Lemma invert_Fail : forall result P Q,
  hoare_triple P (Fail (result := result)) Q
  -> forall h, P h -> False.
Proof.
  induct 1; propositional; eauto.

  unfold star in *; simp; eauto.
Qed.

(* Now that we proved enough basic facts, let's hide the definitions of all
 * these predicates, so that we reason about them only through automation. *)
Opaque heq himp lift star exis ptsto.

Lemma unit_not_nat : unit = nat -> False.
Proof.
  simplify.
  assert (exists x : unit, forall y : unit, x = y).
  exists tt; simplify.
  cases y; reflexivity.
  rewrite H in H0.
  invert H0.
  specialize (H1 (S x)).
  linear_arithmetic.
Qed.

Lemma invert_Read : forall a P Q,
  hoare_triple P (Read a) Q
  -> exists R, (P ===> exists v, a |-> v * R v)%sep
               /\ forall r, a |-> r * R r ===> Q r.
Proof.
  induct 1; simp; eauto.

  exists R; simp.
  cancel; auto.
  cancel; auto.

  apply unit_not_nat in x0; simp.

  apply unit_not_nat in x0; simp.

  eauto 7 using himp_trans.

  exists (fun n => x n * R)%sep; simp.
  rewrite H1.
  cancel.

  rewrite <- H2.
  cancel.
Qed.

Lemma invert_Write : forall a v' P Q,
  hoare_triple P (Write a v') Q
  -> exists R, (P ===> (exists v, a |-> v) * R)%sep
               /\ a |-> v' * R ===> Q tt.
Proof.
  induct 1; simp; eauto.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  exists emp; simp.
  cancel; auto.
  cancel; auto.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  eauto 7 using himp_trans.

  exists (x * R)%sep; simp.
  rewrite H1.
  cancel.

  cancel.
  rewrite <- H2.
  cancel.
Qed.

Lemma invert_Alloc : forall numWords P Q,
  hoare_triple P (Alloc numWords) Q
  -> forall r, P * r |--> zeroes numWords ===> Q r.
Proof.
  induct 1; simp; eauto.

  apply unit_not_nat in x0; simp.

  cancel.

  apply unit_not_nat in x0; simp.

  rewrite H0.
  eauto using himp_trans.

  rewrite <- IHhoare_triple.
  cancel.
Qed.

(* Temporarily transparent again! *)
Transparent heq himp lift star exis ptsto.

Lemma zeroes_initialize' : forall h a v,
    h $? a = None
    -> (fun h' : heap => h' = h $+ (a, v)) ===> (fun h' => h' = h) * a |-> v.
Proof.
  unfold himp, star, split, ptsto, disjoint; simp.
  exists h, (heap1 a v).
  propositional.
  maps_equal.
  unfold heap1.
  rewrite lookup_join2.
  simp.
  simp.
  apply lookup_None_dom in H.
  propositional.
  cases (h $? k).
  rewrite lookup_join1; auto.
  eauto using lookup_Some_dom.
  rewrite lookup_join2; auto.
  unfold heap1; simp.
  eauto using lookup_None_dom.
  unfold heap1 in *.
  cases (a ==n a0); simp.
Qed.

(* Opaque again! *)
Opaque heq himp lift star exis ptsto.

Lemma multi_ptsto_app : forall ls2 ls1 a,
     a |--> ls1 * (a + length ls1) |--> ls2 ===> a |--> (ls1 ++ ls2).
Proof.
  induct ls1; simp; cancel; auto.

  replace (a + 0) with a by linear_arithmetic.
  cancel.

  rewrite <- IHls1.
  cancel.
  replace (a0 + 1 + length ls1) with (a0 + S (length ls1)) by linear_arithmetic.
  cancel.
Qed.

Lemma length_zeroes : forall n,
    length (zeroes n) = n.
Proof.
  induct n; simplify; auto.
  rewrite app_length; simplify.
  linear_arithmetic.
Qed.

Lemma initialize_fresh : forall a' h a numWords,
    a' >= a + numWords
    -> initialize h a numWords $? a' = h $? a'.
Proof.
  induct numWords; simp; auto.
Qed.

Lemma zeroes_initialize : forall numWords a h,
    (forall i, i < numWords -> h $? (a + i) = None)
    -> (fun h' => h' = initialize h a numWords) ===> (fun h' => h' = h) * a |--> zeroes numWords.
Proof.
  induct numWords; simp.

  cancel; auto.
  rewrite <- multi_ptsto_app.
  rewrite zeroes_initialize'.
  erewrite IHnumWords.
  simp.
  rewrite length_zeroes.
  cancel; auto.
  auto.
  rewrite initialize_fresh; auto.
Qed.

Lemma invert_Free : forall a numWords P Q,
  hoare_triple P (Free a numWords) Q
  -> P ===> a |->? numWords * Q tt.
Proof.
  induct 1; simp; eauto.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  cancel; auto.

  rewrite H0.
  rewrite IHhoare_triple.
  cancel; auto.

  rewrite IHhoare_triple.
  cancel; auto.
Qed.

(* Temporarily transparent again! *)
Transparent heq himp lift star exis ptsto.

Lemma do_deallocate' : forall a Q h,
    ((exists v, a |-> v) * Q)%sep h
    -> Q (h $- a).
Proof.
  unfold ptsto, star, split, heap1; simp.
  invert H1.
  replace ($0 $+ (a, x1) $++ x0 $- a) with x0; auto.
  maps_equal.
  cases (k ==n a); simp.
  specialize (H a).
  simp.
  cases (x0 $? a); auto.
  exfalso; apply H; equality.
  rewrite lookup_join2; auto.
  apply lookup_None_dom.
  simp.
Qed.

Lemma do_deallocate : forall Q numWords a h,
    (a |->? numWords * Q)%sep h
    -> Q (deallocate h a numWords).
Proof.
  induct numWords; simp.

  unfold star, exis, lift in H; simp.
  apply split_empty_fwd' in H0; simp.

  apply IHnumWords.
  clear IHnumWords.

  apply do_deallocate'.
  Opaque heq himp lift star exis ptsto.
  match goal with
  | [ H : ?P h |- ?Q h ] => assert (P ===> Q) by cancel
  end.
  Transparent himp.
  apply H0; auto.
  Opaque himp.
Qed.

Lemma HtReturn' : forall P {result : Set} (v : result) Q,
    P ===> Q v
    -> hoare_triple P (Return v) Q.
Proof.
  simp.
  eapply HtStrengthen.
  constructor.
  simp.
  cancel.
  subst.
  assumption.
Qed.

(* Temporarily transparent again! *)
Transparent heq himp lift star exis ptsto.

Lemma preservation : forall {result} (c : cmd result) h c' h',
    step (h, c) (h', c')
    -> forall Q, hoare_triple (fun h' => h' = h) c Q
                 -> hoare_triple (fun h'' => h'' = h') c' Q.
Proof.
  induct 1; simplify.

  apply invert_Bind in H0; simp.
  eauto.

  apply invert_Bind in H; simp.
  specialize (invert_Return H); eauto using HtWeaken.

  apply invert_Loop in H; simp.
  econstructor.
  eapply HtWeaken.
  eauto.
  assumption.
  simp.
  cases r.
  apply HtReturn'.
  unfold himp; simp; eauto.
  eapply HtStrengthen.
  eauto.
  unfold himp; simp; eauto.

  apply invert_Read in H0; simp.
  apply HtReturn'.
  assert ((exists v, a |-> v * x v)%sep h') by auto.
  unfold exis, star in H1; simp.
  unfold ptsto in H4; subst.
  unfold split in H1; subst.
  unfold heap1 in H.
  rewrite lookup_join1 in H by (simp; sets).
  unfold himp; simp.
  invert H.
  apply H2.
  unfold star.
  exists (heap1 a v), x2; propositional.
  unfold split; reflexivity.
  unfold ptsto; reflexivity.

  apply invert_Write in H0; simp.
  apply HtReturn'.
  simp.
  assert (((exists v : nat, a |-> v) * x)%sep h) by auto.
  unfold star in H1; simp.
  invert H4.
  unfold ptsto in H5; subst.
  unfold split in H3; subst.
  unfold heap1 in H.
  rewrite lookup_join1 in H by (simp; sets).
  unfold himp; simp.
  invert H.
  apply H2.
  unfold star.
  exists ($0 $+ (a, v')), x1; propositional.
  unfold split.
  unfold heap1.
  maps_equal.
  rewrite lookup_join1 by (simp; sets).
  simp.
  repeat rewrite lookup_join2 by (simp; sets); reflexivity.
  unfold disjoint in *; simp.
  cases (a0 ==n a); simp.
  apply H1 with (a := a).
  unfold heap1; simp.
  equality.
  assumption.
  unfold ptsto; reflexivity.

  apply invert_Alloc with (r := a) in H0.
  apply HtReturn'.
  unfold himp; simp.
  eapply himp_trans in H0; try apply zeroes_initialize.
  auto.
  assumption.

  apply invert_Free in H.
  assert ((a |->? numWords * Q tt)%sep h) by auto.
  apply HtReturn'.
  unfold himp; simp.
  eapply do_deallocate.
  eauto.
Qed.

Lemma deallocate_None : forall a' numWords h a,
    h $? a' = None
    -> deallocate h a numWords $? a' = None.
Proof.
  induct numWords; simp.
  rewrite IHnumWords; simp.
  cases (a ==n a'); simp.
Qed.

Lemma preservation_finite : forall {result} (c : cmd result) h c' h' bound,
    step (h, c) (h', c')
    -> (forall a, a >= bound -> h $? a = None)
    -> exists bound', forall a, a >= bound' -> h' $? a = None.
Proof.
  induct 1; simplify; eauto.

  exists bound; simp.
  cases (a ==n a0); simp.
  rewrite H0 in H; equality.
  auto.

  exists (max bound (a + numWords)); simp.
  rewrite initialize_fresh; auto.

  exists bound; simp.
  eauto using deallocate_None.
Qed.

Local Hint Constructors step : core.

Lemma progress : forall {result} (c : cmd result) P Q,
    hoare_triple P c Q
    -> forall h h1 h2, split h h1 h2
                       -> disjoint h1 h2
                       -> P h1
                       -> (exists bound, forall a, a >= bound -> h $? a = None)
                       -> (exists r, c = Return r)
                          \/ (exists h' c', step (h, c) (h', c')).
Proof.
  induct 1; simp;
  repeat match goal with
           | [ H : forall _ h1 _, _ -> _ -> ?P h1 -> _, H' : ?P _ |- _ ] => eapply H in H'; clear H; try eassumption; simp
         end; eauto.

  invert H1.
  right; exists h, (Return x0).
  constructor.
  unfold split, ptsto, heap1 in *; simp.
  unfold star in H2; simp.
  unfold split in H; simp.
  rewrite lookup_join1; simp.
  rewrite lookup_join1; simp.
  sets.
  eapply lookup_Some_dom.
  rewrite lookup_join1; simp.
  sets.

  right; exists (h $+ (a, v')), (Return tt).
  unfold split, exis, ptsto, heap1 in *; simp.
  econstructor.
  rewrite lookup_join1; simp.
  sets.

  unfold lift in H1; simp.
  apply split_empty_fwd' in H; simp.
  right; exists (initialize h2 x numWords), (Return x).
  constructor.
  simp; auto.

  unfold star in H2; simp.
  apply IHhoare_triple with (h := h) (h1 := x0) (h2 := h2 $++ x1); eauto.
  unfold split in *; simp.
  rewrite (@join_comm _ _ h2 x1).
  apply join_assoc.
  sets.
  cases (h2 $? x2).
  cases (x1 $? x2).
  specialize (H2 x2).
  specialize (H1 x2).
  rewrite lookup_join2 in H1.
  apply H1; equality.
  unfold not.
  simplify.
  cases (x0 $? x2).
  exfalso; apply H2; equality.
  apply lookup_None_dom in Heq1; propositional.
  apply lookup_None_dom in Heq0; propositional.
  apply lookup_None_dom in Heq; propositional.

  unfold split, disjoint in *; simp.
  cases (h2 $? a).
  rewrite lookup_join1 in H8.
  apply H1 with (a := a); auto.
  rewrite lookup_join1; auto.
  cases (x0 $? a); try equality.
  eauto using lookup_Some_dom.
  eauto using lookup_Some_dom.
  rewrite lookup_join2 in H8.
  eapply H2; eassumption.
  eauto using lookup_None_dom.
Qed.

Lemma hoare_triple_sound' : forall P {result} (c : cmd result) Q,
    hoare_triple P c Q
    -> P $0
    -> invariantFor (trsys_of $0 c)
                    (fun p =>
                       (exists bound, forall a, a >= bound -> fst p $? a = None)
                       /\ hoare_triple (fun h' => h' = fst p)
                                       (snd p)
                                       Q).
Proof.
  simplify.

  apply invariant_induction; simplify.

  propositional; subst; simplify.
  exists 0; simp.
  eapply HtWeaken; eauto.
  unfold himp; simplify; equality.

  cases s.
  cases s'.
  simp.
  eauto using preservation_finite.
  eauto using preservation.
Qed.

Theorem hoare_triple_sound : forall P {result} (c : cmd result) Q,
    hoare_triple P c Q
    -> P $0
    -> invariantFor (trsys_of $0 c)
                    (fun p => (exists r, snd p = Return r)
                              \/ (exists p', step p p')).
Proof.
  simplify.

  eapply invariant_weaken.
  eapply hoare_triple_sound'; eauto.
  simp.
  specialize (progress H3); simplify.
  specialize (H2 (fst s) (fst s) $0).
  assert (split (fst s) (fst s) $0) by auto.
  assert (disjoint (fst s) $0) by auto.
  assert (exists bound, forall a, a >= bound -> fst s $? a = None) by eauto.
  cases s; simp; eauto.
Qed.

(* Fancy theorem to help us rewrite within preconditions and postconditions *)
Global Instance hoare_triple_morphism : forall A,
  Proper (heq ==> eq ==> (eq ==> heq) ==> iff) (@hoare_triple A).
Proof.
  Transparent himp.
  repeat (hnf; intros).
  unfold pointwise_relation in *; intuition subst.

  eapply HtConsequence; eauto.
  rewrite H; reflexivity.
  intros.
  hnf in H1.
  specialize (H1 r _ eq_refl).
  rewrite H1; reflexivity.

  eapply HtConsequence; eauto.
  rewrite H; reflexivity.
  intros.
  hnf in H1.
  specialize (H1 r _ eq_refl).
  rewrite H1; reflexivity.
  Opaque himp.
Qed.

(** * Examples *)

Opaque heq himp lift star exis ptsto.

(* Here comes some automation that we won't explain in detail, instead opting to
 * use examples. *)

Theorem use_lemma : forall result P' (c : cmd result) (Q : result -> hprop) P R,
  hoare_triple P' c Q
  -> P ===> P' * R
  -> hoare_triple P c (fun r => Q r * R)%sep.
Proof.
  simp.
  eapply HtWeaken.
  eapply HtFrame.
  eassumption.
  eauto.
Qed.

Theorem HtRead' : forall a v,
  hoare_triple (a |-> v)%sep (Read a) (fun r => a |-> v * [| r = v |])%sep.
Proof.
  simp.
  apply HtWeaken with (exists r, a |-> r * [| r = v |])%sep.
  eapply HtStrengthen.
  apply HtRead.
  simp.
  cancel; auto.
  subst; cancel.
Qed.

Theorem HtRead'' : forall p P R,
  P ===> (exists v, p |-> v * R v)
  -> hoare_triple P (Read p) (fun r => p |-> r * R r)%sep.
Proof.
  simp.
  eapply HtWeaken.
  apply HtRead.
  assumption.
Qed.

Ltac basic := apply HtReturn' || eapply HtWrite || eapply HtAlloc || eapply HtFree.

Ltac step0 := basic || eapply HtBind || (eapply use_lemma; [ basic | cancel; auto ])
              || (eapply use_lemma; [ eapply HtRead' | solve [ cancel; auto ] ])
              || (eapply HtRead''; solve [ cancel ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ basic | cancel; auto ] | ])
              || (eapply HtConsequence; [ apply HtFail | .. ]).
Ltac step := step0; simp.
Ltac ht := simp; repeat step.
Ltac conseq := simplify; eapply HtConsequence.
Ltac use_IH H := conseq; [ apply H | .. ]; ht.
Ltac loop_inv0 Inv := (eapply HtWeaken; [ apply HtLoop with (I := Inv) | .. ])
                      || (eapply HtConsequence; [ apply HtLoop with (I := Inv) | .. ]).
Ltac loop_inv Inv := loop_inv0 Inv; ht.
Ltac use H := (eapply use_lemma; [ eapply H | cancel; auto ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ eapply H | cancel; auto ] | ]).

Ltac heq := intros; apply himp_heq; split.

(* That's the end of the largely unexplained automation.  Let's prove some
 * programs! *)

(** ** Swapping with two pointers *)

Definition swap p q :=
  tmpp <- Read p;
  tmpq <- Read q;
  _ <- Write p tmpq;
  Write q tmpp.

(* Looking at the precondition here, note how we no longer work with explicit
 * functions over heaps.  All that is hidden within the assertion language.
 * Also note that the definition of [*] gives us nonaliasing of [p] and [q] for
 * free! *)
Theorem swap_ok : forall p q a b,
  {{p |-> a * q |-> b}}
    swap p q
  {{_ ~> p |-> b * q |-> a}}.
Proof.
  unfold swap.
  (* [simp] is our generic simplifier for this file. *)
  simp.
  (* We generally just keep calling [step] to advance forward by one atomic
   * statement. *)
  step.
  step.
  (* We do often want to use [simp] to clean up the goal after [step] infers an
   * intermediate assertion. *)
  simp.
  step.
  step.
  simp.
  step.
  step.
  simp.
  step.
  (* The [cancel] procedure repeatedly finds matching subformulas on the two
   * sides of [===>], removing them and recurring, possibly learning the values
   * of some unification variables each time. *)
  cancel.
  subst.
  cancel.
Qed.

Opaque swap.
(* This command prevents later proofs from peeking inside the implementation of
 * [swap].  Instead, we only reason about it through [swap_ok]. *)

(* Two swaps in a row provide a kind of rotation across three addresses. *)
Definition rotate p q r :=
  _ <- swap p q;
  swap q r.

Theorem rotate_ok : forall p q r a b c,
  {{p |-> a * q |-> b * r |-> c}}
    rotate p q r
  {{_ ~> p |-> b * q |-> c * r |-> a}}.
Proof.
  unfold rotate.
  simp.
  step.
  (* Now we invoke our earlier theorem by name.  Note that its precondition only
   * matches a subset of our current precondition.  The rest of state is left
   * alone, which we can prove "for free" by the frame rule. *)
  use swap_ok.
  simp.
  use swap_ok.
  simp.
  cancel.
Qed.

Opaque rotate.

(** ** Initializing a fresh object *)

Definition init :=
  p <- Alloc 2;
  _ <- Write p 7;
  _ <- Write (p+1) 8;
  Return p.

Theorem init_ok :
  {{emp}}
    init
  {{p ~> p |--> [7; 8]}}.
Proof.
  unfold init.
  simp.
  step.
  step.
  simp.
  step.
  step.
  simp.
  step.
  step.
  simp.
  step.
  cancel.
Qed.

Opaque init.

Theorem the_circle_of_life_ok :
  {{emp}}
    p <- init;
    Free p 2
  {{_ ~> emp}}.
Proof.
  step.
  use init_ok.
  simp.
  step.
  cancel.
Qed.

Theorem ultra_combo_ok :
  {{emp}}
    p <- init;
    _ <- swap p (p+1);
    Return p
  {{p ~> p |--> [8; 7]}}.
Proof.
  step.
  use init_ok.
  simp.
  step.
  use swap_ok.
  simp.
  step.
  cancel.
Qed.

(** ** In-place reversal of a singly linked list *)

(* Let's give a recursive definition of how a linked list should be laid out in
 * memory. *)
Fixpoint linkedList (p : nat) (ls : list nat) :=
  match ls with
  | nil => [| p = 0 |]
    (* An empty list is associated with a null pointer and no memory
     * contents. *)
  | x :: ls' => [| p <> 0 |]
                * exists p', p |--> [x; p'] * linkedList p' ls'
    (* A nonempty list is associated with a nonnull pointer and a two-cell
     * struct, which points to a further list. *)
  end%sep.

(* The definition of [linkedList] is recursive in the list.  Let's also prove
 * lemmas for simplifying [linkedList] invocations based on values of [p]. *)

Theorem linkedList_null : forall ls,
  linkedList 0 ls === [| ls = nil |].
Proof.
  (* Tactic [heq] breaks an equivalence into two implications. *)
  heq; cases ls; cancel.
Qed.

Theorem linkedList_nonnull : forall {p ls},
  p <> 0
  -> linkedList p ls === exists x ls' p', [| ls = x :: ls' |] * p |--> [x; p'] * linkedList p' ls'.
Proof.
  heq; cases ls; cancel; match goal with
                         | [ H : _ = _ :: _ |- _ ] => invert H
                         end; cancel.
Qed.

Local Hint Rewrite <- rev_alt.
Local Hint Rewrite rev_involutive.

(* Let's hide the definition of [linkedList], so that we *only* reason about it
 * via the two lemmas we just proved. *)
Opaque linkedList.

(* In-place linked-list reverse, the "hello world" of separation logic! *)
Definition reverse p :=
  pr <- for pr := (p, 0) loop
    let (p, r) := pr in
    if p ==n 0 then
      Return (Done pr)
    else
      tmp <- Read (p + 1);
      _ <- Write (p+1) r;
      Return (Again (tmp, p))
  done;
  Return (snd pr).

(* Helper function to peel away the [Done]/[Again] status of a [loop_outcome] *)
Definition valueOf {A} (o : loop_outcome A) :=
  match o with
  | Done v => v
  | Again v => v
  end.

Theorem reverse_ok : forall p ls,
  {{linkedList p ls}}
    reverse p
  {{r ~> linkedList r (rev ls)}}.
Proof.
  unfold reverse.
  simp.
  step.
  (* When we reach a loop, we give the invariant with a special tactic. *)
  loop_inv (fun o => exists ls1 ls2, [| ls = rev_append ls1 ls2 |]
                                     * linkedList (fst (valueOf o)) ls2
                                     * linkedList (snd (valueOf o)) ls1
                                     * [| match o with
                                          | Done (p, _) => p = 0
                                          | _ => True
                                          end |])%sep.
  cases (a ==n 0); simp.
  step.
  cancel.
  step.
  (* We use [setoid_rewrite] for rewriting under binders ([exists], in this
   * case).  Note that we also specify hypothesis [n] explicitly, since
   * [setoid_rewrite] isn't smart enough to infer parameters otherwise. *)
  setoid_rewrite (linkedList_nonnull n).
  step.
  simp.
  step.
  step.
  simp.
  step.
  setoid_rewrite (linkedList_nonnull n).
  cancel.
  simp.
  setoid_rewrite linkedList_null.
  cancel.
  equality.
  simp.
  step.
  cancel.
  simp.
  setoid_rewrite linkedList_null.
  cancel.
  simp.
  cancel.
Qed.

Opaque reverse.

(* ** Calling [reverse] twice, to illustrate the *frame rule* *)

Theorem reverse_two_ok : forall p1 ls1 p2 ls2,
  {{linkedList p1 ls1 * linkedList p2 ls2}}
    p1 <- reverse p1;
    p2 <- reverse p2;
    Return (p1, p2)
  {{ps ~> linkedList (fst ps) (rev ls1) * linkedList (snd ps) (rev ls2)}}.
Proof.
  simp.
  step.
  use reverse_ok.
  simp.
  step.
  use reverse_ok.
  simp.
  step.
  cancel.
Qed.
(* Note that the intuitive correctness theorem would be *false* for lists
 * sharing any cells in common!  The inherent disjointness of [*] saves us from
 * worrying about those cases. *)

(* ** Computing the length of a linked list *)

(* To state a good loop invariant, it will be helpful to define
 * *list segments* that end with some pointer beside null. *)
Fixpoint linkedListSegment (p : nat) (ls : list nat) (q : nat) :=
  match ls with
  | nil => [| p = q |]
  | x :: ls' => [| p <> 0 |] * exists p', p |--> [x; p'] * linkedListSegment p' ls' q
  end%sep.

(* Next, two [linkedListSegment] lemmas analogous to those for [linkedList]
 * above *)

Lemma linkedListSegment_empty : forall p ls,
  linkedList p ls ===> linkedList p ls * linkedListSegment p nil p.
Proof.
  cancel.
Qed.

Lemma linkedListSegment_append : forall q r x ls p,
  q <> 0
  -> linkedListSegment p ls q * q |--> [x; r] ===> linkedListSegment p (ls ++ x :: nil) r.
Proof.
  induct ls; cancel; auto.
  subst; cancel.
  rewrite <- IHls; cancel; auto.
Qed.

(* One more [linkedList] lemma will be helpful.  We'll re-reveal the predicate's
 * definition to prove the lemma. *)

Transparent linkedList.

Lemma linkedListSegment_null : forall ls p,
  linkedListSegment p ls 0 ===> linkedList p ls.
Proof.
  induct ls; cancel; auto.
Qed.

Opaque linkedList linkedListSegment.

(* A few algebraic properties of list operations: *)
Local Hint Rewrite <- app_assoc.
Local Hint Rewrite app_length app_nil_r.

(* We tie a few of them together into this lemma. *)
Lemma move_along : forall A (ls : list A) x2 x1 x0 x,
  ls = x2 ++ x1
  -> x1 = x0 :: x
  -> ls = (x2 ++ [x0]) ++ x.
Proof.
  simp.
Qed.

Local Hint Resolve move_along : core.

Theorem length_ok : forall p ls,
  {{linkedList p ls}}
    q_len <- for q_len := (p, 0) loop
      let (q, len) := q_len in
      if q ==n 0 then
        Return (Done q_len)
      else
        tmp <- Read (q + 1);
        Return (Again (tmp, len+1))
    done;
    Return (snd q_len)
  {{len ~> linkedList p ls * [| len = length ls |]}}.
Proof.
  simp.
  step.
  loop_inv (fun o => exists ls1 ls2, [| ls = ls1 ++ ls2 |]
                                     * linkedListSegment p ls1 (fst (valueOf o))
                                     * linkedList (fst (valueOf o)) ls2
                                     * [| snd (valueOf o) = length ls1 |]
                                     * [| match o with
                                          | Done (q, _) => q = 0 /\ ls2 = nil
                                          | _ => True
                                          end |])%sep.
  cases (a ==n 0); simp.
  step.
  setoid_rewrite linkedList_null.
  cancel.
  simp.
  step.
  setoid_rewrite (linkedList_nonnull n).
  step.
  simp.
  step.
  cancel.
  simp.
  setoid_rewrite <- linkedListSegment_append.
  cancel.
  auto.
  simp.
  simp.
  rewrite linkedListSegment_empty.
  cancel.
  simp.
  step.
  cancel.
  simp.
  rewrite linkedListSegment_null.
  rewrite linkedList_null.
  cancel.
  simp.
Qed.


Require Import Coq.Init.Notations.
From mathcomp Require Import ssreflect eqtype ssrfun generic_quotient.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool.
Set Warnings "parsing".
Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Export Submodule Quotient Morphism Algebras.

Open Scope ring_scope.
Module ChainCpx.
  Definition isComplex {R : ringType} {M1 M2 M3 : lmodType R}
    (f : M1 -> M2) (g : M2 -> M3) := forall x : M1, (g \o f) x == 0.

  Inductive type {R : ringType} (M1 M2 : lmodType R) (f : M1 -> M2) :=
  |CpxStart : type M1 M2 f
  |CpxNext : forall (M3 : lmodType R) (g : M2 -> M3), (isComplex f g) ->
    (type M2 M3 g) -> type M1 M2 f.
End ChainCpx.

Module ExactSequence.
  Definition isExact {R : ringType} {M1 M2 M3 : lmodType R}
    (f : {linear M1 -> M2}) (g : {linear M2 -> M3}) := ChainCpx.isComplex f g /\ (forall y, (g y == 0 -> (exists x, f x == y))).

  Inductive exactType {R : ringType} (M1 M2 : lmodType R) (f : {linear M1 -> M2}) :=
  |ExactStart : exactType M1 M2 f
  |ExactNext : forall (M3 : lmodType R) (g : {linear M2 -> M3}), (isExact f g) ->
    (exactType M2 M3 g) -> exactType M1 M2 f.

  Definition leftZeroExact {R : ringType} (M1 M2 : lmodType R) (f : {linear M1 -> M2}) I
    := ExactNext (lmodZero.type R) M1 (linZero.map _ _) M2 f I.

  Definition rightZeroExact {R : ringType} (M2 M3 : lmodType R) (g : {linear M2 -> M3}) S
    := ExactNext M2 M3 g (lmodZero.type R) (linZero.map _ _) S (ExactStart _ _ _).

  Module Short.
    Definition shortExactSequence {R : ringType} (M1 M2 M3 : lmodType R)
      (f : {linear M1 -> M2}) (g : {linear M2 -> M3})
        (I : isExact (linZero.map _ _) f) (E : isExact f g) (S : isExact g (linZero.map _ _))
      := leftZeroExact M1 M2 f I
          (ExactNext M1 M2 f M3 g E
            (rightZeroExact M2 M3 g S)  ).

    Record ses_type {R : ringType} := SES {
      M1 : lmodType R; M2 : lmodType R; M3 : lmodType R;
      ses_f : {linear M1 -> M2};
      ses_g : {linear M2 -> M3};
      ses_I : isExact (linZero.map (lmodZero.type R) M1) ses_f;
      ses_E : isExact ses_f ses_g;
      ses_S : isExact ses_g (linZero.map M3 (lmodZero.type R));
      ses := shortExactSequence M1 M2 M3 ses_f ses_g ses_I ses_E ses_S;
    }.

    Module Exports.
      Notation ses := ses_type.
      Notation SES := SES.
      Notation "[ 'ses' '0' '-->' A '-->' B '-->' C '-->' '0' ]" :=
          (shortExactSequence A B C)
        (at level 0, format "[ 'ses' '0' '-->' A '-->' B '-->' C '-->' '0' ]",
        A at level 99, B at level 99, C at level 99).

      Notation "[ 'ses' '0' '-->' A '-->' B '-->' C '-->' '0' '|' f ',' g ]" :=
          (shortExactSequence A B C f g)
        (at level 0, format "[ 'ses' '0' '-->' A '-->' B '-->' C '-->' '0' '|' f ',' g ]",
        A at level 99, B at level 99, C at level 99).
    End Exports.
  End Short.

  Program Definition ExtendSequenceHere {R : ringType} (M1 M2 : lmodType R) (f : {linear M1 -> M2})
    : exactType M1 M2 f
   := ExactNext M1 M2 f (lmodZero.type R) (linZero.map _ _) _ (ExactStart _ _ _).
  Next Obligation. Admitted.

  Fixpoint ExtendSequence {R : ringType} {M1 M2 : lmodType R} {f : {linear M1 -> M2}}
   (es : exactType M1 M2 f) {struct es} := match es with
    |ExactNext M3 g E ES => ExactNext M1 M2 f M3 g E (ExtendSequence ES)
    |ExactStart => ExtendSequenceHere M1 M2 f
    end.
End ExactSequence.
Export ExactSequence.Short.Exports.

Set Implicit Arguments.
Unset Strict Implicit.
Module subLmodSES.
  Section Def.
    Variable (R : ringType) (M : lmodType R) (S : subLmodType M).

    Lemma isExact_ZeroToS : ExactSequence.isExact (linZero.map (lmodZeroType R) S) (subLmodIncl S).
    Proof. split=>[|y H]=>//.
      refine(ex_intro _ tt _); move: H.
      by rewrite /(eq_op _) eq_sym.
    Qed.

    Lemma isExact_SToQ : ExactSequence.isExact (subLmodIncl S) (quotLmodProj S).
    Proof. split=>[x|y H]=>//=.
      rewrite /quotPiLmod.proj=>/=.
    Admitted.

    Lemma isExact_QToZero : ExactSequence.isExact (quotLmodProj S)
      (linZero.map (quotLmod S) (lmodZeroType R)).
    Proof. split=>[x|y H]=>//=.
    refine(ex_intro _ (repr y) _).
      by rewrite /quotPiLmod.proj reprK.
    Qed.

    Definition type := [ses 0 --> S --> M --> (quotLmod S) --> 0 | (subLmodIncl S), (quotLmodProj S)] isExact_ZeroToS isExact_SToQ isExact_QToZero.
  End Def.
End subLmodSES.

Module linSES.
  Section Def.
    Variable (R : ringType) (M N : lmodType R) (f : {linear M -> N}).
    Program Definition type := [ses 0 --> \ker(f) --> M --> \image(f) --> 0].
  End Def.
End linSES.

Close Scope ring_scope.


Require Export Structure.
Require Export Categories.Slice.

Program Definition SliceTop_mixin (C: Category) (x: C) := TopCategory.Mixin (C / x)
  {|
    Slice.dom := x;
    Slice.oarr := id x;
  |}
  (fun f => {|
    Slice.arr := Slice.oarr f;
  |})
  _.
Next Obligation.
  apply comp_id_l.
Qed.
Next Obligation.
  apply Slice.hom_eq; simpl.
  rewrite <- comp_id_l.
  symmetry.
  exact (Slice.comm f).
Qed.

Canonical SliceTop (C: Category) (x: C) := TopCategory.Pack (C / x) (SliceTop_mixin C x).

Program Definition SliceBot_mixin (C: BotCategory) (x: C) := BotCategory.Mixin (C / x)
  {|
    Slice.dom := 0;
    Slice.oarr := ¡;
  |}
  (fun f => {|
    Slice.arr := ¡;
  |})
  _.
Next Obligation.
  symmetry.
  apply from_zero_unique.
Qed.
Next Obligation.
  apply Slice.hom_eq; simpl.
  apply from_zero_unique.
Qed.

Canonical SliceBot (C: BotCategory) (x: C) := BotCategory.Pack (C / x) (SliceBot_mixin C x).

Program Definition SliceCoprod_mixin (C: CoprodCategory) (x: C) := CoprodCategory.Mixin (C / x)
  (fun f g => {|
    Slice.dom := Slice.dom f + Slice.dom g;
    Slice.oarr := [Slice.oarr f, Slice.oarr g];
  |})
  (fun f g h a b => {|
    Slice.arr := [Slice.arr a, Slice.arr b];
  |})
  (fun f g => {|
    Slice.arr := in1;
  |})
  (fun f g => {|
    Slice.arr := in2;
  |})
  _.
Next Obligation.
  rewrite merge_comp.
  f_equal; apply Slice.comm.
Qed.
Next Obligation.
  apply merge_in1.
Qed.
Next Obligation.
  apply merge_in2.
Qed.
Next Obligation.
  setoid_rewrite Slice.hom_eq; simpl.
  apply merge_in.
Qed.

Canonical SliceCoprod (C: CoprodCategory) (x: C) := CoprodCategory.Pack (C / x) (SliceCoprod_mixin C x).


Require Import VST.floyd.proofauto.
Require Import triang.
Require Import spec_stdlib.
Require Import spec_pile.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope assert.

Fixpoint triang (n: nat) :=
 match n with
 | O => 0
 | S n' => Z.of_nat n + triang n'
 end.

Definition Triang_nth_spec :=
 DECLARE _Triang_nth
 WITH n:Z, gv: globals
 PRE [ _n OF tint ]
    PROP( 0 <= n < 1000)
    LOCAL(temp _n (Vint (Int.repr n)); gvars gv)
    SEP(mem_mgr gv)
 POST[ tint ]
    PROP()
    LOCAL(temp ret_temp (Vint (Int.repr (triang (Z.to_nat n)))))
    SEP(mem_mgr gv).

Definition specs := [Triang_nth_spec].


From Cat Require Import Cat.

Set Implicit Arguments.

Class isEqualizer
  (C : Cat) {A B : Ob C} (f g : Hom A B)
  (E : Ob C) (equalize : Hom E A)
  (factorize : forall {E' : Ob C} (e' : Hom E' A), e' .> f == e' .> g -> Hom E' E)
  : Prop :=
{
  ok : equalize .> f == equalize .> g;
  factorize_equalize :
    forall {E' : Ob C} (e' : Hom E' A) (H : e' .> f == e' .> g),
      factorize e' H .> equalize == e';
  equiv_equalizer :
    forall {E' : Ob C} {e1 e2 : Hom E' E},
      e1 .> equalize == e2 .> equalize -> e1 == e2;
}.

#[export] Hint Mode isEqualizer ! ! ! ! ! ! ! ! : core.
#[export] Hint Mode isEqualizer ! ! ! - - - - - : core.

Section isEqualizer.

Context
  {C : Cat} {A B : Ob C} {f g : Hom A B}
  {E : Ob C} {equalize : Hom E A}
  {factorize : forall {E' : Ob C} (e' : Hom E' A), e' .> f == e' .> g -> Hom E' E}
  {isEq : isEqualizer C f g E equalize (@factorize)}.

Arguments factorize {E' e'} _.

Lemma equiv_equalizer' :
  forall {E' : Ob C} {e1 e2 : Hom E' E},
    e1 == e2 <-> e1 .> equalize == e2 .> equalize.
Proof.
  split.
  - now intros ->.
  - now apply equiv_equalizer.
Qed.

Lemma Proper_factorize :
  forall {E' : Ob C} {e1 e2 : Hom E' A} (H1 : e1 .> f == e1 .> g) (H2 : e2 .> f == e2 .> g),
    e1 == e2 -> factorize H1 == factorize H2.
Proof.
  now intros; rewrite equiv_equalizer', !factorize_equalize.
Qed.

Lemma universal :
  forall
    [E' : Ob C] [e' : Hom E' A] (H : e' .> f == e' .> g)
    (h : Hom E' E),
      factorize H == h <-> h .> equalize == e'.
Proof.
  split.
  - now intros <-; rewrite factorize_equalize.
  - now intros Heq; rewrite equiv_equalizer', factorize_equalize.
Qed.

Lemma factorize_unique :
  forall
    [E' : Ob C] [e' : Hom E' A] (H : e' .> f == e' .> g)
    (h : Hom E' E),
      h .> equalize == e' -> h == factorize H.
Proof.
  now intros; rewrite equiv_equalizer', factorize_equalize.
Qed.

Lemma factorize_ok :
  factorize ok == id E.
Proof.
  now rewrite equiv_equalizer', factorize_equalize, comp_id_l.
Defined.

Lemma comp_factorize :
  forall {X Y : Ob C} {e1 : Hom X Y} {e2 : Hom Y A} (Heq : e2 .> f == e2 .> g),
    e1 .> factorize Heq == factorize (wut_l e1 Heq).
Proof.
  now intros; rewrite equiv_equalizer', factorize_equalize, comp_assoc, factorize_equalize.
Qed.

Lemma isMono_equalize :
  isMono equalize.
Proof.
  now intros X h1 h2 Heq; rewrite equiv_equalizer'.
Qed.

End isEqualizer.

Ltac equalizer_simpl :=
  repeat (rewrite
    ?comp_factorize, ?equiv_equalizer', ?factorize_equalize, ?factorize_ok,
    ?comp_id_l, ?comp_id_r, ?comp_assoc).

Section Traditional.

Context
  [C : Cat]
  [X Y : Ob C]
  [f g : Hom X Y].

Lemma isEqualizer_uiso :
  forall
    {E1 : Ob C} {equalize1 : Hom E1 X}
    {factorize1 : forall (E1' : Ob C) (e1' : Hom E1' X), e1' .> f == e1' .> g -> Hom E1' E1}
    {E2 : Ob C} {equalize2 : Hom E2 X}
    {factorize2 : forall (E2' : Ob C) (e2' : Hom E2' X), e2' .> f == e2' .> g -> Hom E2' E2},
      isEqualizer C f g E1 equalize1 factorize1 ->
      isEqualizer C f g E2 equalize2 factorize2 ->
        exists!! f : Hom E1 E2, isIso f /\ equalize1 == f .> equalize2.
Proof.
  intros * H1 H2.
  exists (factorize2 E1 equalize1 ok).
  repeat split.
  - exists (factorize1 E2 equalize2 ok).
    now rewrite !equiv_equalizer', !comp_assoc, !factorize_equalize, !comp_id_l.
  - now rewrite factorize_equalize.
  - now intros y [_ ?]; rewrite equiv_equalizer', factorize_equalize.
Qed.

Lemma isEqualizer_iso :
  forall
    {E1 : Ob C} {e1 : Hom E1 X}
    {factorize1 : forall (E1' : Ob C) (e1' : Hom E1' X), e1' .> f == e1' .> g -> Hom E1' E1}
    {E2 : Ob C} {e2 : Hom E2 X}
    {factorize2 : forall (E2' : Ob C) (e2' : Hom E2' X), e2' .> f == e2' .> g -> Hom E2' E2},
      isEqualizer C f g E1 e1 factorize1 ->
      isEqualizer C f g E2 e2 factorize2 ->
        E1 ~ E2.
Proof.
  now intros; destruct (isEqualizer_uiso H H0) as [i []]; exists i.
Qed.

Lemma isEqualizer_equiv_equalize :
  forall
    (E : Ob C) (equalize1 equalize2 : Hom E X)
    (factorize : forall (E' : Ob C) (e : Hom E' X), e .> f == e .> g -> Hom E' E),
      isEqualizer C f g E equalize1 factorize ->
      isEqualizer C f g E equalize2 factorize ->
        equalize1 == equalize2.
Proof.
  now intros; rewrite <- comp_id_l, <- factorize_ok, factorize_equalize.
Qed.

Lemma isEqualizer_equiv_factorize :
  forall
    (E : Ob C) (equalize : Hom E X)
    (factorize1 factorize2 :
      forall (E' : Ob C) (e' : Hom E' X), e' .> f == e' .> g -> Hom E' E),
      isEqualizer C f g E equalize factorize1 ->
      isEqualizer C f g E equalize factorize2 ->
        forall (E' : Ob C) (e' : Hom E' X) (H : e' .> f == e' .> g),
          factorize1 E' e' H == factorize2 E' e' H.
Proof.
  now intros; rewrite equiv_equalizer', !factorize_equalize.
Qed.

Lemma isIso_equalize :
  forall
    (E : Ob C) (equalize : Hom E X)
    (factorize : forall (E' : Ob C) (e' : Hom E' X), e' .> f == e' .> g -> Hom E' E),
      isEqualizer C f g E equalize factorize -> isEpi equalize -> isIso equalize.
Proof.
  intros * HisEq HisEpi; red.
  assert (Hfg : id X .> f == id X .> g) by (rewrite !comp_id_l; apply HisEpi, ok).
  exists (factorize _ (id X) Hfg).
  now rewrite equiv_equalizer', comp_assoc, factorize_equalize, comp_id_l, comp_id_r.
Qed.

End Traditional.

Class HasEqualizers (C : Cat) : Type :=
{
  equalizer :
    forall {X Y : Ob C}, Hom X Y -> Hom X Y -> Ob C;
  equalize :
    forall {X Y : Ob C} (f g : Hom X Y), Hom (equalizer f g) X;
  factorize :
    forall [X Y : Ob C] [f g : Hom X Y] [E' : Ob C] (e' : Hom E' X),
      e' .> f == e' .> g -> Hom E' (equalizer f g);
  isEqualizer_HasEqualizers :>
    forall {X Y : Ob C} (f g : Hom X Y),
      isEqualizer C f g (equalizer f g) (equalize f g) (@factorize _ _ f g)
}.

Arguments equalizer [C _ X Y] _ _.
Arguments equalize  [C _ X Y] _ _.
Arguments factorize [C _ X Y f g E'] _ _.


Module FeatureModelSemantics.
Require Export Coq.Lists.ListSet.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export formulatheory_int.
Require Export formulatheory_def.
Import FormulaTheory.

  Definition wfFM_func (fm : FM) : Prop := (wfTree_func fm) /\
    (wfFormulae_func fm).

  Definition satImpConsts_func (fm : FM) (c : Configuration) : Prop :=
  forall n: Name, set_In n (c) -> set_In n (fst fm).

  Definition satExpConsts_func (fm : FM) (c : Configuration) : Prop :=
  forall f: Formula, set_In f (snd fm) -> (satisfies_func f c = True).

  Definition Is_truePB (b:Prop) : bool :=
    match b with
      | True => true
    end.

  Fixpoint filter_func (fm:FM) (s: set Configuration) : set Configuration :=
    match s with
    | nil => nil
    | a1 :: x1 =>
          if Is_truePB ((satImpConsts_func fm a1) /\
              (satExpConsts_func fm a1)) then a1 :: filter_func fm x1
           else filter_func fm x1
    end.

Fixpoint genConf_func (fm : set Name) : set Configuration :=
  match fm with
  | nil => nil
  | x :: xs => (set_add conf_dec_axiom (set_add name_dec_axiom x (nil)) (genConf_func xs)) ++ (genConf_func xs)
  end.

  Definition semantics_func (fm : FM) : set Configuration :=
    filter_func fm (genConf_func (ns_func fm)).

  Definition refines_func (abs : FM) (con : FM) : Prop :=
    if andb (Is_truePB (wfFM_func abs)) (Is_truePB(wfFM_func con)) then
      forall (conf : Configuration), set_In conf (semantics_func abs)
        -> set_In conf (semantics_func con)
          else False.

  Definition refines2_func (abs : FM) (con : FM) : Prop :=
    forall (conf1 : Configuration), set_In conf1 (semantics_func abs) ->
      exists (conf2 : Configuration),  set_In conf2 (semantics_func con).

  Definition nsf_func (fm : FM) : set Name := fst fm.

End FeatureModelSemantics.


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

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Numbers.DecimalString.
Require Import Coq.NArith.NArith.
Require Import Coq.Strings.String.
Require Import Cava.Util.List. (* TODO: From cava 1 *)

Require Import Cava.Types.
Require Import Cava.Expr.
Require Import Cava.Semantics.

Local Open Scope N.

Section Var.
  Import ExprNotations.
  Import PrimitiveNotations.
  Context {var : tvar}.

  Definition fork2 {A} : Circuit [] [A] (A ** A) := {{
    fun a => (a, a)
  }}.

  Definition fib_init sz : denote_type (BitVec sz) := 2^(N.of_nat sz)-1.

  Definition fibonacci {sz: nat}: Circuit (BitVec sz ** BitVec sz) [] (BitVec sz) := {{
    let/delay r1 :=
      let r2 := delay r1 initially (fib_init sz) in
      r1 + r2
      initially (1: denote_type (BitVec sz)) in
    r1
  }}.
End Var.

Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import coqutil.Tactics.Tactics.
Require Import Cava.Util.List.
Require Import Cava.Util.Tactics.

Fixpoint fibonacci_nat (n : nat) :=
  match n with
  | 0 => 0
  | S m =>
    let f_m := fibonacci_nat m in
    match m with
    | 0 => 1
    | S p => fibonacci_nat p + f_m
    end
  end%nat.

Definition spec_of_fibonacci (sz : nat) (input : list unit) : list N
  := map (fun n => N.of_nat (fibonacci_nat n) mod (2 ^ N.of_nat sz))%N (seq 0 (List.length input)).

Lemma fork2_step A state input : step (fork2 (A:=A)) state (input, tt) = (tt, (input, input)).
Proof. reflexivity. Qed.

Lemma fibonacci_step sz state input :
  step (fibonacci (sz:=sz)) state input
  =
    let sum := (fst state + snd state) mod (2 ^ N.of_nat sz) in
    (sum, fst state, sum).
Proof.
  intros; cbn [step fibonacci Bv2N Vector.of_list Primitives.binary_semantics ].
  repeat (destruct_pair_let; cbn [split_absorbed_denotation combine_absorbed_denotation List.app absorb_any fst snd ]).
  reflexivity.
Qed.

Definition fibonacci_invariant {sz: nat}
           (t : nat) (loop_state : N * N)
           (output_accumulator : list (N)) : Prop :=
  let r1 := fst loop_state in
  let r2 := snd loop_state in
  (* at timestep t... *)
  (* ...r1 holds fibonacci_nat (t-1), or 1 if t=0 *)
  r1 = match t with
       | 0%nat => 1
       | S t_minus1 =>
         (N.of_nat (fibonacci_nat t_minus1) mod (2 ^ N.of_nat sz))
       end
  (* ... and r2 holds fibonacci_nat (t-2), or 1 if t=1, 2^sz-1 if t=0 *)
  /\ r2 = match t with
         | 0%nat => (2 ^ N.of_nat sz - 1)
         | 1%nat => 1
         | S (S t_minus2) => N.of_nat(fibonacci_nat t_minus2) mod (2 ^ N.of_nat sz)
         end
  (* ... and the output accumulator matches the circuit spec for the
     inputs so far *)
  /\ output_accumulator = spec_of_fibonacci sz (repeat tt t).

(* Helper lemma for fibonacci_correct *)
Lemma fibonacci_nat_step n :
  fibonacci_nat (S (S n)) = (fibonacci_nat (S n) + fibonacci_nat n)%nat.
Proof. cbn [fibonacci_nat]. lia. Qed.

Lemma fibonacci_correct sz input :
  simulate (fibonacci (sz:=sz)) input = spec_of_fibonacci sz input.
Proof.
  cbv [simulate simulate'].
  fold (fold_left_accumulate (step (fibonacci (sz:=sz))) input (reset_state fibonacci)).
  rewrite fold_left_accumulate_to_seq with (default:=tt).
  assert (2 ^ (N.of_nat sz) <> 0) by (apply N.pow_nonzero; lia).
  eapply fold_left_accumulate_invariant_seq with (I:=fibonacci_invariant (sz:=sz)).
  { cbv [fibonacci_invariant]. ssplit; reflexivity. }
  { cbv [fibonacci_invariant].
    intros; destruct_products; cbn [fst snd] in *; subst; cbn [fst snd].
    rewrite fibonacci_step. cbn [fst snd].
    repeat destruct_one_match.
    { (* t = 0 case *)
      rewrite N.sub_1_r, N.add_1_l, N.succ_pred; try apply H.
      rewrite N.mod_same, N.mod_0_l;
        ssplit; try reflexivity; try apply H.
      }
    { (* t = 1 case *)
      ssplit; reflexivity.
    }
    { (* t > 1 case *)
      rewrite N.add_mod_idemp_r, N.add_mod_idemp_l by lia.
      ssplit.
      { cbn [fibonacci_nat]. f_equal; lia. }
      { reflexivity. }
      { cbv [spec_of_fibonacci].
        autorewrite with push_length.
        rewrite seq_S with (len:=S (S _)).
        autorewrite with natsimpl. rewrite map_app.
        cbn [map]. rewrite fibonacci_nat_step.
        rewrite Nat2N.inj_add.
        reflexivity. } } }
  { cbv [fibonacci_invariant]. intros.
    logical_simplify; subst.
    autorewrite with push_length.
    erewrite <-list_unit_equiv. reflexivity. }
Qed.