Require Export Hask.Ltac.
Require Export Coq.Program.Equality.
Require Export Coq.Unicode.Utf8.
Require Export FunctionalExtensionality.
Require Export Iso.
Require Export Tuple.

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

Section Indexed.

Variable A : Type.

Definition transp (P Q : A → Type) := ∀ x : A, P x → Q x.

Notation "s :→ t" := (transp s t) (at level 28).

Definition pid {X} : X :→ X.
  unfold ":→". intros.
  apply X0.
Defined.

Definition pcompose {X Y Z} : (Y :→ Z) → (X :→ Y) → (X :→ Z).
  unfold ":→". intros.
  apply X0. apply X1. apply X2.
Defined.

End Indexed.

Arguments transp {A} _ _.
Arguments pid {A X} _ _.
Arguments pcompose {A X Y Z} _ _ _ _.

Infix ":→" := transp (at level 100).
Infix ":∘" := pcompose (at level 40, left associativity).

Module SimpleCategory.

(** This is a simple treatment of categories, useful here only for proving
    statements from Conor's paper. *)

Class Category {k} (cat : k → k → Type) := {
    id : ∀ {a}, cat a a;
    compose : ∀ {a b c}, cat b c → cat a b → cat a c;

    id_left : ∀ {a} (f : cat a a), compose id f = f;
    id_right : ∀ {a} (f : cat a a), compose f id = f;
    comp_assoc : ∀ {a b c d} (f : cat c d) (g : cat b c) (h : cat a b),
      compose f (compose g h) = compose (compose f g) h
}.

#[export]
Program Instance Index_Category {A} : Category (@transp A) := {
    id      := @pid A;
    compose := @pcompose A
}.

End SimpleCategory.

(** * Predicate functors *)

Class PFunctor {I O} (F : (I → Type) → (O → Type)) := {
    pobj := F;
    pmap : ∀ {X Y}, (X :→ Y) → (F X :→ F Y);

    pfun_identity : ∀ {X}, pmap (@pid _ X) = pid;
    pfun_composition : ∀ {X Y Z} (f : Y :→ Z) (g : X :→ Y),
      pmap f :∘ pmap g = pmap (f :∘ g)
}.

Notation "pmap[ M ]" := (@pmap _ _ M _ _ _) (at level 9).
Notation "pmap[ M N ]" := (@pmap _ _ (λ X, M (N X)) _ _ _) (at level 9).
Notation "pmap[ M N O ]" := (@pmap _ _ (λ X, M (N (O X))) _ _ _) (at level 9).

Coercion pobj : PFunctor >-> Funclass.

Lemma pfun_irrelevance `(F : PFunctor)
  : ∀ (f g : ∀ {X Y}, (X :→ Y) → (F X :→ F Y))
      i i' c c',
  @f = @g →
  {| pmap := @f
   ; pfun_identity    := i
   ; pfun_composition := c |} =
  {| pmap := @g
   ; pfun_identity    := i'
   ; pfun_composition := c' |}.
Proof.
  intros. subst. f_equal.
  apply proof_irrelevance.
  apply proof_irrelevance.
Qed.

(** * Path *)

(** This is a demonstration of PFunctor, showing "type-aligned lists" as paths
    within a graph. *)

Section Path.

Variable I : Type.
Variable g : (I * I) → Type.

Inductive Path : (I * I) → Type :=
  | Stop : ∀ {i : I}, Path (i,i)
  | Link : ∀ {i j k : I}, g (i,j) → Path (j,k) → Path (i,k).

Notation "f :-: g" := (Link f g) (at level 50).

Fixpoint path_compose {i j k} (x : Path (i,j)) (y : Path (j,k)) : Path (i,k).
Proof.
  intros.
  inversion x; subst. assumption.
  inversion y; subst. assumption.
  apply @Link with (j := j0).
    assumption.
  apply path_compose with (j := j); assumption.
Defined.

Lemma path_right_id : ∀ i j (x : Path (i,j)), path_compose x Stop = x.
Proof. dependent destruction x; reflexivity. Qed.

#[export] Hint Rewrite path_right_id : core.
#[export] Hint Resolve path_right_id : core.

Lemma path_left_id : ∀ i j (x : Path (i,j)), path_compose Stop x = x.
Proof. dependent destruction x; reflexivity. Qed.

#[export] Hint Rewrite path_left_id : core.
#[export] Hint Resolve path_left_id : core.

Lemma path_compose_spec
  : ∀ {i j k l : I} (x : g (i,j)) (xs : Path (j,k)) (ys : Path (k,l)),
  path_compose (x :-: xs) ys = x :-: path_compose xs ys.
Proof.
  intros.
  dependent destruction xs;
  dependent destruction ys; reflexivity.
Qed.

Definition path_comp_assoc
  {i j k l} (x : Path (i,j)) (y : Path (j,k)) (z : Path (k,l)) :
  path_compose x (path_compose y z) = path_compose (path_compose x y) z.
Proof.
  dependent destruction x;
  dependent destruction y;
  dependent destruction z; auto.
  dependent induction x.
    reflexivity.
  rewrite path_compose_spec.
  rewrite IHx.
  rewrite <- path_compose_spec.
  rewrite <- path_compose_spec.
  reflexivity.
Qed.

Import SimpleCategory.

#[export]
Program Instance Path_Category : Category (fun i j => Path (i,j)) := {
    id      := @Stop;
    compose := fun _ _ _ x y => path_compose y x
}.
Obligation 3.
  dependent destruction f.
    autorewrite with core.
    reflexivity.
  rewrite path_comp_assoc.
  reflexivity.
Qed.

End Path.

Arguments Path {I} g _.
Arguments Stop {I g i}.
Arguments Link {I g i j k} _ _.

Notation "f :-: g" := (Link f g) (at level 50).

Definition path_pmap {I} {k h : (I * I) → Type} (f : k :→ h)
  {x : I * I} (p : Path k x) : Path h x.
  induction p.
    apply Stop.
  apply (Link (f _ g) IHp).
Defined.

#[export]
Program Instance Path_PFunctor {I} : @PFunctor (I * I) (I * I) (@Path I) := {
    pmap := @path_pmap I
}.
Obligation 1.
  compute.
  extensionality x.
  extensionality p. induction p.
    reflexivity.
  f_equal. apply IHp.
Qed.
Obligation 2.
  compute.
  extensionality x.
  extensionality p. induction p.
    reflexivity.
  f_equal. apply IHp.
Qed.

Lemma path_pmap_compose : ∀ I (q r : I * I → Type)
  (f : q :→ r) i j k (z : Path q (i,j)) (s : Path q (j,k)),
  path_compose I r (path_pmap f z) (path_pmap f s) =
  path_pmap f (path_compose I q z s).
Proof.
  dependent induction z; auto.
  dependent destruction s; auto.
  simpl in *.
  f_equal.
  rewrite <- (IHz r f k).
  f_equal.
Qed.

(** * PAssign *)

(** PAssign is "a particularly useful constructor of indexed sets, capturing
    that idea of having an element of a given type at a particular key index."
    -- Conor *)

Inductive PAssign {I : Type} (a : Type) (k : I) : I → Type :=
  | V : a → PAssign a k k.

Arguments V {I a k} _.

Infix "::=" := PAssign (at level 50).

#[export]
Program Instance KeyIndex_Iso : ∀ (a I : Type) (t : I → Type) (k : I),
  ((a ::= k) :→ t) ≅ (a → t k).
Obligation 1.
  unfold ":→" in X.
  apply X. constructor.
  apply X0.
Defined.
Obligation 2.
  unfold ":→". intros.
  inversion X0; subst.
  apply X. apply X1.
Defined.

(** The following shows that a Path whose indices are fixed at unit is
    equivalent to a list. *)

Definition list_to_Path : ∀ {a}, list a → Path (a ::= (tt, tt)) (tt, tt).
  intros.
  induction X.
    apply Stop.
  apply @Link with (j := tt).
  apply V. apply a0.
  apply IHX.
Defined.

Definition Path_to_list : ∀ {a}, Path (a ::= (tt, tt)) (tt, tt) → list a.
  intros.
  induction X.
    apply nil.
  apply cons.
  inversion g. apply X0.
  apply IHX.
Defined.

(*
#[export]
Program Instance Path_List_Iso
  : ∀ a, list a ≅ Path (a ::= (tt, tt)) (tt, tt) := {
    to   := list_to_Path;
    from := Path_to_list
}.
Obligation 1.
  extensionality l.
  induction l. reflexivity.
  compute. f_equal.
  apply IHl.
Qed.
Obligation 2.
  compute.
  extensionality p.
  dependent induction p. auto.
  destruct j.
  rewrite IHp; auto.
  f_equal.
  dependent destruction g.
  reflexivity.
Qed.
*)

(** * PMonad *)

(** We now show that some endo-PFunctors can also be PMonads. *)

Reserved Notation "c ?>= f" (at level 25, left associativity).

Class PMonad {I} (m : (I → Type) → (I → Type)) `{PFunctor I I m} := {
    is_pfunctor :> PFunctor m;

    pskip   : ∀ {p}, p :→ m p;
    pextend : ∀ {p q}, (p :→ m q) → (m p :→ m q)
      where "c ?>= f" := (pextend f _ c);

    imonad_left_id : ∀ (p q : I → Type) (f : p :→ m q) (i : I) (a : p i),
      pskip i a ?>= f = f i a;
    imonad_right_id : ∀ (p q : I → Type) (f : p :→ m q) (i : I) (m : m p i),
      m ?>= pskip = m;
    imonad_assoc : ∀ (p q r : I → Type)
      (f : p :→ m q) (g : q :→ m r) (i : I) (m : m p i),
      (m ?>= f) ?>= g = m ?>= (λ x a, f x a ?>= g)
}.

Arguments pskip {I m H PMonad p _} _.
Arguments pextend {I m H PMonad p q _} _ _.

Coercion is_pfunctor : PMonad >-> PFunctor.

Notation "c ?>= f" := (pextend f _ c) (at level 25, left associativity).

Definition angbind `{m : PMonad}
  {a j q} (f : a → m q j) : m (a ::= j) :→ m q :=
  pextend ((λ _ x, match x with V a => f a end) : (a ::= j) :→ m q).

Notation "c =>= f" := (angbind f _ c) (at level 25, left associativity).

Definition pjoin {I} `{m : PMonad I} {p} : m (m p) :→ m p :=
  pextend (λ (x : I) (X : m p x), X).

(** An ordinary monad on indexed types induces an indexed monad on ordinary
    types, packaging the restricted functionality offered by the angelic
    bind. -- Conor *)

Definition Atkey {I : Type} (m : (I → Type) → (I → Type)) i j a :=
  m (a ::= j) i.

Definition ireturn `{m : PMonad} {i a} (x : a) : Atkey m i i a :=
  pskip (V x).

Definition ibind `{m : PMonad} {i j k a b}
  : Atkey m i j a → (a → Atkey m j k b) → Atkey m i k b :=
  fun x f => angbind f _ x.

Definition iseq `{m : PMonad} {p q r} (f : p :→ m q) (g : q :→ m r)
  : p :→ m r := pextend g :∘ f.

(** Paths are also PMonads. *)

Fixpoint path_join {I : Type} {g : (I * I) → Type} {i}
  (p : Path (Path g) i) : Path g i :=
  match p with
  | Stop k => Stop
  | Link _ _ _ x xs => path_compose I g x (path_join xs)
  end.

Lemma path_join_compose : ∀ I (g : I * I → Type)
  i j k (z : Path (Path g) (i,j)) (s : Path (Path g) (j,k)),
  path_compose I g (path_join z) (path_join s) =
  path_join (path_compose I (Path g) z s).
Proof.
  intros.
  dependent induction z; auto;
  dependent destruction s; simpl; auto.
    rewrite path_right_id.
    reflexivity.
  rewrite <- IHz. simpl.
  repeat rewrite path_comp_assoc.
  reflexivity.
Qed.

#[export]
Program Instance Path_PMonad {I} : PMonad (@Path I) := {
    pskip := fun p (x : I * I) =>
      (let (i, j) as z return (p z → Path p z) := x in
       λ Y : p (i, j), Y :-: Stop)
}.
Obligation 1.
  unfold ":→" in *. intros.
  apply (pmap X) in X0.
  apply path_join in X0.
  assumption.
Defined.
Obligation 2.
  unfold Path_PMonad_obligation_1. simpl.
  apply path_right_id.
Qed.
Obligation 3.
  unfold Path_PMonad_obligation_1. simpl.
  dependent induction m. reflexivity.
  specialize (IHm _ f).
  simpl. rewrite IHm.
  dependent destruction m; auto.
Qed.
Obligation 4.
  unfold Path_PMonad_obligation_1. simpl.
  dependent induction m. reflexivity.
  simpl. rewrite <- IHm.
  rewrite <- path_pmap_compose.
  rewrite path_join_compose. reflexivity.
Qed.

(** We now formalize a notion of indexed monads ala Atkey, prove that the
    Atkey definition fulfills them, and thereafter we can trust that Atkey is
    a specialization of PMonad.  We must keep IxApplicative, however, since we
    do not have applicatives in the general case. *)

Module Atkey.

Class IxFunctor {I O} (F : I → O → Type → Type) :=
{ ixobj := F
; ixmap : ∀ {I O X Y}, (X → Y) → F I O X → F I O Y

; ixfun_identity : ∀ {I O X}, @ixmap I O _ _ (@id X) = id
; ixfun_composition : ∀ {I O X Y Z} (f : Y → Z) (g : X → Y),
    ixmap f \o ixmap g = @ixmap I O _ _ (f \o g)
}.

Notation "f <$$> g" := (ixmap f g) (at level 28, left associativity).

Notation "ixmap[ M ]" := (@ixmap M _ _ _) (at level 9).
Notation "ixmap[ M N ]" := (@ixmap (fun X => M (N X)) _ _ _) (at level 9).
Notation "ixmap[ M N O ]" := (@ixmap (fun X => M (N (O X))) _ _ _) (at level 9).

Coercion ixobj : IxFunctor >-> Funclass.

Lemma ixfun_irrelevance `(F : IxFunctor)
  : ∀ (f g : ∀ {I O X Y}, (X -> Y) → (F I O X -> F I O Y))
      i i' c c',
  @f = @g →
  {| ixmap := @f
   ; ixfun_identity    := i
   ; ixfun_composition := c |} =
  {| ixmap := @g
   ; ixfun_identity    := i'
   ; ixfun_composition := c' |}.
Proof.
  intros. subst. f_equal.
  apply proof_irrelevance.
  apply proof_irrelevance.
Qed.

Section IxFunctor.

Variables I O : Type.
Context `{@IxFunctor I O F}.

Theorem ixfun_identity_x : forall {I O X} (x : F I O X), ixmap id x = id x.
Proof.
  intros.
  rewrite ixfun_identity.
  reflexivity.
Qed.

Theorem ixfun_composition_x
  : forall {I O X Y Z} (f : Y -> Z) (g : X -> Y) (x : F I O X),
  f <$$> (g <$$> x) = (f \o g) <$$> x.
Proof.
  intros.
  rewrite <- ixfun_composition.
  reflexivity.
Qed.

End IxFunctor.

#[export]
Program Instance Atkey_IxFunctor {I : Type} `{H : PFunctor I I F}
  : IxFunctor (Atkey F) := {
    ixmap := fun _ O X Y f x =>
      pmap (fun (i : I) (x : (X ::= O) i) =>
              match x with V a => V (f a) end) _ x
}.
Obligation 1.
  destruct H. simpl in *.
  extensionality x.
  unfold id.
  assert ((λ (i : I) (x0 : (X ::= O) i),
      match
        x0 as x1 in ((_ ::= _) i0) return (i0 = i → x1 ~= x0 → (X ::= O) i0)
      with
      | V a => λ (_ : O = i) (_ : V a ~= x0), V a
      end eq_refl JMeq_refl) = pid).
    extensionality i.
    extensionality x0.
    destruct x0. unfold pid. reflexivity.
    rewrite H. clear H.
  rewrite pfun_identity0.
  unfold pid. reflexivity.
Qed.
Obligation 2.
  destruct H. simpl in *.
  unfold comp.
  unfold pcompose in *.
  extensionality x.
  remember
    (λ (i : I) (x0 : (Y ::= O) i),
      match
        x0 as x1 in ((_ ::= _) i0) return (i0 = i → x1 ~= x0 → (Z ::= O) i0)
      with
      | V a => λ (_ : O = i) (_ : V a ~= x0), V (f a)
      end eq_refl JMeq_refl) as f'.
  remember
    (λ (i : I) (x0 : (X ::= O) i),
      match
        x0 as x1 in ((_ ::= _) i0)
        return (i0 = i → x1 ~= x0 → (Y ::= O) i0)
      with
      | V a => λ (_ : O = i) (_ : V a ~= x0), V (g a)
      end eq_refl JMeq_refl) as g'.
  specialize (pfun_composition0 (X ::= O) (Y ::= O) (Z ::= O) f' g').
  assert
    ((λ (i : I) (x0 : (X ::= O) i),
       match
         x0 as x1 in ((_ ::= _) i0) return (i0 = i → x1 ~= x0 → (Z ::= O) i0)
       with
       | V a => λ (_ : O = i) (_ : V a ~= x0), V (f (g a))
       end eq_refl JMeq_refl) =
     (λ (x : I) (X2 : (X ::= O) x), f' x (g' x X2))).
    subst.
    extensionality i.
    extensionality x0.
    destruct x0.
    reflexivity.
    rewrite H. clear H.
  rewrite <- pfun_composition0.
  reflexivity.
Qed.

Reserved Notation "f <**> g" (at level 28, left associativity).

Class IxApplicative {I} (F : I → I → Type → Type) :=
{ is_ixfunctor :> IxFunctor F

; ixpure : ∀ {I X}, X → F I I X
; ixap : ∀ {I J K X Y}, F I J (X → Y) → F J K X → F I K Y
    where "f <**> g" := (ixap f g)

; ixapp_identity : ∀ {I X}, @ixap _ _ I _ _ (@ixpure I _ (@id X)) = id
; ixapp_composition
    : ∀ {I J K L X Y Z}
        (u : F I J (Y → Z)) (v : F J K (X → Y)) (w : F K L X),
    ixpure comp <**> u <**> v <**> w = u <**> (v <**> w)
; ixapp_homomorphism : ∀ {I X Y} (x : X) (f : X → Y),
    ixpure f <**> ixpure x = @ixpure I _ (f x)
; ixapp_interchange : ∀ {I J X Y} (y : X) (u : F I J (X → Y)),
    u <**> ixpure y = ixpure (fun f => f y) <**> u

; app_ixmap_unit : ∀ {I O X Y} (f : X → Y), ixap (ixpure f) = @ixmap _ _ _ _ I O _ _ f
}.

Notation "ixpure[ M ]" := (@ixpure M _ _) (at level 9).
Notation "ixpure[ M N ]" := (@ixpure (fun X => M (N X)) _ _) (at level 9).

Notation "ixap[ M ]" := (@ixap M _ _ _) (at level 9).
Notation "ixap[ M N ]" := (@ixap (fun X => M (N X)) _ _ _) (at level 9).
Notation "ixap[ M N O ]" := (@ixap (fun X => M (N (O X))) _ _ _) (at level 9).

Notation "f <**> g" := (ixap f g) (at level 28, left associativity).

(* Notation "[| f x y .. z |]" := (.. (f <$$> x <**> y) .. <**> z) *)
(*     (at level 9, left associativity, f at level 9, *)
(*      x at level 9, y at level 9, z at level 9). *)

Definition ixapp_merge {X Y Z W} (f : X → Y) (g : Z → W)
  (t : X * Z) : Y * W  :=
  match t with (x, z) => (f x, g z) end.

Definition ixapp_prod `{IxApplicative T F}
  {I J K X Y} (x : F I J X) (y : F J K Y)
  : F I K (X * Y)%type := pair <$$> x <**> y.

Notation "f *** g" := (ixapp_merge f g) (at level 28, left associativity).

Notation "f ** g" := (ixapp_prod f g) (at level 28, left associativity).

Ltac rewrite_ixapp_homomorphisms :=
  (repeat (rewrite <- app_ixmap_unit);
   rewrite ixapp_homomorphism;
   repeat (rewrite app_ixmap_unit)).

Section IxApplicative.

Variables I : Type.
Context `{@IxApplicative I F}.

Theorem app_pmap_compose : ∀ I A B (f : A → B),
  ixpure \o f = ixmap f \o @ixpure _ _ _ I _.
Proof.
  intros.
  extensionality x.
  unfold comp.
  rewrite <- ixapp_homomorphism.
  rewrite app_ixmap_unit.
  reflexivity.
Qed.

Theorem app_pmap_compose_x : ∀ J A B (f : A → B) (x : A),
  ixpure (f x) = ixmap f (@ixpure _ F _ J _ x).
Proof.
  intros.
  assert (ixpure (f x) = (@ixpure _ F _ J _ \o f) x).
    unfold comp. reflexivity.
  assert (ixmap f (ixpure x) = (ixmap f \o @ixpure _ _ _ J _) x).
    unfold comp. reflexivity.
  rewrite H0. rewrite H1.
  rewrite app_pmap_compose.
  reflexivity.
Qed.

Theorem ixapp_identity_x : ∀ {I X} {x : F I I X},
  ixap (ixpure (@id X)) x = id x.
Proof.
  intros.
  rewrite app_ixmap_unit.
  apply ixfun_identity_x.
Qed.

Theorem ixapp_homomorphism_2
  : ∀ {I X Y Z} (x : X) (y : Y) (f : X → Y → Z),
  f <$$> ixpure x <**> ixpure y = @ixpure _ _ _ I _ (f x y).
Proof.
  intros.
  rewrite <- ixapp_homomorphism.
  rewrite <- ixapp_homomorphism.
  rewrite app_ixmap_unit.
  reflexivity.
Qed.

(* This theorem was given as an exercise by Brent Yorgey at:

   http://www.haskell.org/haskellwiki/Typeclassopedia#IxApplicative
*)
Theorem ixapp_flip : ∀ {J K X Y} (x : F J K X) (f : X → Y),
  ixpure f <**> x = ixpure (fun a b => b a) <**> x <**> ixpure f.
Proof.
  intros.
  rewrite ixapp_interchange.
  rewrite <- ixapp_composition.
  rewrite app_ixmap_unit.
  rewrite app_ixmap_unit.
  rewrite ixapp_homomorphism_2.
  unfold comp.
  rewrite app_ixmap_unit.
  reflexivity.
Qed.

Theorem ixapp_embed
  : ∀ {GI G} `{IxApplicative GI G}
           {I J K X Y} (x : G I J (X → Y)) (y : G J K X),
  ixpure (x <**> y) = ixpure ixap <**> ixpure x <**> @ixpure _ _ _ K _ y.
Proof.
  intros.
  rewrite_ixapp_homomorphisms.
  rewrite <- ixapp_homomorphism.
  rewrite <- app_ixmap_unit.
  reflexivity.
Qed.

Theorem ixapp_split
  : ∀ I J K A B C (f : A → B → C) (x : F I J A) (y : F J K B),
  f <$$> x <**> y = uncurry f <$$> (x ** y).
Proof.
  intros. unfold ixapp_prod.
  repeat (rewrite <- app_ixmap_unit).
  repeat (rewrite <- ixapp_composition).
  repeat (rewrite ixapp_homomorphism).
  unfold uncurry, comp.
  reflexivity.
Qed.

Theorem ixapp_naturality
  : ∀ {I J K A B C D}
      (f : A → C) (g : B → D) (u : F I J A) (v : F J K B),
  ixmap (f *** g) (u ** v) = (ixmap f u) ** (ixmap g v).
Proof.
  intros.
  unfold ixapp_prod.
  rewrite <- app_ixmap_unit.
  rewrite ixfun_composition_x.
  repeat (rewrite <- app_ixmap_unit).
  rewrite <- ixapp_composition.
  rewrite <- ixapp_composition.
  rewrite <- ixapp_composition.
  rewrite <- ixapp_composition.
  rewrite ixapp_composition.
  rewrite ixapp_composition.
  rewrite_ixapp_homomorphisms.
  rewrite ixfun_composition_x.
  rewrite ixfun_composition_x.
  rewrite ixapp_interchange.
  rewrite app_ixmap_unit.
  rewrite ixfun_composition_x.
  reflexivity.
Qed.

(*
  Theorem app_left_identity {I A} (v : F I I A) : (F I I unit * v) ≅ v.
  Proof.
    intros.
    unfold app_prod, app_unit.
    rewrite_app_homomorphisms.
    split.
      assert (pmap (pair tt) =
              (@from (F (unit * A)) (F A)
                     (Functor_Isomorphism _ LTuple_Isomorphism))).
        reflexivity. rewrite H0. clear H0.
      apply iso_from_x.
      reflexivity.
  Qed.

  Theorem app_right_identity `(v : F A) : (v ** ixpure tt) ≡ v.
  Proof.
    intros.
    unfold app_prod, app_unit.
    rewrite <- app_ixmap_unit.
    rewrite app_interchange.
    rewrite <- app_composition.
    rewrite app_homomorphism.
    rewrite app_homomorphism.
    rewrite app_ixmap_unit.
    unfold comp.
    split.
      assert (pmap (fun x : A => (x, tt)) =
              (@from (F (A * unit)) (F A)
                     (Functor_Isomorphism _ RTuple_Isomorphism))).
        reflexivity. rewrite H0.
      apply iso_from_x.
      reflexivity.
  Qed.
*)

Theorem ixapp_embed_left_triple
  : ∀ I J K L A B C
      (u : F I J A) (v : F J K B) (w : F K L C),
  u ** v ** w = left_triple <$$> u <**> v <**> w.
Proof.
  intros.
  unfold ixapp_prod.
  repeat (rewrite <- app_ixmap_unit).
  rewrite <- ixapp_composition.
  rewrite_ixapp_homomorphisms.
  rewrite ixfun_composition_x.
  reflexivity.
Qed.

Theorem ixapp_embed_right_triple
  : ∀ I J K L A B C
      (u : F I J A) (v : F J K B) (w : F K L C),
  u ** (v ** w) = right_triple <$$> u <**> v <**> w.
Proof.
  intros.
  unfold ixapp_prod.
  repeat (rewrite <- app_ixmap_unit).
  rewrite <- ixapp_composition.
  repeat (rewrite app_ixmap_unit).
  rewrite ixfun_composition_x.
  repeat (rewrite <- app_ixmap_unit).
  rewrite <- ixapp_composition.
  repeat (rewrite app_ixmap_unit).
  rewrite ixfun_composition_x.
  rewrite ixapp_interchange.
  rewrite app_ixmap_unit.
  rewrite ixfun_composition_x.
  unfold comp.
  reflexivity.
Qed.

(*
  Theorem ixapp_associativity
    : ∀ A B C (u : F I J A) (v : F J K B) (w : F K L C),
    ((u ** v) ** w) ≡ (u ** (v ** w)).
  Proof.
    intros.
    rewrite ixapp_embed_left_triple.
    rewrite ixapp_embed_right_triple.
    split; simpl;
    repeat (rewrite <- app_ixmap_unit);
    rewrite <- ixapp_composition;
    rewrite <- ixapp_composition;
    rewrite <- ixapp_composition;
    repeat f_equal;
    repeat (rewrite app_ixmap_unit);
    rewrite pfun_composition_x;
    rewrite pfun_composition_x;
    rewrite <- app_pmap_compose_x;
    rewrite ixapp_homomorphism;
    reflexivity.
  Qed.
*)

Definition liftIA2 {I J K A B C} (f : A → B → C)
  (x : F I J A) (y : F J K B) : F I K C :=
  f <$$> x <**> y.

End IxApplicative.

#[export]
Program Instance Atkey_IxApplicative {I : Type} `{H : PMonad I F}
  : IxApplicative (Atkey F) := {
  ixpure := fun _ _ => pskip \o V
}.
Obligation 1.
  pose (@ibind I F H0 H I0 J K (X → Y) Y).
  apply a in X0.
  assumption. intros.
  pose (@ibind I F H0 H J K K X Y).
  apply a0 in X1.
  assumption. intros.
  apply X2 in X3.
  unfold Atkey.
  pose (@ireturn I F H0 H K Y).
  apply a1.
  assumption.
Defined.
Obligation 2.
  unfold Atkey_IxApplicative_obligation_1.
  extensionality X1. unfold id.
  destruct H. destruct H0. simpl in *.
  rewrite imonad_left_id0.
  destruct is_pfunctor0.
  assert
    ((fun (H0 : I) (x : @PAssign I X I0 H0) =>
         match
           x in (@PAssign _ _ _ y)
           return
             (@pobj I I
                (@pobj I I F
                   (Build_PFunctor I I F pmap1 pfun_identity1
                      pfun_composition1))
                (Build_PFunctor I I F pmap1 pfun_identity1 pfun_composition1)
                (@PAssign I X I0) y)
         with
         | V a => pskip0 (@PAssign I X I0) I0 (@V I X I0 a)
         end) = @pskip0 _).
    extensionality H1.
    extensionality x.
    destruct x. reflexivity.
    rewrite H. clear H.
  apply (imonad_right_id0 (X ::= I0) (X ::= I0)).
  auto.
Qed.
Obligation 3.
  unfold Atkey_IxApplicative_obligation_1; simpl.
  unfold ibind, angbind.
  rewrite imonad_left_id.
  rewrite imonad_assoc.
  rewrite imonad_assoc.
  f_equal.
  extensionality H1.
  extensionality x.
  destruct x.
  unfold ireturn.
  rewrite imonad_left_id.
  rewrite imonad_assoc.
  rewrite imonad_assoc.
  f_equal.
  extensionality x.
  extensionality a.
  destruct a.
  rewrite imonad_left_id.
  rewrite imonad_assoc.
  f_equal.
  extensionality H1.
  extensionality x.
  destruct x.
  rewrite imonad_left_id.
  reflexivity.
Qed.
Obligation 4.
  unfold Atkey_IxApplicative_obligation_1; simpl.
  unfold ibind, angbind.
  rewrite imonad_left_id.
  rewrite imonad_left_id.
  reflexivity.
Qed.
Obligation 5.
  unfold Atkey_IxApplicative_obligation_1; simpl.
  unfold ibind, angbind.
  rewrite imonad_left_id.
  f_equal.
  extensionality H1.
  extensionality x.
  destruct x.
  rewrite imonad_left_id.
  reflexivity.
Qed.
Obligation 6.
  unfold Atkey_IxApplicative_obligation_1; simpl.
  unfold ibind, ireturn, angbind.
  extensionality x.
  rewrite imonad_left_id.
Admitted.

Definition ixapp_unit `{IxApplicative _ F} : F unit unit unit := ixpure tt.

Reserved Notation "m >>>= f" (at level 25, left associativity).

Class IxMonad {I} (M : I → I → Type → Type) :=
{ is_ixapplicative :> IxApplicative M

; ixbind : ∀ {I J K X Y}, M I J X → (X -> M J K Y) → M I K Y
    where "m >>>= f" := (ixbind m f)

; ixmonad_left_id : ∀ {I O X Y} (f : X → M I O Y) (x : X),
    ixpure x >>>= f = f x
; ixmonad_right_id : ∀ {I O X} (m : M I O X), m >>>= ixpure = m
; ixmonad_assoc : ∀ {I J K L X Y Z} (m : M I J X)
    (f : X → M J K Y) (g : Y → M K L Z),
    (m >>>= f) >>>= g = m >>>= (λ x, f x >>>= g)
}.

#[export]
Program Instance Atkey_IxMonad {I : Type} `{H : PMonad I F}
  : IxMonad (Atkey F) := {
  ixbind := @ibind I F _ H
}.
Obligation 1.
  unfold ibind, angbind.
  rewrite imonad_left_id.
  reflexivity.
Qed.
Obligation 2.
  unfold ibind, angbind.
  destruct H0. destruct H. simpl in *.
  assert
    ((fun (H : I) (x : @PAssign I X O H) =>
         match
           x in (@PAssign _ _ _ y)
           return
             (@pobj I I (@pobj I I F is_pfunctor0) is_pfunctor0
                (@PAssign I X O) y)
         with
         | V a => pskip0 (@PAssign I X O) O (@V I X O a)
         end) = @pskip0 _).
    extensionality H.
    extensionality x.
    destruct x.
    reflexivity.
    rewrite H. clear H.
  apply (imonad_right_id0 _ (X ::= O)).
  apply pskip0.
Qed.
Obligation 3.
  unfold ibind, angbind.
  rewrite imonad_assoc.
  f_equal.
  extensionality x.
  extensionality a.
  destruct a.
  reflexivity.
Qed.

End Atkey.

Module Kleene.

Record Signature (I O : Type) : Type := {
    Operations : O → Type;
    Arities    : forall o : O, Operations o → Type;
    Sorts      : forall (o : O) (op : Operations o), Arities o op → I
}.

Arguments Operations {I O} _ i.
Arguments Arities {I O} _ {_} op.
Arguments Sorts {I O} _ {_} {_} ar.

Infix "▷" := Signature (at level 60) : type_scope.
Infix "o ◁ a / s" := ({| Operations := o
                       ; Arities := a
                       ; Sorts := s |}) (at level 40).

Record WFunctor {I O} (S : I ▷ O) (X : I → Type) (o : O) : Type := {
    op : Operations S o;
    ar : Arities S op;
    xx : X (Sorts S ar)
}.

Arguments op {I O S X} o _.
Arguments ar {I O S X} o _.
Arguments xx {I O S X} o _.

Coercion op : WFunctor >-> Operations.
Coercion WFunctor : Signature >-> Funclass.

#[export]
Program Instance WFunctor_PFunctor {I O} (S : I ▷ O) : PFunctor (WFunctor S).
Obligation 1.
  unfold ":→". intros.
  destruct X1.
  eexists.
  apply X0 in xx0. apply xx0.
Defined.
Obligation 2.
  compute.
  extensionality x.
  extensionality F.
  destruct F. reflexivity.
Qed.
Obligation 3.
  compute.
  extensionality x.
  extensionality F.
  destruct F. reflexivity.
Qed.

Inductive Kleene {I O} (S : I ▷ O) (p : I → Type) (i : I) :=
| Ret : p i → Kleene S p i
| Do  : forall o : O, WFunctor S (Kleene S p) o → Kleene S p i.

Arguments Ret {I O S p i} _.
Arguments Do {I O S p i} o _.

Infix ":*" := Kleene (at level 25, left associativity).

Fixpoint Kleene_extend {I O} (F : I ▷ O)
  {p q : I → Type} (f : p :→ Kleene F q) i (x : Kleene F p i)
  {struct x} : Kleene F q i.
Proof.
  destruct x as [y | r].
    apply (f i y).
  apply (Do r).
  destruct w.
  eexists.
  apply (Kleene_extend _ _ _ p q f).
  apply xx0.
Defined.

Fixpoint Kleene_map {I O} (F : I ▷ O)
  {X Y} (f : X :→ Y) i (x : (F :* X) i) {struct x} : (F :* Y) i.
Proof.
  destruct x.
    apply (Ret (f i x)).
  apply (Do o).
  destruct w.
  eexists.
  apply (Kleene_map I O F X Y f).
  apply xx0.
Defined.

Fixpoint Kleene_identity {I O} (F : I ▷ O)
  {X : I → Type} {i : I} (x : (F :* X) i) :
  Kleene_map F pid i x = pid i x.
Proof.
  destruct x. reflexivity.
  destruct w.
  unfold pid in *. simpl.
  f_equal. f_equal.
  apply Kleene_identity.
Qed.

Fixpoint Kleene_composition {I O} (F : I ▷ O)
  (X Y Z : I → Type) (f : Y :→ Z) (g : X :→ Y)
  (i : I) (x : (F :* X) i) {struct x} :
  (Kleene_map F f :∘ Kleene_map F g) i x = Kleene_map F (f :∘ g) i x.
Proof.
  unfold pcompose.
  destruct x. reflexivity.
  destruct w. simpl.
  f_equal. f_equal.
  apply Kleene_composition.
Qed.

#[export]
Program Instance Kleene_PFunctor {I O} (F : I ▷ O)
  : PFunctor (Kleene F) := {
    pmap := fun _ _ => Kleene_map F
}.
Obligation 1.
  extensionality i.
  extensionality x.
  apply Kleene_identity.
Qed.
Obligation 2.
  extensionality i.
  extensionality x.
  apply Kleene_composition.
Qed.

Fixpoint Kleene_left_id {I O} (F : I ▷ O)
  (p q : I → Type) (f : p :→ F :* q) (i : I) (m : (F :* p) i) :
  Kleene_extend F (λ H : I, Ret) i m = m.
Proof.
  destruct m. reflexivity.
  destruct w. simpl.
  f_equal. f_equal.
  apply (Kleene_left_id I O F p q).
  assumption.
Qed.

Fixpoint Kleene_assoc {I O} (F : I ▷ O)
  (p q r : I → Type) (f : p :→ F :* q) (g : q :→ F :* r)
  (i : I) (m : (F :* p) i) :
  Kleene_extend F g i (Kleene_extend F f i m) =
  Kleene_extend F (λ (x : I) (a : p x), Kleene_extend F g x (f x a)) i m.
Proof.
  destruct m. reflexivity.
  destruct w. simpl.
  f_equal. f_equal.
  apply (Kleene_assoc I O F p q r).
Qed.

#[export]
Program Instance Kleene_PMonad {I O} (F : I ▷ O)
  : PMonad (Kleene F) := {
    pskip := fun _ _ => Ret;
    pextend := @Kleene_extend I O F
}.
Obligation 2.
  apply (Kleene_left_id F p q).
  assumption.
Qed.
Obligation 3.
  apply (Kleene_assoc F p q r).
Qed.

End Kleene.

Module IAlgebra.

Inductive RProd {I} (p q r : I → Type) (i : I) :=
  mkRProd : p i → (q :→ r) → RProd p q r i.

Arguments mkRProd {I p q r i} _ _.

Infix ":>>:" := RProd (at level 25, left associativity).
Infix ":&" := mkRProd (at level 25, left associativity).

#[export]
Program Instance RProd_PFunctor {I} (p q : I → Type) : PFunctor (p :>>: q) := {
    pmap := fun _ _ h _ x => match x with p :& k => p :& (h :∘ k) end
}.
Obligation 1.
  extensionality H.
  extensionality x.
  destruct x.
  reflexivity.
Qed.
Obligation 2.
  extensionality H.
  extensionality x.
  destruct x.
  reflexivity.
Qed.

Inductive RSum {I O} (f g : (I → Type) → (O → Type)) (p : I → Type) (i : O) :=
  | InL : f p i → RSum f g p i
  | InR : g p i → RSum f g p i.

Arguments InL {I O f g p i} _.
Arguments InR {I O f g p i} _.

Infix ":+:" := RSum (at level 25, left associativity).

#[export]
Program Instance RSum_PFunctor {I O} `{PFunctor I O f, PFunctor I O g}
  : PFunctor (f :+: g) := {
    pmap := fun _ _ h _ x =>
      match x with
      | InL fp => InL (@pmap I O f _ _ _ h _ fp)
      | InR gp => InR (@pmap I O g _ _ _ h _ gp)
      end
}.
Obligation 1.
  extensionality H1.
  extensionality x.
  destruct x;
  rewrite pfun_identity; reflexivity.
Qed.
Obligation 2.
  extensionality H1.
  extensionality x.
  destruct x;
  [ destruct H | destruct H0 ];
  simpl in *;
  unfold pcompose in *; f_equal;
  specialize (pfun_composition0 X Y Z f0 g0);
  rewrite <- pfun_composition0; reflexivity.
Qed.

End IAlgebra.

Module SAlgebra.

Import Kleene.

Definition 𝒫 (X : Type) := X → Type.

Definition Alg {O} (Σ : O ▷ O) (X : 𝒫 O) : Type := Σ X :→ X.

(* jww (2014-10-10): WRONG *)
Definition sdo {O C X} : @Alg O C (C :* X).
Proof.
  unfold Alg, ":→". intros.
  apply (Do x).
  apply X0.
Defined.

(* jww (2014-10-10): WRONG *)
Definition generic {O} {Σ : O ▷ O} `{PMonad _ Σ} {o : O} (p : Operations Σ o)
  : (Σ :* (λ o', forall a : Arities Σ p, Sorts Σ a = o')) o.
Proof.
  apply pskip. intros.
Admitted.

(*
Inductive μ {O} (Σ : O ▷ O) (o : O) : Type := sup : Alg Σ (μ Σ) → μ Σ o.

Fixpoint iter {O} {C : O ▷ O} {X} (φ : Alg C X)
  {o : O} (x : μ C o) {struct x} : X o :=
  match x with
  | sup p k => φ p (pmap (fun a y => @iter O C X φ a y) p k)
  end.
*)

Definition sid {O} : O ▷ O :=
  {| Operations := λ _, True
   ; Arities    := λ _ _, True
   ; Sorts      := λ o _ _, o |}.

(*
Definition sconst {I O} (p : 𝒫 O) : I ▷ O :=
  {| Operations := p
   ; Arities    := λ _ _, False
   ; Sorts      := λ x _ unit, undefined |}.
*)

Definition sor {I O} (x y : I ▷ O) : I ▷ O :=
  match x with {| Operations := P₁
                ; Arities    := A₁
                ; Sorts      := s₁ |} =>
  match y with {| Operations := P₂
                ; Arities    := A₂
                ; Sorts      := s₂ |} =>
  {| Operations := λ x, (P₁ x + P₂ x)%type

   ; Arities := λ o op,
       match op with
       | inl op' => A₁ o op'
       | inr op' => A₂ o op'
       end

   ; Sorts := λ o op,
       match op with
       | inl op' => s₁ o op'
       | inr op' => s₂ o op'
       end
   |}
  end
  end.

(* This one is written using tactics because the dependent matching required
   is rather ugly. *)
Definition sand {I O} (x y : I ▷ O) : I ▷ O.
  destruct x. destruct y.
  eapply
    {| Operations := λ x, (Operations0 x * Operations1 x)%type
     ; Arities    := λ o op, let (op₁, op₂) := op in
                             (Arities0 o op₁ + Arities1 o op₂)%type |}.
  Grab Existential Variables.
  intros.
  destruct op0.
  destruct X.
    apply (Sorts0 o o0 a).
  apply (Sorts1 o o1 a).
Defined.

Definition State (S : Set) : S ▷ S :=
  sor {| Operations := λ _, True
       ; Arities    := λ s _, forall s' : S, s = s'
       ; Sorts      := λ s _ _, s
       |}
      {| Operations := λ _, S
       ; Arities    := λ _ _, True
       ; Sorts      := λ _ s _, s
       |}.

(*
Definition get {S} {s : S} : (State S :* ((forall s' : S, s = s') ::= s)) s.

Definition put {S} {s s' : S} : (State S :* (unit ::= s')) s.
*)

End SAlgebra.

Module Hoare.

Import Kleene.

Inductive FilePath := FilePath_.

Inductive State := Open | Closed.

(*
Definition FH' : (State → Type) → State → Type :=
      ((FilePath ::= Closed) :>>: (fun _ => State))  (* fOpen *)
  :+: ((unit ::= Open) :>>: (option nat ::= Open))   (* fGetC *)
  :+: ((unit ::= Open) :>>: (unit ::= Closed)).      (* fClose *)

Definition FH : Signature State :=
  {| Operations := fun st : State => State -> Type
   ; Arities    := fun (st : State) ops => FH' ops st
   ; Sorts      := fun (st : State) ops ars => st |}.
*)

(*
Definition fOpen (p : FilePath) : (FH :* (const State)) Closed.
Proof.
  apply Do.
  apply {| op := _
         ; ar := _
         ; xx := @Ret _ _ _
         |}.
  eexists.
  apply Ret.
  apply Closed.
  Grab Existential Variables.
  constructor.
  constructor.
Defined.

Definition fGetC : (FH :* (Maybe Char := Open)) Open :=
  Do (InR (InL (V () :& k))).

Definition fClose : (FH :* (unit := Closed)) Open :=
  Do (InR (InR (V () :& k))).
*)

End Hoare.

Module PState.

Inductive PState {I} (S P : I → Type) (i : I) :=
  mkPState : (S i → (P i * S i)) → PState S P i.

Arguments mkPState {I S P i} _.

Definition runPState {I} {S P : I → Type} {i} (x : PState S P i) :=
  match x with mkPState f => f end.

Definition pget {I} {S : I → Type} {i} : PState S S i :=
  mkPState (fun s : S i => (s, s)).

Definition pgets {I} {S T : I → Type} {i} (f : S :→ T) : PState S T i :=
  mkPState (fun s : S i => (f i s, s)).

Definition pput {I} {S : I → Type} {i} (s : S i) : PState S (fun _ => unit) i :=
  mkPState (fun _ : S i => (tt, s)).

Definition pmodify {I} (S : I → Type) {i} (f : S :→ S)
  : PState S (fun _ => unit) i :=
  mkPState (fun s : S i => (tt, f i s)).

#[export]
Program Instance PState_PFunctor {I} (S : I → Type)
  : PFunctor (PState S) := {
    pmap := fun X Y f i x =>
      mkPState (fun st => let (a,st') := runPState x st in (f i a, st'))
}.
Obligation 1.
  extensionality i.
  extensionality x.
  unfold pid. destruct x.
  f_equal.
  extensionality st. simpl.
  destruct (p st).
  reflexivity.
Qed.
Obligation 2.
  extensionality i.
  extensionality x.
  unfold pcompose.
  f_equal.
  extensionality st.
  destruct x.
  simpl.
  destruct (p st).
  reflexivity.
Qed.

#[export]
Program Instance PState_PMonad {I} (S : I → Type) : PMonad (PState S) := {
    pskip := fun p i x => mkPState (fun st => (x, st));
    pextend := fun p q f i x => mkPState (fun st =>
      let (y, st') := runPState x st in
      runPState (f i y) st')
}.
Obligation 1.
  destruct (f i a). simpl.
  f_equal.
Qed.
Obligation 2.
  destruct m. simpl.
  f_equal.
  extensionality st.
  destruct (p0 st).
  reflexivity.
Qed.
Obligation 3.
  destruct m. simpl.
  f_equal.
  extensionality st.
  destruct (p0 st).
  reflexivity.
Qed.

End PState.


(** * Repr: Representation Predicates *)

Set Implicit Arguments.
From SLF Require Import LibSepReference.
Import ProgramSyntax DemoPrograms.
From SLF Require Import Basic.
Open Scope liblist_scope.
(* From Coq Require Import Lists.List. *)

Implicit Types n m : int.
Implicit Types p q s c : loc.

(* ################################################################# *)
(** * First Pass *)

(** SOONER AC: polish
    As explained in the preface
    chapters from there on are made of 3 parts:
    first pass, more details, optional material.
    *)

(** This chapter introduces the notion of representation predicate,
    which is typically used for describing mutable data structures.
    For example, this chapter introduces the heap predicate [MList L p]
    to describe a mutable linked list whose head cell is at location [p],
    and whose elements are described by the Coq list [L].

    This chapter explains how to specify and verify functions that
    operate on mutable linked lists and mutable trees. It also presents
    representation predicates for functions that capture local state,
    such as a counter function.

    This chapter assumes a programming language featuring records,
    and it assumes the Separation Logic to support heap predicates for
    describing records. For example, [p ~~~>`{ head := x; tail := q}]
    describes a record allocated at location [p], with a head field
    storing the value [x] and a tail field storing the value [q].
    In this course, for simplicity, we implement field names as natural
    numbers---e.g., [head] is defined as [0] and [tail] as [1]. Details
    on the formalization of records are postponed to chapter [Struct].

    This chapter introduces a few additional tactics:

    - [xfun] to reason about a function definition.
    - [xchange] for exploiting transitivity of [==>]. *)

(* ================================================================= *)
(** ** Formalization of the List Representation Predicate *)

(** A mutable list cell is a two-cell record, featuring a head field and a
    tail field. *)

Definition head : field := 0%nat.
Definition tail : field := 1%nat.

(** The heap predicate [p ~~~>`{ head := x; tail := q}] describes a
    record allocated at location [p], with a head field storing [x]
    and a tail field storing [q]. *)

(** A mutable list consists of a chain of cells, terminated by [null].

    The heap predicate [MList L p] describes a list whose head cell is
    at location [p], and whose elements are described by the list [L].
    This predicate is defined recursively on the structure of [L]:

    - if [L] is empty, then [p] is the null pointer,
    - if [L] is of the form [x::L'], then [p] is not null, the
      head field of [p] contains [x], and the tail field of [p]
      contains a pointer [q] such that [MList L' q] describes the
      tail of the list. *)

Fixpoint MList (L:list val) (p:loc) : hprop :=
  match L with
  | nil => \[p = null]
  | x::L' => \exists q, (p ~~~> `{ head := x; tail := q}) \* (MList L' q)
  end.

(* ================================================================= *)
(** ** Alternative Characterizations of [MList] *)

(** The following reformulations are helpful in proofs, allowing us to
    fold or unfold the definition using a tactic called [xchange]. *)

Lemma MList_nil : forall p,
  (MList nil p) = \[p = null].
Proof using. auto. Qed.

Lemma MList_cons : forall p x L',
  MList (x::L') p =
  \exists q, (p ~~~> `{ head := x; tail := q}) \* (MList L' q).
Proof using. auto. Qed.

(** Another characterization of [MList L p] is useful for proofs. Whereas
    the original definition is by case analysis on whether [L] is empty,
    the alternative one is by case analysis on whether [p] is null:

    - if [p] is null, then [L] is empty,
    - otherwise, [L] decomposes as [x::L'], the head field of [p] contains [x],
      and the tail field of [p] contains a pointer [q] such that [MList L' q]
      describes the tail of the list.

    The lemma below is stated using an entailment. The reciprocal entailment
    is also true, but we do not need it so we do not bother proving it here. *)

Lemma MList_if : forall (p:loc) (L:list val),
      (MList L p)
  ==> (If p = null
        then \[L = nil]
        else \exists x q L', \[L = x::L']
             \* (p ~~~> `{ head := x; tail := q}) \* (MList L' q)).
Proof using.
  (* Let's prove this result by case analysis on [L]. *)
  intros. destruct L as [|x L'].
  { (* Case [L = nil]. By definition of [MList], we have [p = null]. *)
    xchange MList_nil. intros M.
    (* We have to justify [L = nil], which is trivial.
       The TLC [case_if] tactic performs a case analysis on the argument
       of the first visible [if] conditional. *)
    case_if. xsimpl. auto. }
  { (* Case [L = x::L']. *)
  (* One possibility is to perform a rewrite operation using [MList_cons]
     on its first occurrence. Then using CFML the tactic [xpull] to extract
     the existential quantifiers out from the precondition:
     [rewrite MList_cons. xpull. intros q.]
     A more efficient approach is to use the dedicated CFML tactic [xchange],
     which is specialized for performing updates in the current state. *)
    xchange MList_cons. intros q.
    (* Because a record is allocated at location [p], the pointer [p]
       cannot be null. The lemma [hrecord_not_null] allows us to exploit
       this property, extracting the hypothesis [p <> null]. We use again
       the tactic [case_if] to simplify the case analysis. *)
    xchange hrecord_not_null. intros N. case_if.
    (* To conclude, it suffices to correctly instantiate the existential
       quantifiers. The tactic [xsimpl] is able to guess the appropriate
       instantiations. *)
     xsimpl. auto. }
Qed.

Global Opaque MList.

(* ================================================================= *)
(** ** In-place Concatenation of Two Mutable Lists *)

(** The function [append] shown below expects a nonempty list [p1] and a list
    [p2], and it updates [p1] in place so that its tail gets extended by the
    cells from [p2].

OCaml:

    let rec append p1 p2 =
      if p1.tail == null
        then p1.tail <- p2
        else append p1.tail p2
*)

Definition append : val :=
  <{ fix 'f 'p1 'p2 =>
       let 'q1 = 'p1`.tail in
       let 'b = ('q1 = null) in
       if 'b
         then 'p1`.tail := 'p2
         else 'f 'q1 'p2 }>.

(** The append function is specified and verified as follows. The
    proof pattern is representative of that of many list-manipulating
    functions, so it is essential that the reader follow through every
    step of the proof. *)

Lemma Triple_append : forall (L1 L2:list val) (p1 p2:loc),
  p1 <> null ->
  triple (append p1 p2)
    (MList L1 p1 \* MList L2 p2)
    (fun _ => MList (L1++L2) p1).
Proof using.
(** The induction principle provides an hypothesis for the tail of [L1],
    i.e., for the list [L1'], such that the relation [list_sub L1' L1]
    holds. *)
  introv K. gen p1. induction_wf IH: list_sub L1. introv N. xwp.
(** To begin the proof, we reveal the head cell of [p1].
    We let [q1] denote the tail of [p1], and [L1'] the tail of [L1]. *)
  xchange (MList_if p1). case_if. xpull. intros x q1 L1' ->.
(** We then reason about the case analysis. *)
  xapp. xapp. xif; intros Cq1.
(** If [q1'] is null, then [L1'] is empty. *)
  { xchange (MList_if q1). case_if. xpull. intros ->.
(** In this case, we set the pointer, then we fold back the head cell. *)
    xapp. xchange <- MList_cons. }
(** Otherwise, if [q1'] is not null, we reason about the recursive call using
       the induction hypothesis, then we fold back the head cell. *)
  { xapp. xchange <- MList_cons. }
Qed.

(* ================================================================= *)
(** ** Smart Constructors for Linked Lists *)

Implicit Types x : val.

(** This section introduces two smart constructors for linked lists,
    called [mnil] and [mcons].

    The operation [mnil()] is intended to create an empty list.
    Its implementation simply returns the value [null]. Its
    specification asserts that the return value is a pointer [p]
    such that [MList nil p] holds. *)

Definition mnil : val :=
  <{ fun 'u =>
       null }>.

Lemma triple_mnil :
  triple (mnil ())
    \[]
    (funloc p => MList nil p).
Proof using. xwp. xval. xchanges* <- (MList_nil null). Qed.

Hint Resolve triple_mnil : triple.

(** Observe that the specification [triple_mnil] does not mention
    the [null] pointer anywhere. This specification may thus be
    used to specify the behavior of operations on mutable lists
    without having to reveal low-level implementation details that
    involve the [null] pointer. *)

(** The operation [mcons x q] is intended to allocate a fresh list cell,
    with [x] in the head field and [q] in the tail field. The implementation
    of this operation allocates and initializes a fresh record made of
    two fields. The allocation operation leverages the [New] construct, which
    is notation for a operation called [val_new_hrecord_2], which we here view
    as a primitive operation. (The chapter [Struct] describes an encoding
    of this function in terms of the allocation and write operations.) *)

Definition mcons : val :=
  <{ fun 'x 'q =>
       `{ head := 'x; tail := 'q } }>.

(** The operation [mcons] admits two specifications: one that describes only
    the fresh record allocated, and one that combines it with a list
    representation of the form [Mlist q L] to produce as postcondition
    an extended list of the form [Mlist p (x::L)].

    The first specification is as follows. *)

Lemma triple_mcons : forall x q,
  triple (mcons x q)
    \[]
    (funloc p => p ~~~> `{ head := x ; tail := q }).
Proof using. xwp. xapp triple_new_hrecord_2; auto. xsimpl*. Qed.

(** The second specification is derived from the first. *)

Lemma triple_mcons' : forall L x q,
  triple (mcons x q)
    (MList L q)
    (funloc p => MList (x::L) p).
Proof using.
  intros. xtriple. xapp triple_mcons.
  intros p. xchange <- MList_cons. xsimpl*.
Qed.

Hint Resolve triple_mcons' : triple.

(* ================================================================= *)
(** ** Copy Function for Lists *)

(** The function [mcopy] takes a mutable linked list and builds
    an independent copy of it.

    This program illustrates the use the of functions [mnil] and
    [mcons], and gives another example of a proof by induction.

OCaml:

    let rec mcopy p =
      if p == null
        then mnil ()
        else mcons (p.head) (mcopy p.tail)
*)

Definition mcopy : val :=
  <{ fix 'f 'p =>
       let 'b = ('p = null) in
       if 'b
         then mnil ()
         else
           let 'x = 'p`.head in
           let 'q = 'p`.tail in
           let 'q2 = ('f 'q) in
           mcons 'x 'q2 }>.

(** The precondition of [mcopy] requires a linked list [MList L p].
    Its postcondition asserts that the function returns a pointer [p']
    and a list [MList L p'], in addition to the original list [MList L p].
    The two lists are totally disjoint and independent, as captured by
    the separating conjunction symbol (the star). *)

Lemma triple_mcopy : forall L p,
  triple (mcopy p)
    (MList L p)
    (funloc p' => (MList L p) \* (MList L p')).
(** The proof script is very similar in structure to the previous ones.
    While playing the script, try to spot the places where:

    - [mnil] produces an empty list of the form [MList nil p'],
    - the recursive call produces a list of the form [MList L' q'],
    - [mcons] produces a list of the form [MList (x::L') p'].

*)

Proof using.
  intros. gen p. induction_wf IH: list_sub L.
  xwp. xapp. xchange MList_if. xif; intros C; case_if; xpull.
  { intros ->. xapp. xsimpl. intros. reflexivity. subst. xchange* <- MList_nil. }
  { intros x q L' ->. xapp. xapp. xapp. intros q'.
    xapp. intros p'. xchange <- MList_cons. xsimpl*. }
Qed.

(* ================================================================= *)
(** ** Length Function for Lists *)

(** The function [mlength] takes a mutable linked list and computes its
    length.

OCaml:

    let rec mlength p =
      if p == null
        then 0
        else 1 + mlength p.tail
*)

Definition mlength : val :=
  <{ fix 'f 'p =>
       let 'b = ('p = null) in
       if 'b
         then 0
         else (let 'q = 'p`.tail in
               let 'n = 'f 'q in
               'n + 1) }>.

(** **** Exercise: 3 stars, standard, especially useful (triple_mlength)

    Prove the correctness of the function [mlength]. *)

Lemma triple_mlength : forall L p,
  triple (mlength p)
    (MList L p)
    (fun r => \[r = val_int (length L)] \* (MList L p)).
Proof using.
  intros. gen p. induction_wf IH: list_sub L.
  xwp. xapp. xchange MList_if. xif; intros H; case_if; xpull.
  {intros ->. xval. xsimpl. reflexivity. subst.
  xchange* <- MList_nil. }
  intros x q L' ->. xapp. xapp. xapp. xchange <- MList_cons.
  xsimpl. rewrite length_cons. math.
Qed.

(** [] *)

(* ================================================================= *)
(** ** Alternative Length Function for Lists *)

(** In the previous section, the function [mlength] computes the length using a
    recursive function that returns an integer. In this section, we consider an
    alternative implementation that uses an auxiliary reference cell to
    keep track of the number of cells traversed so far. The list is traversed
    recursively, incrementing the contents of the reference once for every
    cell. The corresponding implementation is shown below. The variable [c]
    denotes the location of the auxiliary reference cell.

OCaml:

    let rec listacc c p =
      if p == null
        then ()
        else (incr c; listacc c p.tail)

    let mlength' p =
      let c = ref 0 in
      listacc c p;
      !c
*)

Definition acclength : val :=
  <{ fix 'f 'c 'p =>
       let 'b = ('p <> null) in
       if 'b then
         incr 'c;
         let 'q = 'p`.tail in
         'f 'c 'q
       end }>.

Definition mlength' : val :=
  <{ fun 'p =>
       let 'c = ref 0 in
       acclength 'c 'p;
       get_and_free 'c }>.

(** **** Exercise: 3 stars, standard, especially useful (triple_mlength')

    Prove the correctness of the function [mlength'].
    Hint: start by stating a lemma [triple_acclength] expressing the
    specification of the recursive function [acclength]. Then, register
    that specification for subsequent use by [xapp] using the command
    [Hint Resolve triple_acclength : triple]. Finally, complete the
    proof of the specification [triple_mlength']. *)

Lemma triple_acclength : forall L n c p,
  triple (acclength c p)
    (c ~~> n \* MList L p)
    (fun _ => c ~~> (n + length L) \* MList L p).
Proof using.
  intros L. induction_wf IH: list_sub L.
  xwp. xapp. xchange MList_if. xif; intros H; case_if; xpull.
  { intros. repeat xapp. rewrite H0. apply list_sub_cons. xsimpl.
  rewrite H0. rewrite length_cons. math. xchange <- MList_cons. rewrite H0. xsimpl. }
  { intros. xval. xsimpl. rewrite H0. rewrite length_nil. math.
  xchange <- MList_nil. apply C. rewrite H0. xsimpl. }
Qed.

Hint Resolve triple_acclength : triple.

Lemma triple_mlength' : forall L p,
  triple (mlength' p)
    (MList L p)
    (fun r => \[r = val_int (length L)] \* (MList L p)).
Proof using.
  intros. xwp. xapp. intros. xapp. xapp. xsimpl. math.
Qed.

(** [] *)

(* ================================================================= *)
(** ** In-Place Reversal Function for Lists *)

(** The function [mrev] takes as argument a pointer on a mutable list, and
    returns a pointer on the reverse list, that is, a list with elements in
    the reverse order. The cells from the input list are reused for
    constructing the output list---the operation is "in-place". Its
    implementation appears next.

OCaml:

    let rec mrev_aux p1 p2 =
      if p2 == null
        then p1
        else (let p3 = p2.tail in
              p2.tail <- p1;
              mrev_aux p2 p3)

    let mrev p =
      mrev_aux null p
*)

Definition mrev_aux : val :=
  <{ fix 'f 'p1 'p2 =>
       let 'b = ('p2 = null) in
       if 'b
         then 'p1
         else (
           let 'p3 = 'p2`.tail in
           'p2`.tail := 'p1;
           'f 'p2 'p3) }>.

Definition mrev : val :=
  <{ fun 'p =>
       mrev_aux null 'p }>.

(** **** Exercise: 5 stars, standard, optional (triple_mrev)

    Prove the correctness of the functions [mrev_aux] and [mrev].

    Hint: start by stating a lemma [mtriple_rev_aux] expressing the
    specification of the recursive function [mrev_aux]. Then, register
    the specification using [Hint Resolve triple_acclength : triple.].
    Finally, complete the proof of [triple_mrev].

    Hint: don't forget to generalize all the necessary variables before
    applying the well-founded induction principle. *)

Lemma mtriple_rev_aux: forall l2 l1 l p p1 p2,
  l = (rev l1) ++ l2 ->
  triple (mrev_aux p1 p2)
    (MList l1 p1 \* MList l2 p2)
    (funloc p' => MList (rev l) p').
Proof using.
  intros l2. induction_wf IH: list_sub l2.
  xwp. xapp. xchange MList_if. xif; intros H1; case_if; xpull.
  intros. xval. xsimpl. reflexivity. rewrite H0 in H. rewrite app_nil_r in H.
  assert (H2: rev l = rev (rev l1)). { eapply f_equal. eauto. }
  rewrite rev_rev in H2. rewrite H2. xsimpl. intros. xapp. xapp. xapp.
  rewrite H0. apply list_sub_cons. apply x0. rewrite H0 in H.
  rewrite app_cons_r in H. rewrite <- rev_one in H. rewrite <- rev_app in H.
  rewrite app_cons_one_r in H. apply H. xchange <- MList_cons. xsimpl. auto.
Qed.

Hint Resolve mtriple_rev_aux : triple.

Lemma triple_mrev : forall L p,
  triple (mrev p)
    (MList L p)
    (funloc q => MList (rev L) q).
Proof using.
  intros. xwp. xchange <- MList_nil. reflexivity. xapp. xsimpl. intros. reflexivity.
Qed.

(** [] *)

(* ################################################################# *)
(** * More Details *)

(* ================================================================= *)
(** ** Sized Stack *)

Module SizedStack.

(** In this section, we consider the implementation of a mutable stack with
    constant-time access to its size, i.e., to the number of items it stores.
    The stack structure consists of a 2-field record, storing a pointer on a
    mutable linked list, and an integer storing the length of that list.
    The stack implementation exposes a function to create an empty stack, a
    function for reading the size, and [push] and [pop] methods for operating
    at the top of the stack.

OCaml:

    type 'a stack = { data : 'a list; size : int }

    let create () =
      { data = nil; size = 0 }

    let sizeof s =
      s.size

    let push p x =
      s.data <- mcons x s.data;
      s.size <- s.size + 1

    let pop s =
      let p = s.data in
      let x = p.head in
      let q = p.tail in
      delete p;
      s.data <- q in
      s.size <- s.size - 1;
      x
*)

(** The representation predicate for the stack takes the form [Stack L s], where
    [s] denotes the location of the record describing the stack, and where [L]
    denotes the list of items stored in the stack. The underlying mutable list
    is described as [MList L p], where [p] is the location [p] stored in the
    first field of the record. The definition of [Stack] is as follows. *)

Definition data : field := 0%nat.
Definition size : field := 1%nat.

Definition Stack (L:list val) (s:loc) : hprop :=
  \exists p, s ~~~>`{ data := p; size := length L } \* (MList L p).

(** Observe that the predicate [Stack] does not expose the address of the
    mutable list; this adress is existentially quantified in the definition.
    The predicate [Stack] also does not expose the size of the stack, as this
    value can be deduced as [length L]. *)

Definition create : val :=
  <{ fun 'u =>
      `{ data := null; size := 0 } }>.

Lemma triple_create :
  triple (create ())
    \[]
    (funloc s => Stack nil s).
Proof using.
  xwp. xapp triple_new_hrecord_2; auto. intros s.
  unfold Stack. xsimpl*. xchange* <- (MList_nil null).
Qed.

(** The [sizeof] operation returns the contents of the [size] field of a
    stack. *)

Definition sizeof : val :=
  <{ fun 'p =>
      'p`.size }>.

Lemma triple_sizeof : forall L s,
  triple (sizeof s)
    (Stack L s)
    (fun r => \[r = length L] \* Stack L s).
Proof using.
  xwp. unfold Stack. xpull. intros p. xapp. xsimpl*.
Qed.

(** The [push] operation extends the head of the list, and increments the size
    field. *)

Definition push : val :=
  <{ fun 's 'x =>
       let 'p = 's`.data in
       let 'p2 = mcons 'x 'p in
       's`.data := 'p2;
       let 'n = 's`.size in
       let 'n2 = 'n + 1 in
       's`.size := 'n2 }>.

(** **** Exercise: 3 stars, standard, especially useful (triple_push)

    Prove the following specification for the [push] operation. *)

Lemma triple_push : forall L s x,
  triple (push s x)
    (Stack L s)
    (fun u => Stack (x::L) s).
Proof using.
  intros. xwp. unfold Stack. xapp. intros. subst. xapp.
  intros. repeat xapp. xsimpl. rewrite length_cons.
  math.
Qed.

(** [] *)

(** The [push] operation extracts the element at the head of the list, updates
    the [data] field to the tail of the list, and decrements the size field. *)

Definition pop : val :=
  <{ fun 's =>
       let 'p = 's`.data in
       let 'x = 'p`.head in
       let 'p2 = 'p`.tail in
       delete 'p;
       's`.data := 'p2;
       let 'n = 's`.size in
       let 'n2 = 'n - 1 in
       's`.size := 'n2;
       'x }>.

(** **** Exercise: 4 stars, standard, especially useful (triple_pop)

    Prove the following specification for the [pop] operation. *)

Lemma triple_pop : forall L s,
  L <> nil ->
  triple (pop s)
    (Stack L s)
    (fun x => \exists L', \[L = x::L'] \* Stack L' s).
Proof using.
  intros. xwp. unfold Stack. xapp. intros. subst. destruct L. contradiction.
  xchange MList_cons. intros. repeat xapp. xval.
  xsimpl. reflexivity. rewrite length_cons. math.
Qed.

(** [] *)

End SizedStack.

(* ================================================================= *)
(** ** Formalization of the Tree Representation Predicate *)

(** So far in this chapter, we have presented the representation of mutable
    lists in Separation Logic. We next consider the generalization to mutable
    binary trees.

    Just like mutable lists are specified with respect to Coq's purely
    functional lists, mutable binary trees are specified with respect to
    purely functional trees. For simplicity, let us consider a definition
    specialized for trees storing integer values in the nodes.

    The corresponding inductive definition is as shown below. A node from a
    logical tree takes the form [Node n T1 T2], where [n] is an integer and
    [T1] and [T2] denote the two subtrees. A leaf is represented by the
    constructor [Leaf]. *)

Inductive tree : Type :=
  | Leaf : tree
  | Node : int -> tree -> tree -> tree.

Implicit Types T : tree.

(** A mutable tree node consists of a three-cell record, featuring an field
    storing an integer named "item", and two pointers named "left" and "right",
    denoting the pointers to the left and right subtrees, respectively. *)

Definition item : field := 0%nat.
Definition left : field := 1%nat.
Definition right : field := 2%nat.

(** The heap predicate [p ~~~>`{ item := n; left := p1; right := p2 }]
    describes a record allocated at location [p], describing a node storing
    the integer [n], with its two subtrees at locations [p1] and [p2].
    An empty tree is represented using the [null] pointer.

    The representation predicate [MTree T p], of type [hprop], asserts that
    the mutable tree structure with root at location [p] describes the logical
    tree [T]. The predicate is defined recursively on the structure of [T]:

    - if [T] is a [Leaf], then [p] is the null pointer,
    - if [T] is a node [Node n T1 T2], then [p] is not null, and at location
      [p] one finds a record with field contents [n], [p1] and [p2], with
      [MTree T1 p1] and [MTree T2 p2] describing the two subtrees. *)

Fixpoint MTree (T:tree) (p:loc) : hprop :=
  match T with
  | Leaf => \[p = null]
  | Node n T1 T2 => \exists p1 p2,
         (p ~~~>`{ item := n; left := p1; right := p2 })
      \* (MTree T1 p1)
      \* (MTree T2 p2)
  end.

(* ================================================================= *)
(** ** Alternative Characterization of [MTree] *)

(** Just like for [MList], it is very useful for proofs to state three
    lemmas that paraphrase the definition of [MTree]. The first two
    lemmas correspond to folding/unfolding rules for leaves and nodes. *)

Lemma MTree_Leaf : forall p,
  (MTree Leaf p) = \[p = null].
Proof using. auto. Qed.

Lemma MTree_Node : forall p n T1 T2,
  (MTree (Node n T1 T2) p) =
  \exists p1 p2,
       (p ~~~>`{ item := n; left := p1; right := p2 })
    \* (MTree T1 p1) \* (MTree T2 p2).
Proof using. auto. Qed.

(** The third lemma reformulates [MTree T p] using a case analysis on whether
    [p] is the null pointer. This formulation matches the case analysis
    typically perform in the code of functions operating on trees. *)

Lemma MTree_if : forall (p:loc) (T:tree),
      (MTree T p)
  ==> (If p = null
        then \[T = Leaf]
        else \exists n p1 p2 T1 T2, \[T = Node n T1 T2]
             \* (p ~~~>`{ item := n; left := p1; right := p2 })
             \* (MTree T1 p1) \* (MTree T2 p2)).
Proof using.
  intros. destruct T as [|n T1 T2].
  { xchange MTree_Leaf. intros M. case_if. xsimpl*. }
  { xchange MTree_Node. intros p1 p2.
    xchange hrecord_not_null. intros N. case_if. xsimpl*. }
Qed.

Opaque MTree.

(* ================================================================= *)
(** ** Additional Tooling for [MTree] *)

(** For reasoning about recursive functions over trees, it is useful to
    exploit the well-founded order associated with "immediate subtrees".
    This order, named [tree_sub], can be exploited for a tree [T] by
    invoking the tactic [induction_wf IH: tree_sub T]. *)

Inductive tree_sub : binary (tree) :=
  | tree_sub_1 : forall n T1 T2,
      tree_sub T1 (Node n T1 T2)
  | tree_sub_2 : forall n T1 T2,
      tree_sub T2 (Node n T1 T2).

Lemma tree_sub_wf : wf tree_sub.
Proof using.
  intros T. induction T; constructor; intros t' H; inversions~ H.
Qed.

Hint Resolve tree_sub_wf : wf.

(** For allocating fresh tree nodes as a 3-field record, we introduce the
    operation [mnode n p1 p2], defined and specified as follows. *)

Definition mnode : val :=
  val_new_hrecord_3 item left right.

(** The first specification of [mnode] describes the allocation of a record. *)

Lemma triple_mnode : forall n p1 p2,
  triple (mnode n p1 p2)
    \[]
    (funloc p => p ~~~> `{ item := n ; left := p1 ; right := p2 }).
Proof using. intros. applys* triple_new_hrecord_3. Qed.

(** The second specification, derived from the first, asserts that, if provided
    the description of two subtrees [T1] and [T2] at locations [p1] and [p2],
    the operation [mnode n p1 p2] builds, at a fresh location [p], a tree
    described by [Mtree [Node n T1 T2] p]. *)

(** **** Exercise: 2 stars, standard, optional (triple_mnode')

    Prove the specification [triple_mnode'] for node allocation. *)

Lemma triple_mnode' : forall T1 T2 n p1 p2,
  triple (mnode n p1 p2)
    (MTree T1 p1 \* MTree T2 p2)
    (funloc p => MTree (Node n T1 T2) p).
Proof using.
  intros. xtriple. xapp triple_mnode. intros. xchange <- MTree_Node. xsimpl*.
Qed.

Hint Resolve triple_mnode' : triple.

(** [] *)

(* ================================================================= *)
(** ** Tree Copy *)

(** The operation [tree_copy] takes as argument a pointer [p] on a mutable tree
    and returns a fresh copy of that tree. It is constructed in similar way to
    the function [mcopy] for lists.

OCaml:

    let rec tree_copy p =
      if p = null
        then null
        else mnode p.item (tree_copy p.left) (tree_copy p.right)
*)

Definition tree_copy :=
  <{ fix 'f 'p =>
       let 'b = ('p = null) in
       if 'b then null else (
         let 'n = 'p`.item in
         let 'p1 = 'p`.left in
         let 'p2 = 'p`.right in
         let 'q1 = 'f 'p1 in
         let 'q2 = 'f 'p2 in
         mnode 'n 'q1 'q2
      ) }>.

(** **** Exercise: 3 stars, standard, optional (triple_tree_copy)

    Prove the specification of [tree_copy]. *)

Lemma triple_tree_copy : forall p T,
  triple (tree_copy p)
    (MTree T p)
    (funloc q => (MTree T p) \* (MTree T q)).
Proof using.
  intros. gen p. induction_wf IH: tree_sub T.
  intros. xwp. xchange MTree_if. xapp. xif. intros H. case_if. xval. xsimpl. reflexivity.
  intros. rewrite H0. rewrite C. xchange* <- (MTree_Leaf null). xsimpl. xchange* <- (MTree_Leaf null). xsimpl.
  intros. case_if. xapp. intros. xapp. xapp. xapp. rewrite H0. apply tree_sub_1.
  intros. xapp. rewrite H0. apply tree_sub_2. intros. subst. xapp. intros.
  xsimpl*. xchange <- MTree_Node.
Qed.

(** [] *)

(* ================================================================= *)
(** ** Computing the Sum of the Items in a Tree *)

(** The operation [mtreesum] takes as argument the location [p] of a mutable
    tree, and it returns the sum of all the integers stored in the nodes of
    that tree. Consider the implementation that traverses the tree and uses
    an auxiliary reference cell for maintaining the sum of all the items
    visited so far.

OCaml:

    let rec treeacc c p =
      if p <> null then (
        c := !c + p.item;
        treeacc c p.left;
        treeacc c p.right)

    let mtreesum p =
      let c = ref 0 in
      treeacc c p;
      !c
*)

Definition treeacc : val :=
  <{ fix 'f 'c 'p =>
       let 'b = ('p <> null) in
       if 'b then
         let 'm = ! 'c in
         let 'x = 'p`.item in
         let 'm2 = 'm + 'x in
         'c := 'm2;
         let 'p1 = 'p`.left in
         'f 'c 'p1;
         let 'p2 = 'p`.right in
         'f 'c 'p2
       end }>.

Definition mtreesum : val :=
  <{ fun 'p =>
       let 'c = ref 0 in
       treeacc 'c 'p;
       get_and_free 'c }>.

(** The specification of [mtreesum] is expressed in terms of the logical
    operation [treesum] which computes the sum of the node items stored
    in a logical tree. This operation is defined in Coq as a fixed point. *)

Fixpoint treesum (T:tree) : int :=
  match T with
  | Leaf => 0
  | Node n T1 T2 => n + treesum T1 + treesum T2
  end.

(** **** Exercise: 4 stars, standard, optional (triple_mtreesum)

    Prove the correctness of the function [mlength'].
    Hint: start by stating a lemma [triple_treeacc], then register it
    using the command [Hint Resolve triple_treeacc : triple.]. Finally,
    complete the proof of the specification [triple_mtreesum]. *)

Lemma triple_treeacc: forall T n c p,
  triple (treeacc c p)
    (MTree T p \* c ~~> n)
    (fun _ => c ~~> (n + treesum T) \* (MTree T p)).
Proof using.
  intros T. induction_wf IH: tree_sub T.
  intros. xwp. xapp. xchange MTree_if. xif. intros H. case_if. xapp.
  intros. xapp. subst. xapp. xapp. xapp. xapp. apply tree_sub_1. xapp.
  xapp. apply tree_sub_2. xsimpl. math. xchange <- MTree_Node.
  intros. case_if. xval. xsimpl. intros. rewrite H0. simpl. math.
  intros. subst. xchange* <- (MTree_Leaf null).
Qed.

Hint Resolve triple_treeacc : triple.

Lemma triple_mtreesum : forall T p,
  triple (mtreesum p)
    (MTree T p)
    (fun r => \[r = treesum T] \* (MTree T p)).
Proof using.
  intros. xwp. xapp. intros. xapp. xapp. xsimpl. math.
Qed.

(** [] *)

(* ================================================================= *)
(** ** Verification of a Counter Function with Local State *)

(** In this section, we present another kind of representation predicate:
    one that describes a function with an internal, mutable state. *)

Implicit Type f : val.

(** A counter function is a function [f] such that, each time it
    is invoked, returns the next integer, starting from 1.

    The function [create_counter] produces a fresh counter function.
    Concretely, if [create_counter()] produces the counter [f],
    then the first call to [f()] returns [1], the second call to
    [f()] returns [2], the third call to [f()] returns [3], and so on.

    The counter function can be implemented using a reference cell,
    named [p], that stores the integer last returned by the counter.
    Initially, the contents of the reference [p] is zero. Each time
    the counter is queried, the contents of [p] is increased by one
    unit, and the new value of the contents is returned to the caller.

OCaml:

    let create_counter () =
       let p = ref 0 in
       (fun () -> (incr p; !p))
*)

Definition create_counter : val :=
  <{ fun 'u =>
       let 'p = ref 0 in
       (fun_ 'u => (incr 'p; !'p)) }>.

(** The remaining of this section presents two set of specifications,
    each covering both the specification of a counter function and
    the specification of a function that creates a fresh counter function.

    The first specification is the most direct: it exposes the existence
    of a reference [p]. Doing so, however, reveals implementation details
    about the counter function.

    The second specification is more abstract: it successfully hides
    the description of the internal representation of the counter,
    and states specification only in terms of a representation predicate,
    called [IsCounter f n], that exposes only the identity of the
    counter function and its current value, but not the existence of
    the reference [p]. *)

(** Let's begin with the simple, direct specification. The proposition
    [CounterSpec f p] asserts that the counter function [f] has its
    internal state stored in a reference cell at location [p], in the
    sense that invoking [f] in a state [p ~~> m] updates the state to
    [p ~~> (m+1)] and produces the output value [m+1]. *)

Definition CounterSpec (f:val) (p:loc) : Prop :=
  forall m, triple (f ())
                    (p ~~> m)
                    (fun r => \[r = m+1] \* p ~~> (m+1)).

(** The function [create_counter] creates a fresh counter. Its precondition
    is empty. Its postcondition describes the existence of a reference
    cell [p ~~> 0], for an existentially quantified location [p], and such
    that the proposition [CounterSpec f p] holds. Observe the use of the
    tactic [xfun] for reasoning about a function definition. *)

Lemma triple_create_counter :
  triple (create_counter ())
    \[]
    (fun f => \exists p, (p ~~> 0) \* \[CounterSpec f p]).
Proof using.
  xwp. xapp. intros p. xfun. intros f Hf. xsimpl.
  { intros m. applys Hf. xapp. xapp. xsimpl. auto. }
Qed.

(** Given a counter function described by [CounterSpec f p], a call to the
    function [f] on a unit argument, in an input state of the form [p ~~> n]
    for some [n], produces the state [p ~~> (n+1)] and the output value [n+1].
    Observe how this specification applies to any function [f] satisfying
    [CounterSpec f p]. *)

Lemma triple_apply_counter : forall f p n,
  CounterSpec f p ->
  triple (f ())
    (p ~~> n)
    (fun r => \[r = n+1] \* (p ~~> (n+1))).
Proof using. introv Hf. applys Hf. Qed.

(** In the proof above, we were able to directly apply the assumption [Hf].
    In general, however, for reasoning about a call to an abstract function
    [f], it is generally needed to first invoke the tactic [xwp]. *)

Lemma triple_apply_counter_alternative_proof : forall f p n,
  CounterSpec f p ->
  triple (f ())
    (p ~~> n)
    (fun r => \[r = n+1] \* (p ~~> (n+1))).
Proof using.
  introv Hf. xtriple. lets H: Hf n. xapp. xsimpl. auto.
Qed.

(** Let's now make the specifications more abstract, by hiding away the
    description of the reference cells from the client of the specifications.

    To that end, we introduce the heap predicate [IsCounter f n], which
    relates a function [f], its current value [n], and the piece of memory
    state involved in the implementation of this function. This piece of
    memory is of the form [p ~~> n] for some location [p], such that
    [CounterSpec f p] holds. Here, [p] gets quantified existentially. *)

Definition IsCounter (f:val) (n:int) : hprop :=
  \exists p, p ~~> n \* \[CounterSpec f p].

(** Using [IsCounter], we can reformulate the specification of
    [create_counter] is a more abstract and more concise manner,
    with a postcondition simply asserting that the fresh counter
    function [f] initialized at zero is described by the heap
    predicate [IsCounter f 0]. *)

Lemma triple_create_counter_abstract :
  triple (create_counter ())
    \[]
    (fun f => IsCounter f 0).
Proof using. unfold IsCounter. applys triple_create_counter. Qed.

(** Likewise, we can reformulate the specification of a call to a counter
    function [f]. Such a call, under precondition [IsCounter f n] for some
    [n], admits the precondition [IsCounter f (n+1)], and returns [n+1]. *)

(** **** Exercise: 3 stars, standard, especially useful (triple_apply_counter_abstract)

    Prove the abstract specification for a counter function.
    Hint: use [xtriple] at some point. *)

Lemma triple_apply_counter_abstract : forall f n,
  triple (f ())
    (IsCounter f n)
    (fun r => \[r = n+1] \* (IsCounter f (n+1))).
Proof using.
  intros. unfold IsCounter. xtriple. xpull. intros. lets H1: H n. xapp.
  xsimpl*.
Qed.

(** [] *)

Opaque IsCounter.

(* ################################################################# *)
(** * Optional Material *)

(* ================================================================= *)
(** ** Specification of a Higher-Order Repeat Operator *)

(** As a warm-up before presenting the specifications of higher-order iterators
    such as [iter] and [fold] over mutable lists, we present the specification
    of an higher-order operator named [repeat]. A call to [repeat f n] executes
    [n] successives calls to [f] on the unit value, that is, calls to [f()].

OCaml:

    let rec repeat f n =
      if n > 0 then (f(); repeat f (n-1))
*)

Definition repeat : val :=
  <{ fix 'g 'f 'n =>
       let 'b = ('n > 0) in
       if 'b then
         'f ();
         let 'n2 = 'n - 1 in
         'g 'f 'n2
       end }>.

(** For simplicity, let us assume for now [n >= 0]. The specification of
    [repeat n f] is expressed in terms of an invariant, named [I],
    describing the state in-between every two calls to [f]. Initially, we
    assume the state to satisfy [f 0]. We assume that, for every index [i]
    in the range from [0] (inclusive) to [n] (exclusive), a call [f()] takes
    the state from one satisfying [f i] to one satisfying [f (i+1)]. The
    specification below asserts that, under these assumptions, after the [n]
    calls to [f()], the final state satisfies [f n].

    The specification takes the form:

    n >= 0 ->
    Hypothesis_on_f ->
    triple (repeat f n)
      (I 0)
      (fun u => I n).

    where the hypothesis of [f] captures the following specification:

    0 <= i < n ->
    triple (f ())
      (I i)
      (fun u => I (i+1))

    The complete specification of [repeat n f] appears below. *)

Lemma triple_repeat : forall (I:int->hprop) (f:val) (n:int),
  n >= 0 ->
  (forall i, 0 <= i < n ->
    triple (f ())
      (I i)
      (fun u => I (i+1))) ->
  triple (repeat f n)
    (I 0)
    (fun u => I n).

(** To establish that specification, we carry out a proof by induction over the
    judgment:

    triple (repeat f m)
      (I (n-m))
      (fun u => I n)).

    which asserts that, when there remains [m] calls to perform, the current
    state is described by [I (n-m)], that is, the current index [i] is equal
    to [n-m]. *)

Proof using.
  introv Hn Hf.
  cuts G: (forall m, 0 <= m <= n ->
    triple (repeat f m)
      (I (n-m))
      (fun u => I n)).
  { applys_eq G. { fequals. math. } { math. } }
  intros m. induction_wf IH: (downto 0) m. intros Hm.
  xwp. xapp. xif; intros C.
  { xapp. { math. } xapp. xapp. { math. } { math. }
    math_rewrite ((n - m) + 1 = n - (m - 1)). xsimpl. }
  { xval. math_rewrite (n - m = n). xsimpl. }
Qed.

(* ================================================================= *)
(** ** Specification of an Iterator on Mutable Lists *)

(** The operation [miter] takes as argument a function [f] and a pointer [p]
    on a mutable list, and invokes [f] on each of the items stored in that
    list.

OCaml:

    let rec miter f p =
      if p <> null then (f p.head; miter f p.tail)
*)

Definition miter : val :=
  <{ fix 'g 'f 'p =>
       let 'b = ('p <> null) in
       if 'b then
         let 'x = 'p`.head in
         'f 'x;
         let 'q = 'p`.tail in
         'g 'f 'q
       end }>.

(** The specification of [miter] follows the same structure as that of the
    function [repeat] from the previous section, with two main differences.
    The first difference is that the invariant is expressed not in terms of
    an index [i] ranging from [0] to [n], but in terms of a prefix of the
    list [L] being traversed, ranging from [nil] to the full list [L].
    The second difference is that the operation [miter f p] requires in its
    precondition, in addition to [I nil], the description of the mutable list
    [MList L p]. This predicate is returned in the postcondition, unchanged,
    reflecting on the fact that the iteration does not alter the list. *)

(** **** Exercise: 5 stars, standard, especially useful (triple_miter)

    Prove the correctness of [triple_miter]. *)

Lemma triple_miter : forall (I:list val->hprop) L (f:val) p,
  (forall x L1 L2, L = L1++x::L2 ->
    triple (f x)
      (I L1)
      (fun u => I (L1++(x::nil)))) ->
  triple (miter f p)
    (MList L p \* I nil)
    (fun u => MList L p \* I L).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** For exploiting the specification [triple_miter] to reason about a call to
    [miter], it is necessary to provide an invariant [I] of type
    [list val -> hprop], that is, of the form [fun (K:list val) => ...]. This
    invariant, which cannot be inferred automatically, should describe the state
    at the point where the iteration has traversed a prefix [K] of the list [L].

    Concretely, for reasoning about a call to [miter], one should exploit the
    tactic [xapp (triple_iter (fun K => ...))]. *)

(* ================================================================= *)
(** ** Computing the Length of a Mutable List using an Iterator *)

(** We can compute the length of a mutable list by iterating over that list a
    function that increments a reference cell once for every item.

OCaml:

    let mlength_using_miter p =
      let c = ref 0 in
      miter (fun x -> incr c) p;
      !c
*)

(** **** Exercise: 4 stars, standard, especially useful (triple_mlength_using_miter)

    Prove the correctness of [mlength_using_iter].
    Hint: use [xfun. intros f Hf] for reasoning about the function definition,
    then use [xapp] for reasoning about a call to [f] by inlining its code. *)

Definition mlength_using_miter : val :=
  <{ fun 'p =>
       let 'c = ref 0 in
       let 'f = (fun_ 'x => incr 'c) in
       miter 'f 'p;
       get_and_free 'c }>.

Lemma triple_mlength_using_miter : forall p L,
  triple (mlength_using_miter p)
    (MList L p)
    (fun r => \[r = length L] \* MList L p).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** A Continuation-Passing-Style, In-Place Concatenation Function *)

(** The following program was proposed in the original article on
    Separation Logic by John Reynolds as a challenge for verification.

    This function, called [cps_append], is similar to the function [append]
    presented previously: it also performs in-place concatenation of two lists.
    It differs in that it is implemented using a recursive, continuation-passing
    style function to perform the work.

    The presentation of [cps_append p1 p2] is also slightly different: this
    operation returns a pointer [p3] that describes the head of the result
    of the concatenation, and it works even if [p1] corresponds to an empty
    list.

    The code of [cps_append] involves an auxiliary function [cps_append_aux].
    This code appears at first like a puzzle: it takes a good drawing and
    several minutes to figure out how it works. Observe in particular how the
    recursive call is invoked as part of the continuation. *)

(**

OCaml:

    let rec cps_append_aux p1 p2 k =
      if p1 == null
        then k p2
        else cps_append_aux p1.tail p2 (fun r => (p1.tail <- r); k p1)

    let cps_append p1 p2 =
      cps_append_aux p1 p2 (fun r => r)
*)

Definition cps_append_aux : val :=
  <{ fix 'f 'p1 'p2 'k =>
       let 'b = ('p1 = null) in
       if 'b
         then 'k 'p2
         else
           let 'q1 = 'p1`.tail in
           let 'k2 = (fun_ 'r => ('p1`.tail := 'r; 'k 'p1)) in
           'f 'q1 'p2 'k2 }>.

Definition cps_append : val :=
  <{ fun 'p1 'p2 =>
      let 'f = (fun_ 'r => 'r) in
      cps_append_aux 'p1 'p2 'f }>.

(** **** Exercise: 5 stars, standard, optional (triple_cps_append)

    Specify and verify [cps_append_aux], then verify [cps_append]. *)

(* FILL IN HERE *)

(** The main function [cps_append] simply invokes [cps_append_aux]
    with a trivial continuation. *)

Lemma triple_cps_append : forall (L1 L2:list val) (p1 p2:loc),
  triple (cps_append p1 p2)
    (MList L1 p1 \* MList L2 p2)
    (funloc p3 => MList (L1++L2) p3).
Proof using. (* FILL IN HERE *) Admitted.

(** [] *)

(** This concludes the formal verification of Reynolds' verification
    challenge. *)

(* ================================================================= *)
(** ** Historical Notes *)

(** The representation predicate for lists appears in the seminal papers on
    Separation Logic: the notes by Reynolds from the summer 1999, updated the
    next summer [Reynolds 2000] (in Bib.v), and the publication by
    [O’Hearn, Reynolds, and Yang 2001] (in Bib.v).

    Most presentations of Separation Logic target partial correctness, whereas
    this chapters targets total correctness. The specifications of recursive
    functions are established using the built-in induction mechanism offered by
    Coq.

    The specification of higher-order iterators requires higher-order
    Separation Logic. Being embedded in the higher-order logic of Coq, the
    Separation Logic that we work with is inherently higher-order. Further
    information on the history of higher-order Separation Logic for
    higher-order programs may be found in section 10.2 of
    http://www.chargueraud.org/research/2020/seq_seplogic/seq_seplogic.pdf . *)

(* 2021-01-25 13:22 *)


Require Import Coq.Vectors.Vector.
Require Import Coq.PArith.PArith.
Require Import Lia.
Require Import Equations.Prop.Equations.
Set Equations With UIP.
Generalizable All Variables.

Definition obj_idx : Type := positive.
Definition arr_idx (n : nat) : Type := Fin.t n.

Import VectorNotations.

Definition obj_pair := (obj_idx * obj_idx)%type.

Inductive Term {a} (tys : Vector.t (obj_idx * obj_idx) a)
          : obj_idx -> obj_idx -> Type :=
  | Ident : forall dom, Term tys dom dom
  | Morph (f : arr_idx a) : Term tys (fst (tys[@f])) (snd (tys[@f]))
  | Comp (dom mid cod : obj_idx)
         (f : Term tys mid cod) (g : Term tys dom mid) :
      Term tys dom cod.

Arguments Ident {a tys dom}.
Arguments Morph {a tys} f.
Arguments Comp {a tys dom mid cod} f g.
Import Sigma_Notations.
Require Import Wellfounded Relations.

Derive NoConfusion for positive.
Derive EqDec for positive.
Derive Signature NoConfusion Subterm for Term.

Fixpoint term_size
         {a : nat} {tys : Vector.t obj_pair a}
         {dom cod} (t : @Term a tys dom cod) : nat :=
  match t with
  | Ident    => 1%nat
  | Morph _  => 1%nat
  | Comp f g => 1%nat + term_size f + term_size g
  end.
Set Program Mode.
Show Obligation Tactic.
Equations? comp_assoc_simpl_rec {a : nat} {tys dom cod}
          (t : @Term a tys dom cod) : {t' : @Term a tys dom cod | term_size t' <= term_size t}
  by wf (term_size t) lt :=
  comp_assoc_simpl_rec (Comp f g) with comp_assoc_simpl_rec f => {
    | exist _ (Comp i j) Hle => Comp i (comp_assoc_simpl_rec (Comp j g));
    | x => Comp x (comp_assoc_simpl_rec g)
  };
  comp_assoc_simpl_rec x := x.
Proof.
  1-2,4:lia.
  all:(simpl; try Program.Tactics.destruct_call comp_assoc_simpl_rec; simpl in *; try lia).
Time Defined.

Definition comp_assoc_simpl {a}
           {tys : Vector.t obj_pair a} {dom cod} (t : Term tys dom cod) : Term tys dom cod :=
  comp_assoc_simpl_rec t.

Lemma comp_assoc_simpl_ident {a} {tys : Vector.t obj_pair a} {dom cod} (g : Term tys dom cod) :
  comp_assoc_simpl (Comp Ident g) = Comp Ident (comp_assoc_simpl g).
Proof.
  unfold comp_assoc_simpl.
  Opaque comp_assoc_simpl_rec.
  autorewrite with comp_assoc_simpl_rec. simpl. reflexivity.
Qed.

Unset Program Mode.
Open Scope program_scope.

Lemma comp_assoc_simpl_comp {a} {tys : Vector.t obj_pair a} {dom mid cod}
      (f : Term tys mid cod) (g : Term tys dom mid) :
  comp_assoc_simpl (Comp f g) =
  match comp_assoc_simpl f in Term _ mid cod return Term tys dom mid -> Term tys dom cod with
  | Comp f f' => fun g => Comp f (comp_assoc_simpl (Comp f' g))
  | x => fun g => Comp x (comp_assoc_simpl g) end g.
Proof.
  unfold comp_assoc_simpl.
  simp comp_assoc_simpl_rec.
  revert dom g. Tactics.reverse.
  let felim := constr:(fun_elim (f := @comp_assoc_simpl_rec)) in
  unshelve refine_ho (felim _ _ _ _ _ _); simpl; intros; try reflexivity.
Qed.


Require Import List.

(* tag definition *)
Inductive tag_ter_normal :=
| ADD : tag_ter_normal
| AND : tag_ter_normal.

Inductive tag_ter_immediate :=
| ADD_I : tag_ter_immediate
| AND_I : tag_ter_immediate.

Inductive tag_duo_immediate :=
| JUMP_I : tag_duo_immediate
| JUMP_IC : tag_duo_immediate.

Inductive tag_duo_normal :=
| JUMP : tag_duo_normal
| JUMPC : tag_duo_normal.

Inductive tag :=
| tag_t_n : tag_ter_normal -> tag
| tag_t_i : tag_ter_immediate -> tag
| tag_d_i : tag_duo_immediate -> tag
| tag_d_n : tag_duo_normal -> tag.

Scheme Equality for tag.

Lemma tag_beq_reflexivity : forall (t :tag), tag_beq t t = true.
Proof.
  destruct t.
  -destruct t.
   +reflexivity.
   +reflexivity.
  -destruct t.
   +reflexivity.
   +reflexivity.
  -destruct t.
   +reflexivity.
   +reflexivity.
  -destruct t.
   +reflexivity.
   +reflexivity.
Qed.

Lemma tag_beq_different : forall (t1 t2 : tag), tag_beq t1 t2 = true -> t1 = t2.
Proof.
  destruct t1.
  -{
      destruct t2.
      -{
          destruct t.
          -destruct t0.
           +reflexivity.
           +discriminate.
          -destruct t0.
           +discriminate.
           +reflexivity.
        }
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
    }
  -{
      destruct t2.
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
      -{
          destruct t.
          -destruct t0.
           +reflexivity.
           +discriminate.
          -destruct t0.
           +discriminate.
           +reflexivity.
        }
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
    }
  -{
      destruct t2.
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
      -{
          destruct t.
          -destruct t0.
           +reflexivity.
           +discriminate.
          -destruct t0.
           +discriminate.
           +reflexivity.
        }
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
    }
  -{
      destruct t2.
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
      -{
          destruct t.
          -destruct t0.
           +discriminate.
           +discriminate.
          -destruct t0.
           +discriminate.
           +discriminate.
        }
      -{
          destruct t.
          -destruct t0.
           +reflexivity.
           +discriminate.
          -destruct t0.
           +discriminate.
           +reflexivity.
        }
    }
Qed.

(* maybe it's not usefull to distinguish the special register than the
other because the specification says that you have different numbers for them *)

Inductive  imediate :=
  imm : nat -> imediate.
Inductive register :=
  reg : nat -> register.

Inductive operande :=
  | imm_o : imediate -> operande
  | reg_o : register -> operande.

(* instruction definition *)
Record instruction_tern_n :=
  mk_instr_t_n { instr_opcode_t_n : tag_ter_normal;
             instr_operande1_t_n : register ;
             instr_operande2_t_n : register ;
             instr_operande3_t_n : register }.

Record instruction_tern_i :=
  mk_instr_t_i { instr_opcode_t_i : tag_ter_immediate;
             instr_operande1_t_i : register ;
             instr_operande2_t_i : register ;
             instr_operande3_t_i : imediate }.

Record instruction_duo_n :=
  mk_instr_d_n { instr_opcode_d_n : tag_duo_normal;
             instr_operande1_d_n : register ;
             instr_operande2_d_n : register }.

Record instruction_duo_i :=
  mk_instr_d_i { instr_opcode_d_i : tag_duo_immediate;
             instr_operande1_d_i : register ;
             instr_operande2_d_i : imediate }.

Inductive instruction :=
| instr_t_n : instruction_tern_n -> instruction
| instr_t_i : instruction_tern_i -> instruction
| instr_d_n : instruction_duo_n -> instruction
| instr_d_i : instruction_duo_i -> instruction.
(* binary instruction definition *)
Definition binary_instruction := list bool.

(* some example to test the record structure *)
(* Example my_instr := mk_instr_t_i (tag_t_i ADD_I) (reg 10) (reg 11) (imm 12). *)

(* Example first_field_instr := my_instr.(instr_opcode_t_i).  *)