(*
 * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import Coq.Relations.Relations.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Classes.Morphisms.
Require Omega.

Local Open Scope nat_scope.

Program Definition EqSetoid (A:Type) : Setoid A := @Build_Setoid A (@eq A) _.
Next Obligation.
  constructor; hnf; intuition.
  transitivity y; auto.
Qed.

#[global] Program Instance ProdSetoid `(Setoid A) `(Setoid B) : Setoid (A * B) :=
  { equiv := fun z w => equiv (fst z) (fst w) /\ equiv (snd z) (snd w)
  }.
Next Obligation.
  constructor; hnf; intuition; simpl in *.
  transitivity a0; auto.
  transitivity b0; auto.
Qed.

Inductive Mor `(As:Setoid A) `(Bs:Setoid B) :=
  { mor_fun :> A -> B
  ; mor_prf :> @Morphism (A -> B) (equiv ==> equiv)%signature mor_fun
  }.
Implicit Arguments Build_Mor [A B].

Program Definition fstM `{As:Setoid A} `{Bs:Setoid B} : Mor (ProdSetoid As Bs) As
 := Build_Mor _ _ (@fst A B) _.
Next Obligation.
  hnf; simpl; intuition.
Qed.

Program Definition sndM `{As:Setoid A} `{Bs:Setoid B} : Mor (ProdSetoid As Bs) Bs
 := Build_Mor _ _ (@snd A B) _.
Next Obligation.
  hnf; simpl; intuition.
Qed.

Definition ext_equiv `(As:Setoid A) `(Bs:Setoid B) : relation (Mor As Bs) :=
  fun f g => forall a a':A, a == a' -> f a == g a'.

Lemma ext_is_equiv `(As:Setoid A) `(Bs:Setoid B) : Equivalence (ext_equiv As Bs).
Proof.
  intros; constructor; do 2 (hnf; intros).
  apply mor_prf; auto.
  transitivity (y a').
  apply mor_prf; auto.
  symmetry; apply H; auto.
  reflexivity.
  transitivity (y a').
  apply H; auto.
  apply H0; reflexivity.
Qed.

#[global] Instance MorSetoid  `(As:Setoid A) `(Bs:Setoid B) : Setoid (Mor As Bs) :=
  { equiv := ext_equiv As Bs
  ; setoid_equiv := ext_is_equiv As Bs
  }.

Program Definition idM `(As:Setoid A) : Mor As As := Build_Mor As As (@id A) _.
Next Obligation.
  hnf; auto.
Qed.

Program Definition composeM `{As:Setoid A} `{Bs:Setoid B} `{Cs:Setoid C}
  (f:Mor Bs Cs) `(g:Mor As Bs) := Build_Mor As Cs (fun x => f (g x)) _.
Next Obligation.
  hnf; intros.
  apply f; apply g; auto.
Qed.
Infix "oo" := composeM (at level 54, right associativity).

Module Type TY_FUNCTOR.
  Parameter F : Type -> Type.
  #[global] Instance Fs : forall {A}, Setoid A -> Setoid (F A).

  Parameter fmap : forall `{As:Setoid A} `{Bs:Setoid B}, Mor As Bs -> Mor (Fs As) (Fs Bs).

  Axiom fmap_mor : forall `{As:Setoid A} `{Bs:Setoid B},
    Morphism (equiv ==> equiv) fmap.

  Axiom fmap_id : forall `{As:Setoid A}, fmap (idM As) == idM (Fs As).
  Axiom fmap_comp : forall `{As:Setoid A} `{Bs:Setoid B} `{Cs:Setoid C}
    (f:Mor Bs Cs) (g:Mor As Bs),
    fmap f oo fmap g == fmap (f oo g).

  Parameter T : Type.
  #[global] Instance Ts : Setoid T.
  Parameter T_bot : T.

  Parameter other : Type.
  Parameter otherS : Setoid other.
End TY_FUNCTOR.

Module Type KNOT.
  Declare Module TF:TY_FUNCTOR.
  Import TF.

  Parameter knot : Type.
  #[global] Instance knotS : Setoid knot.
  Definition koS : Setoid (knot * other) := @ProdSetoid knot knotS other otherS.
  Definition predicate := Mor koS Ts.
  Definition predS : Setoid predicate := MorSetoid koS Ts.
  Definition natFS : Setoid (nat * F predicate) := @ProdSetoid nat (EqSetoid nat) (F predicate) (Fs predS).
  #[global] Existing Instance koS.
  #[global] Existing Instance predS.
  #[global] Existing Instance natFS.

  Parameter squash : Mor natFS knotS.
  Parameter unsquash : Mor knotS natFS.

  Definition level : Mor knotS (EqSetoid nat) := fstM oo unsquash.
  Parameter approx : forall n:nat, Mor predS predS.

  Axiom approx_spec : forall n p w, approx n p w ==
    if (le_gt_dec n (level (fst w))) then T_bot else p w.

  Axiom squash_unsquash : forall x, squash (unsquash x) == x.
  Axiom unsquash_squash : forall n x', unsquash (squash (n,x')) == (n,fmap (approx n) x').

  Definition knot_age1 (k:knot) : option knot :=
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

  Definition knot_age := fun x y => knot_age1 x = Some y.
End KNOT.

Module Knot (TF':TY_FUNCTOR) : KNOT with Module TF:=TF'.
  Module TF := TF'.
  Import TF.

  (* Put the discrete topped order on rhs *)
  Inductive le_T : T -> T -> Prop :=
   | le_T_refl : forall t1 t2,
     t1 == t2 -> le_T t1 t2
   | le_T_bot: forall t,
     le_T T_bot t.

  Lemma le_T_asym: forall t1 t2,
    le_T t1 t2 -> le_T t2 t1 -> t1 == t2.
  Proof.
  intros.
  inversion H; subst; auto.
  inversion H0; subst; auto.
  symmetry; auto.
  reflexivity.
  Qed.

  Fixpoint sinv (n: nat) : { T:Type & Setoid T } :=
    match n with
      | O => existT (fun T => Setoid T) unit (EqSetoid unit)
      | S n => existT (fun T => Setoid T)
                  (prodT (projT1 (sinv n))
                         (Mor (ProdSetoid  (Fs (projT2 (sinv n))) otherS) (Ts)))
                  (ProdSetoid (projT2 (sinv n)) (MorSetoid _ _))
    end.

  Fixpoint floor (m:nat) (n:nat) (p:projT1 (sinv (m+n))) : projT1 (sinv n) :=
    match m as m' return forall (p : projT1 (sinv (m'+n))), projT1 (sinv n) with
    | O => fun p => p
    | S m' => fun p => floor m' n (fst p)
    end p.

  Lemma floor_mor : forall m n, Morphism ( (@equiv _ (projT2 (sinv (m+n)))) ==> (@equiv _ (projT2 (sinv n)))) (floor m n).
  Proof.
    induction m; simpl; hnf; intros; hnf; simpl; intros; auto.
    destruct x; destruct y; simpl in *.
    destruct H.
    apply IHm; auto.
  Qed.

  Definition knot := { n:nat & F (projT1 (sinv n)) }.

  Inductive knotEq : knot -> knot -> Prop :=
    keq : forall n (f1 f2:F (projT1 (sinv n))),
      @equiv _ (Fs (projT2 (sinv n))) f1 f2 ->
      knotEq (existT (fun x => F (projT1 (sinv x))) n f1)
             (existT (fun x => F (projT1 (sinv x))) n f2).
  #[global] Program Instance knotS : Setoid knot := { equiv := knotEq }.
  Next Obligation.
    constructor; hnf; intros.
    destruct x; constructor.
    reflexivity.
    destruct x; destruct y; simpl in *.
    inversion H; subst; simpl in *.
    constructor.
    replace f with f3.
    symmetry; auto.
    revert H2.
    apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))).
    destruct x; destruct y; destruct z.
    inversion H; clear H; subst.
    inversion H0; clear H0; subst.
    simpl.
    constructor.
    transitivity f5.
    replace f with f4; auto.
    revert H3.
    apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))).
    replace f5 with f0.
    replace f0 with f6; auto.
    revert H4.
    apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))).
    symmetry.
    revert H5.
    apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))).
  Qed.

  Definition koS : Setoid (knot * other) := @ProdSetoid knot knotS other otherS.
  Definition predicate := Mor koS Ts.
  Definition predS : Setoid predicate := MorSetoid koS Ts.
  Definition natFS : Setoid (nat * F predicate) := @ProdSetoid nat (EqSetoid nat) (F predicate) (Fs predS).
  #[global] Existing Instance koS.
  #[global] Existing Instance predS.
  #[global] Existing Instance natFS.

  Program Definition wrap (n:nat) : Mor (ProdSetoid (Fs (projT2 (sinv n))) otherS) (ProdSetoid knotS otherS) :=
    @Build_Mor _ _ _ _ (fun v => (existT (fun x => F (projT1 (sinv x))) n (fst v), snd v)) _.
  Next Obligation.
    hnf; simpl; intuition.
    destruct y.
    constructor.
    simpl in *; auto.
  Qed.

  Fixpoint stratify0 (n:nat) (Q:predicate) {struct n} : projT1 (sinv n) :=
    match n as n' return projT1 (sinv n') with
    | O => tt
    | S n' => ( stratify0 n' Q, Q oo (wrap n'))
    end.

  Lemma stratify_mor : forall n, Morphism (equiv ==> (@equiv _ (projT2 (sinv n)))) (stratify0 n).
  Proof.
    induction n; simpl; intros; hnf; simpl; intros; auto.
    split.
    apply IHn.
    apply H.
    hnf; intros.
    simpl.
    apply H.
    destruct H0.
    simpl; split; auto.
    constructor; auto.
  Qed.

  Definition stratify (n:nat) : Mor predS (projT2 (sinv n)) :=
    Build_Mor predS (projT2 (sinv n)) (stratify0 n) (stratify_mor n).

  Lemma decompose_nat : forall (x y:nat), { m:nat & y = (m + S x) } + { ge x y }.
  Proof.
    intros x y; revert x; induction y; simpl; intros.
    right; auto with arith.
    destruct (IHy x) as [[m H]|H].
    left; exists (S m); lia.
    destruct (eq_nat_dec x y).
    left; exists O; lia.
    right; lia.
  Qed.

  Definition proof_irr_nat := eq_proofs_unicity dec_eq_nat.
  Implicit Arguments proof_irr_nat.

  Program Definition unstratify (n:nat) : Mor (projT2 (sinv n)) predS :=
    Build_Mor _ _ (fun p =>
      Build_Mor _ _ (fun w =>
      match w with (existT nw w',e) =>
        match decompose_nat nw n with
          | inleft (existT m Hm) => snd (floor m (S nw) (eq_rect n (fun x => projT1 (sinv x)) p (m + S nw) Hm)) (w', e)
          | inright H => T_bot
        end
      end) _) _.
  Next Obligation.
    hnf; simpl; intros.
    destruct x; destruct y; simpl.
    destruct k; destruct k0; simpl in *.
    destruct H.
    inversion H; clear H; subst.
    assert (f3 = f) by (apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))); auto).
    subst f3.
    assert (f4 = f0) by (apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))); auto).
    subst f4.
    clear H3 H5.
    simpl.
    destruct (decompose_nat x0 n); simpl.
    destruct s; simpl.
    generalize e.
    subst n; intro e.
    replace e with (refl_equal (x + S x0)) by apply proof_irr_nat; simpl.
    generalize (floor_mor x (S x0) p p (setoid_refl _ p)).
    intro H.
    simpl in H.
    destruct H.
    apply H1.
    simpl; split; auto.
    apply setoid_refl.
  Qed.
  Next Obligation.
    repeat (hnf; simpl in *; intros).
    destruct a; destruct a'; simpl in *.
    destruct k; destruct k0; destruct H0; simpl in *.
    inversion H0; clear H0; subst.
    assert (f3 = f) by (apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))); auto).
    subst f3.
    assert (f4 = f0) by (apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))); auto).
    subst f4.
    simpl.
    destruct (decompose_nat x1 n); simpl.
    destruct s; simpl.
    generalize e; subst n.
    intro e.
    replace e with (refl_equal (x0 + S x1)) by (apply proof_irr_nat; auto); simpl.
    generalize (floor_mor x0 (S x1) x y H); simpl.
    intros [? ?].
    apply H2.
    split; auto.
    reflexivity.
  Qed.

  Lemma floor_shuffle:
    forall (m1 n : nat)
      (p1 : projT1 (sinv (m1 + S n))) (H1 : (m1 + S n) = (S m1 + n)),
      floor (S m1) n (eq_rect (m1 + S n) (fun x => (projT1 (sinv x))) p1 (S m1 + n) H1) = fst (floor m1 (S n) p1).
  Proof.
    intros.
    remember (fst (floor m1 (S n) p1)) as p.
    revert n p1 H1 p Heqp.
    induction m1; simpl; intros.
    replace H1 with (refl_equal (S n)) by (apply proof_irr_nat); simpl; auto.
    assert (m1 + S n = S m1 + n) by lia.
    destruct p1 as [p1 f'].
    generalize (IHm1 n p1 H p Heqp).
    simpl.
    clear.
    revert H1; generalize H.
    revert p1 f'.
    rewrite H.
    simpl; intros.
    replace H1 with (refl_equal (S (S (m1 + n)))) by (apply proof_irr_nat).
    simpl.
    replace H0 with (refl_equal (S (m1+n))) in H2 by (apply proof_irr_nat).
    simpl in H2.
    trivial.
  Qed.

  Lemma stratify_unstratify_more : forall n m1 m2 p1 p2,
    @equiv _ (projT2 (sinv n)) (floor m1 n p1) (floor m2 n p2) ->

    @equiv _ (projT2 (sinv n))
    (stratify n (unstratify (m1+n) p1))
    (stratify n (unstratify (m2+n) p2)).
  Proof.
    induction n; simpl; intros; auto.
    split.

    assert ((m1 + S n) =  (S m1 + n)) by lia.
    assert ((m2 + S n) =  (S m2 + n)) by lia.
    assert (@equiv _ (projT2 (sinv n))
      (floor (S m1) n (eq_rect (m1 + S n) (fun x => projT1 (sinv x)) p1 _ H0))
      (floor (S m2) n (eq_rect (m2 + S n) (fun x => (projT1 (sinv x))) p2 _ H1))).
    do 2 rewrite floor_shuffle.
    destruct H; auto.
    generalize (IHn (S m1) (S m2) _ _ H2).
    clear.
    generalize H0 H1.
    revert p1 p2.
    rewrite H0; clear H0.
    rewrite H1; clear H1.
    intros p1 p2 H1 H2.
    replace H1 with (refl_equal (S m1 + n)) by (apply proof_irr_nat).
    replace H2 with (refl_equal (S m2 + n)) by (apply proof_irr_nat).
    simpl; auto.

    hnf; intros.
    destruct a; destruct a'.
    unfold unstratify.
    simpl.
    destruct (decompose_nat n (m2 + S n)) as [[r Hr]|Hr].
    2: exfalso; lia.
    destruct (decompose_nat n (m1 + S n)) as [[s Hs]|Hs].
    2: exfalso; lia.
    assert (m2 = r) by lia; subst r.
    assert (m1 = s) by lia; subst s.
    replace Hr with (refl_equal (m2 + S n)) by (apply proof_irr_nat).
    replace Hs with (refl_equal (m1 + S n)) by (apply proof_irr_nat).
    simpl.
    destruct H; auto.
  Qed.

  Lemma stratify_unstratify : forall n,
         stratify n oo unstratify n == idM (projT2 (sinv n)).
  Proof.
    simpl; induction n.
    hnf; simpl; intros.
    destruct a'; auto.
    simpl; intros a a' H.
    split.
    destruct a; destruct a'; destruct H; simpl in *.
    change (@equiv _ (projT2 (sinv n)) (stratify n (unstratify (S n) (p,m))) p0).
    transitivity (stratify n (unstratify n p)).
    symmetry.
    apply (stratify_unstratify_more _ 0 1 p (p,m)).
    simpl; reflexivity.
    apply (IHn p p0 H).

    hnf; intros.
    destruct a0; destruct a'0; destruct H; simpl.
    destruct (decompose_nat n (S n)).
    2: exfalso; lia.
    destruct s.
    assert (x = 0) by lia; subst x; simpl in *.
    replace e with (refl_equal (S n)) by (apply proof_irr_nat; auto); simpl.
    auto.
  Qed.

  Lemma unstratify_stratify1 : forall n (p:predicate) w,
    le_T ((unstratify n oo stratify n) p w) (p w).
  Proof.
    induction n; simpl; intros; unfold unstratify.

    (* 0 case *)
    destruct w as [nw rm]; simpl.
    destruct nw as [nw e].
    destruct (decompose_nat nw O) as [[r Hr]|?].
    exfalso; lia.
    apply le_T_bot.

    (* S n case *)
    destruct w; simpl; intros.
    destruct k as [nw e].
    destruct (decompose_nat nw (S n)) as [[r Hr]|?]; try (apply lt_rhs_bot).
    destruct r; simpl.

    assert (n = nw) by lia.
    subst nw.
    simpl in Hr.
    replace Hr with (refl_equal (S n)) by apply proof_irr_nat; simpl.
    apply le_T_refl.
    reflexivity.

    simpl in Hr.
    assert (n = r + S nw) by lia.
    revert Hr; subst n.
    intro Hr.
    replace Hr with (refl_equal (S (r+S nw))) by apply proof_irr_nat; simpl.
    clear Hr.

    generalize (IHn p (existT (fun x => F (projT1 (sinv x))) nw e, o)).
    unfold unstratify; simpl.
    destruct (decompose_nat nw (r + S nw)) as [[x Hx]|?].
    assert (x = r) by lia; subst x.
    replace Hx with (refl_equal (r + S nw)) by apply proof_irr_nat.
    simpl; auto.
    exfalso; lia.
    apply le_T_bot.
  Qed.

  Lemma unstratify_stratify2 : forall n (p:predicate) (w:knot * other),
     projT1 (fst w) < n ->
        le_T (p w) ((unstratify n oo stratify n) p w).
  Proof.
    induction n; simpl; intros.

    (* 0 case *)
    inversion H.

    (* S n case *)
    destruct w; simpl in *.
    destruct k; simpl.

    destruct (decompose_nat x (S n)) as [[r Hr]|?].
    destruct r; simpl.

    assert (n = x) by lia.
    subst x.
    simpl in Hr; replace Hr with (refl_equal (S n)) by apply proof_irr_nat; simpl.
    apply le_T_refl.
    reflexivity.

    simpl in Hr.
    assert (n = r + S x) by lia.
    revert Hr; subst n.
    intro Hr.
    replace Hr with (refl_equal (S (r+S x))) by apply proof_irr_nat; simpl.
    clear Hr.
    simpl in H.
    assert (x < r + S x) by lia.
    generalize (IHn p (existT (fun x => F (projT1 (sinv x))) x f,o) H0).
    simpl.
    destruct (decompose_nat x (r + S x)) as [[y Hy]|?].
    assert (y = r) by lia; subst y.
    replace Hy with (refl_equal (r + S x)) by apply proof_irr_nat.
    simpl; auto.
    exfalso; lia.
    simpl in *.
    exfalso; lia.
  Qed.

  Lemma unstratify_stratify3 : forall n (p:predicate) w,
    projT1 (fst w) >= n -> le_T ((unstratify n oo stratify n) p w) T_bot.
  Proof.
    intros n p w H; simpl.
    destruct w; simpl in *.
    destruct s; simpl in *.
    destruct (decompose_nat x n) as [[r Hr]|?].
    exfalso; lia.
    apply le_T_bot.
  Qed.

  Program Definition squash : Mor natFS knotS :=
    Build_Mor _ _
     (fun x =>
       match x with (n,y) => existT (fun x => F (projT1 (sinv x))) n (fmap (stratify n) y) end) _.
  Next Obligation.
    hnf; simpl; intros.
    destruct x; destruct y; destruct H; simpl in *.
    subst n0.
    constructor.
    apply mor_prf; auto.
  Qed.

  Program Definition unsquash : Mor knotS natFS :=
    Build_Mor _ _
      (fun x =>
        match x with existT n y => (n, fmap (unstratify n) y) end) _.
  Next Obligation.
    hnf; simpl; intros.
    destruct x; destruct y; inversion H; clear H; subst; simpl.
    split; auto.
    apply mor_prf.
    transitivity f3; auto.
    replace f with f3.
    reflexivity.
    apply (inj_pair2_eq_dec nat eq_nat_dec) with (P:=fun x => F (projT1 (sinv x))); auto.
  Qed.

  Definition level : Mor knotS (EqSetoid nat) := fstM oo unsquash.
  Definition approx (n:nat) := unstratify n oo stratify n.

  Lemma approx_spec : forall n p w, approx n p w ==
    if (le_gt_dec n (level (fst w))) then T_bot else p w.
  Proof.
    intros.
    replace (level (fst w)) with (projT1 (fst w)).
    destruct (le_gt_dec n (projT1 (fst w))).
    apply le_T_asym.
    unfold approx.
    apply unstratify_stratify3; auto.
    apply le_T_bot.
    apply le_T_asym.
    apply unstratify_stratify1.
    apply unstratify_stratify2; auto.
    unfold level; destruct w; simpl.
    destruct k; simpl; auto.
  Qed.

  Lemma squash_unsquash : forall x, squash (unsquash x) == x.
  Proof.
    intros; destruct x; simpl.
    constructor.
    change (@equiv _ (Fs (projT2 (sinv x))) ((fmap (stratify x) oo fmap (unstratify x)) f)f).
    transitivity (fmap (stratify x oo unstratify x) f).
    apply (fmap_comp (stratify x) (unstratify x) f f (setoid_refl _ f)).
    transitivity (fmap (idM (projT2 (sinv x))) f).
    apply fmap_mor.
    apply stratify_unstratify.
    reflexivity.
    transitivity (idM (Fs (projT2 (sinv x))) f).
    apply fmap_id; reflexivity.
    simpl; reflexivity.
  Qed.

  Lemma unsquash_squash : forall n x', unsquash (squash (n,x')) == (n,fmap (approx n) x').
  Proof.
    intros; simpl; split; auto.
    unfold approx.
    change ((fmap (unstratify n) oo fmap (stratify n)) x' == fmap (unstratify n oo stratify n) x').
    apply fmap_comp.
    reflexivity.
  Qed.

  Definition knot_age1 (k:knot) : option knot :=
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

  Definition knot_age := fun x y => knot_age1 x = Some y.

End Knot.


From Coq Require Import Arith.Arith.
From Coq Require Import Lia.

From Elo Require Import Util.
From Elo Require Import Array.
From Elo Require Import Core.
From Elo Require Import HasAddress.
From Elo Require Import ValidAddresses.

(* A term accesses an address if it refers to the address directly or
indirectly. Ignores <spawn> blocks. *)
Inductive access (m : mem) : tm -> addr -> Prop :=
  | acc_mem : forall ad ad' T,
    ad <> ad' ->
    access m m[ad'].tm ad ->
    access m <{ &ad' :: T }> ad

  | acc_ref : forall ad T,
    access m <{ &ad :: T }> ad

  | acc_new : forall T t ad,
    access m t ad ->
    access m <{ new T t }> ad

  | acc_load : forall t ad,
    access m t ad ->
    access m <{ *t }> ad

  | acc_asg1 : forall t1 t2 ad,
    access m t1 ad ->
    access m <{ t1 = t2 }> ad

  | acc_asg2 : forall t1 t2 ad,
    access m t2 ad ->
    access m <{ t1 = t2 }> ad

  | acc_fun : forall x Tx t ad,
    access m t ad ->
    access m <{ fn x Tx --> t }> ad

  | acc_call1 : forall t1 t2 ad,
    access m t1 ad ->
    access m <{ call t1 t2 }> ad

  | acc_call2 : forall t1 t2 ad,
    access m t2 ad ->
    access m <{ call t1 t2 }> ad

  | acc_seq1 : forall t1 t2 ad,
    access m t1 ad ->
    access m <{ t1; t2 }> ad

  | acc_seq2 : forall t1 t2 ad,
    access m t2 ad ->
    access m <{ t1; t2 }> ad
  .

Ltac inversion_acc :=
  match goal with
  | H : access _ <{ unit         }> _ |- _ => inversion H
  | H : access _ <{ N _          }> _ |- _ => inversion H
  | H : access _ <{ & _ :: _     }> _ |- _ => inversion H; subst
  | H : access _ <{ new _ _      }> _ |- _ => inversion H; subst
  | H : access _ <{ * _          }> _ |- _ => inversion H; subst
  | H : access _ <{ _ = _        }> _ |- _ => inversion H; subst
  | H : access _ <{ var _        }> _ |- _ => inversion H
  | H : access _ <{ fn _ _ --> _ }> _ |- _ => inversion H; subst
  | H : access _ <{ call _ _     }> _ |- _ => inversion H; subst
  | H : access _ <{ _ ; _        }> _ |- _ => inversion H; subst
  | H : access _ <{ spawn _      }> _ |- _ => inversion H
  end.

Ltac inversion_clear_acc :=
  match goal with
  | H : access _ <{ unit         }> _ |- _ => inversion H
  | H : access _ <{ N _          }> _ |- _ => inversion H
  | H : access _ <{ & _ :: _     }> _ |- _ => inversion_subst_clear H
  | H : access _ <{ new _ _      }> _ |- _ => inversion_subst_clear H
  | H : access _ <{ * _          }> _ |- _ => inversion_subst_clear H
  | H : access _ <{ _ = _        }> _ |- _ => inversion_subst_clear H
  | H : access _ <{ var _        }> _ |- _ => inversion H
  | H : access _ <{ fn _ _ --> _ }> _ |- _ => inversion_subst_clear H
  | H : access _ <{ call _ _     }> _ |- _ => inversion_subst_clear H
  | H : access _ <{ _ ; _        }> _ |- _ => inversion_subst_clear H
  | H : access _ <{ spawn _      }> _ |- _ => inversion H
  end.

(* ------------------------------------------------------------------------- *)
(* properties                                                                *)
(* ------------------------------------------------------------------------- *)

(* strong acc_mem *)
Theorem acc_mem_trans : forall m t ad ad',
  ad <> ad' ->
  access m t ad' ->
  access m m[ad'].tm ad ->
  access m t ad.
Proof.
  intros * ? Hacc ?. induction Hacc; eauto using access.
  destruct (Nat.eq_dec ad ad'); subst; eauto using access.
Qed.

Lemma acc_length : forall m ad ad',
  access m m[ad'].tm ad ->
  ad' < #m.
Proof.
  intros * Hacc. decompose sum (lt_eq_lt_dec ad' (#m)); subst; trivial;
  simpl_array; try lia; inversion Hacc.
Qed.

Lemma acc_dec : forall m t ad,
  Decidable.decidable (access m t ad).
Proof. eauto using classic_decidable. Qed.

(* ------------------------------------------------------------------------- *)
(* not-access                                                                *)
(* ------------------------------------------------------------------------- *)

Inductive not_access (m : mem) : tm -> addr -> Prop :=
  | nacc_unit : forall ad,
    not_access m <{ unit }> ad

  | nacc_num : forall n ad,
    not_access m <{ N n }> ad

  | nacc_ref : forall T ad ad',
    ad <> ad' ->
    ~ access m m[ad].tm ad' ->
    not_access m <{ &ad :: T }> ad'

  | nacc_new : forall T t ad,
    ~ access m t ad ->
    not_access m <{ new T t }> ad

  | nacc_load : forall t ad,
    ~ access m t ad ->
    not_access m <{ *t }> ad

  | nacc_asg : forall t1 t2 ad,
    ~ access m t1 ad ->
    ~ access m t2 ad ->
    not_access m <{ t1 = t2 }> ad

  | nacc_var : forall x ad,
    not_access m <{ var x }> ad

  | nacc_fun : forall x Tx t ad,
    ~ access m t ad ->
    not_access m <{ fn x Tx --> t }> ad

  | nacc_call : forall t1 t2 ad,
    ~ access m t1 ad ->
    ~ access m t2 ad ->
    not_access m <{ call t1 t2 }> ad

  | nacc_seq : forall t1 t2 ad,
    ~ access m t1 ad ->
    ~ access m t2 ad ->
    not_access m <{ t1; t2 }> ad

  | nacc_spawn : forall t ad,
    not_access m <{ spawn t }> ad
  .

Theorem nacc_iff : forall m t ad,
  ~ access m t ad <-> not_access m t ad.
Proof.
  intros. split; intros Hnacc; destruct t;
  try (eapply nacc_ref
    || eapply nacc_asg
    || eapply nacc_call
    || eapply nacc_seq);
  eauto using access, not_access;
  intros ?; subst;
  try (inversion_acc; inversion_clear Hnacc); eauto using access.
  match goal with
  | Hnacc : ~ access _ <{ & ?ad :: _ }> ?ad' |- _ =>
    destruct (Nat.eq_dec ad ad'); subst; eauto using access
  end.
Qed.

Ltac inversion_nacc Hnacc :=
  eapply nacc_iff in Hnacc; inversion Hnacc; subst; eauto using access.

(* ------------------------------------------------------------------------- *)
(* valid-accesses                                                            *)
(* ------------------------------------------------------------------------- *)

Definition valid_accesses (m : mem) (t : tm) :=
  forall ad, access m t ad -> ad < #m.

(* TODO vac_lt_length *)
Lemma vac_length : forall m t ad,
  valid_accesses m t ->
  access m t ad ->
  ad < #m.
Proof.
  intros * Hvac Hacc.
  decompose sum (lt_eq_lt_dec ad (#m)); subst; trivial.
  - specialize (Hvac (#m) Hacc). lia.
  - specialize (Hvac ad Hacc). lia.
Qed.

Corollary vac_neq_length : forall m t ad,
  valid_accesses m t ->
  access m t ad ->
  ad <> #m.
Proof.
  intros. eauto using Nat.lt_neq, vac_length.
Qed.

Lemma vac_nacc_length : forall m t,
  valid_accesses m t ->
  ~ access m t (#m).
Proof.
  intros * ? F. eapply vac_length in F; eauto. lia.
Qed.

(* ------------------------------------------------------------------------- *)
(* inversion -- valid-accesses                                               *)
(* ------------------------------------------------------------------------- *)

Local Ltac solve_vac_inversion :=
  intros; unfold valid_accesses in *; try split; eauto using access.

Local Lemma inv_vac_ref : forall m ad T,
  valid_accesses m <{ &ad :: T }> ->
  valid_accesses m m[ad].tm.
Proof.
  intros; unfold valid_accesses in *; eauto using access.
  intros ad'. destruct (Nat.eq_dec ad ad'); subst; eauto using access.
Qed.

Local Lemma inv_vac_new : forall m t T,
  valid_accesses m <{ new T t }> ->
  valid_accesses m t.
Proof. solve_vac_inversion. Qed.

Local Lemma inv_vac_load : forall m t,
  valid_accesses m <{ *t }> ->
  valid_accesses m t.
Proof. solve_vac_inversion. Qed.

Local Lemma inv_vac_asg : forall m t1 t2,
  valid_accesses m <{ t1 = t2 }> ->
  valid_accesses m t1 /\ valid_accesses m t2.
Proof. solve_vac_inversion. Qed.

Local Lemma inv_vac_fun : forall m x Tx t,
  valid_accesses m <{ fn x Tx --> t }> ->
  valid_accesses m t.
Proof. solve_vac_inversion. Qed.

Local Lemma inv_vac_call : forall m t1 t2,
  valid_accesses m <{ call t1 t2 }> ->
  valid_accesses m t1 /\ valid_accesses m t2.
Proof. solve_vac_inversion. Qed.

Local Lemma inv_vac_seq : forall m t1 t2,
  valid_accesses m <{ t1; t2 }> ->
  valid_accesses m t1 /\ valid_accesses m t2.
Proof. solve_vac_inversion. Qed.

Ltac inversion_vac :=
  match goal with
  | H: valid_accesses _ <{ &_ :: _  }> |- _ => eapply inv_vac_ref  in H as Hwba'
  | H: valid_accesses _ <{ new _ _  }> |- _ => eapply inv_vac_new  in H
  | H: valid_accesses _ <{ * _      }> |- _ => eapply inv_vac_load in H
  | H: valid_accesses _ <{ _ = _    }> |- _ => eapply inv_vac_asg  in H as [? ?]
  | H: valid_accesses _ <{ fn _ _ --> _ }> |- _ => eapply inv_vac_fun in H
  | H: valid_accesses _ <{ call _ _ }> |- _ => eapply inv_vac_call in H as [? ?]
  | H: valid_accesses _ <{ _ ; _    }> |- _ => eapply inv_vac_seq  in H as [? ?]
  end.

(* ------------------------------------------------------------------------- *)
(* valid-accesses derives from valid-addresses                               *)
(* ------------------------------------------------------------------------- *)

Local Lemma acc_then_hasad : forall m t ad,
  access m t ad ->
  HasAddress ad t \/ (exists ad', HasAddress ad m[ad'].tm).
Proof.
  intros * Hacc.
  induction Hacc; try destruct IHHacc as [? | [? ?]]; eauto using HasAddress.
Qed.

Theorem vad_then_vac : forall m t,
  valid_addresses m t ->
  forall_memory m (valid_addresses m) ->
  valid_accesses m t.
Proof.
  intros. intros ? ?. unfold forall_memory in *. unfold valid_addresses in *.
  assert (HasAddress ad t \/ (exists ad', HasAddress ad m[ad'].tm))
    as [? | [? ?]];
  eauto using acc_then_hasad.
Qed.

Theorem vad_then_mem_vac : forall m t,
  valid_addresses m t ->
  forall_memory m (valid_addresses m) ->
  forall_memory m (valid_accesses m).
Proof.
  intros. intros ad' ? ?.
  unfold forall_memory in *. unfold valid_addresses in *.
  assert (HasAddress ad m[ad'].tm \/ (exists ad'', HasAddress ad m[ad''].tm))
    as [? | [? ?]];
  eauto using acc_then_hasad.
Qed.

Corollary forall_threads_vad_then_vac : forall m ths,
  forall_threads ths (valid_addresses m) ->
  forall_memory m (valid_addresses m) ->
  forall_threads ths (valid_accesses m).
Proof.
  intros. intros ?. eauto using vad_then_vac.
Qed.

(* ------------------------------------------------------------------------- *)
(* properties -- subst                                                       *)
(* ------------------------------------------------------------------------- *)

Lemma subst_acc : forall m x Tx t t' ad,
  access m ([x := t'] t) ad ->
  access m <{ call <{ fn x Tx --> t }> t' }> ad.
Proof.
  intros. induction t; eauto using access; simpl in *;
  try (destruct String.string_dec; eauto using access);
  inversion_clear_acc; auto_specialize; do 2 inversion_acc; eauto using access.
Qed.

Local Lemma subst_nacc' : forall m t tx ad x,
  ~ access m t ad ->
  ~ access m tx ad ->
  ~ access m ([x := tx] t) ad.
Proof.
  intros * Hnacc ?. generalize dependent tx.
  induction t; intros; trivial; simpl;
  try solve [eapply nacc_iff; inversion_nacc Hnacc; eauto using not_access];
  destruct String.string_dec; trivial.
  inversion_nacc Hnacc. eapply nacc_iff. eauto using not_access.
Qed.

Lemma subst_nacc : forall m t tx ad x Tx,
  ~ access m <{ fn x Tx --> t }> ad ->
  ~ access m tx ad ->
  ~ access m ([x := tx] t) ad.
Proof.
  intros * Hnacc ?. inversion_nacc Hnacc; eauto using subst_nacc'.
Qed.

(* ------------------------------------------------------------------------- *)
(* properties -- memory -- add                                               *)
(* ------------------------------------------------------------------------- *)

Lemma mem_add_acc : forall m t ad vTr,
  ~ access m t (#m) ->
  access (m +++ vTr) t ad ->
  access m t ad.
Proof.
  intros * Hnacc Hacc. remember (m +++ vTr) as m'.
  induction Hacc; inversion Heqm'; subst; inversion_nacc Hnacc.
  decompose sum (lt_eq_lt_dec ad' (#m)); subst; try lia;
  simpl_array; eauto using access. simpl in *. inversion_acc.
Qed.

Lemma mem_add_nacc : forall m t ad vTr,
  ~ access m t (#m) ->
  ~ access m t ad ->
  ~ access (m +++ vTr) t ad.
Proof.
  intros * Hnacc1 Hnacc2 F. induction F; inversion_nacc Hnacc2.
  decompose sum (lt_eq_lt_dec ad' (#m)); subst; simpl_array;
  inversion_nacc Hnacc1. eapply IHF; eapply nacc_iff; eauto using not_access.
Qed.

(* ------------------------------------------------------------------------- *)
(* properties -- inheritance                                                 *)
(* ------------------------------------------------------------------------- *)

Lemma mem_set_acc : forall m t ad ad' vTr,
  ~ access m t ad' ->
  access m[ad' <- vTr] t ad ->
  access m t ad.
Proof.
  intros * Hnacc Hacc.  remember (m[ad' <- vTr]) as m'.
  induction Hacc; inversion_subst_clear Heqm'; inversion_nacc Hnacc;
  simpl_array; eauto using access.
Qed.

Local Lemma mem_set_acc' : forall m t ad ad' v Tr,
  ~ access m v ad ->
  access m[ad' <- (v, Tr)] t ad ->
  access m t ad.
Proof.
  intros * Hnacc Hacc. remember (m[ad' <- (v, Tr)]) as m'.
  induction Hacc; try rename IHHacc into IH;
  inversion_subst_clear Heqm'; eauto using access.
  match goal with |- access _ <{ & ?ad :: _ }> _ => rename ad into ad'' end.
  destruct (Nat.eq_dec ad' ad''); subst;
  try simpl_array; eauto using access;
  destruct (Nat.eq_dec ad'' ad); subst; eauto using access.
  auto_specialize. rewrite (get_set_eq memory_default) in IH. 1: contradiction.
  eapply not_le. intros Hlen. simpl_array.
  eapply Nat.lt_eq_cases in Hlen as [? | ?]; subst;
  simpl_array; simpl in *; inversion_acc.
Qed.

Lemma mem_set_nacc1 : forall m t ad ad' vTr,
  ~ access m t ad' ->
  ~ access m t ad ->
  ~ access m[ad' <- vTr] t ad.
Proof.
  intros * Hnacc' Hnacc F. remember (m[ad' <- vTr]) as m'.
  induction F; inversion_nacc Hnacc'; inversion_nacc Hnacc.
  simpl_array. eauto.
Qed.

Lemma mem_set_nacc2 : forall m t ad ad' v Tr,
  ~ access m v ad ->
  ~ access m t ad ->
  ~ access m[ad' <- (v, Tr)] t ad.
Proof.
  assert (ge_iff_le : forall m n, m >= n <-> n <= m)
    by (intros; split; destruct n; eauto).
  assert (forall m ad ad' v,
    access m[ad' <- v] m[ad' <- v][ad'].tm ad ->
    ad' < length m). {
    intros * H. eapply not_ge. rewrite ge_iff_le. intros ?.
    rewrite (get_set_invalid memory_default) in H; trivial. inversion H.
  }
  (* main proof *)
  intros * ? ? Hacc. remember (m[ad' <- (v, Tr)]) as m'.
  induction Hacc; inversion_subst_clear Heqm'; eauto using access.
  match goal with _ : ~ access _ <{ & ?ad :: _ }> _ |- _ =>
    destruct (Nat.eq_dec ad' ad) as [? | Hneq]; subst;
    try (assert (ad < #m) by eauto)
  end;
  simpl_array; eauto using access.
Qed.

(* ------------------------------------------------------------------------- *)
(* access properties -- inheritance                                          *)
(* ------------------------------------------------------------------------- *)

Lemma step_none_inherits_access : forall m t t' ad,
  access m t' ad ->
  t --[EF_None]--> t' ->
  access m t ad.
Proof.
  intros. induction_step; try inversion_acc; eauto using access, subst_acc.
Qed.

Lemma step_alloc_inherits_acc : forall m t t' ad v Tr,
  valid_accesses m t ->
  ad <> #m ->
  access (m +++ (v, Tr)) t' ad ->
  t --[EF_Alloc (#m) v Tr]--> t' ->
  access m t ad.
Proof.
  intros. induction_step;
  inversion_vac; inversion_acc; eauto using access; try lia; try simpl_array;
  eauto using mem_add_acc, vac_nacc_length, access.
Qed.

Lemma step_read_inherits_acc : forall m t t' ad ad',
  access m t' ad ->
  t --[EF_Read ad' m[ad'].tm]--> t' ->
  access m t ad.
Proof.
  intros. induction_step; try inversion_acc; eauto using access.
  destruct (Nat.eq_dec ad' ad); subst; eauto using access.
Qed.

Lemma step_write_inherits_acc : forall m t t' ad ad' v Tr,
  access m[ad' <- (v, Tr)] t' ad ->
  t --[EF_Write ad' v Tr]--> t' ->
  access m t ad.
Proof.
  intros. induction_step; inversion_acc; eauto using access;
  destruct (acc_dec m v ad); eauto using mem_set_acc', access;
  assert (forall t t', t --[EF_Write ad' v Tr]--> t' -> access m t ad)
    by (intros; induction_step; eauto using access);
  eauto using access.
Qed.

Lemma step_spawn_inherits_acc : forall m t t' block ad,
  access m t' ad ->
  t --[EF_Spawn block]--> t' ->
  access m t ad.
Proof.
  intros. induction_step; inversion_acc; eauto using access.
Qed.

(* ------------------------------------------------------------------------- *)
(* not-access properties -- preservation                                     *)
(* ------------------------------------------------------------------------- *)

Local Lemma step_none_nacc_preservation : forall m t t' ad,
  ~ access m t ad ->
  t --[EF_None]--> t' ->
  ~ access m t' ad.
Proof.
  intros * Hnacc. intros. induction_step; inversion_nacc Hnacc;
  eauto using subst_nacc; eapply nacc_iff; eauto using not_access.
Qed.

Local Lemma step_alloc_nacc_preservation : forall m t t' ad v Tr,
  ad < #m ->
  valid_accesses m t ->
  ~ access m t ad ->
  t --[EF_Alloc (#m) v Tr]--> t' ->
  ~ access (m +++ (v, Tr)) t' ad.
Proof.
  intros * ? ? Hnacc. intros.
  induction_step; inversion_vac; inversion_nacc Hnacc;
  eapply nacc_iff; eauto using vac_nacc_length, mem_add_nacc, not_access.
  eapply nacc_ref; eauto using not_eq_sym, Nat.lt_neq. simpl_array. simpl in *.
  eauto using vac_nacc_length, mem_add_nacc.
Qed.

Local Lemma step_read_nacc_preservation : forall m t t' ad ad',
  ~ access m t ad ->
  t --[EF_Read ad' m[ad'].tm]--> t' ->
  ~ access m t' ad.
Proof.
  intros * Hnacc ?. induction_step; inversion_nacc Hnacc;
  try solve [eapply nacc_iff; eauto using not_access].
  match goal with | H : ~ access _ _ _ |- _ => inversion_nacc H end.
Qed.

Local Lemma step_write_nacc_preservation : forall m t t' ad ad' v Tr,
  ~ access m t ad ->
  t --[EF_Write ad' v Tr]--> t' ->
  ~ access m[ad' <- (v, Tr)] t' ad.
Proof.
  assert (forall m t t' ad ad' v Tr,
    ~ access m t ad ->
    t --[EF_Write ad' v Tr]--> t' ->
    ~ access m v ad)
    by (intros; induction_step; eauto using access).
  (* main proof *)
  intros * Hnacc ?. induction_step;
  inversion_nacc Hnacc; eapply nacc_iff;
  eauto using mem_set_nacc2, not_access.
Qed.

Corollary mstep_nacc_preservation : forall m m' t t' ad eff,
  ad < #m ->
  valid_accesses m t ->
  ~ access m t ad ->
  m / t ==[eff]==> m' / t' ->
  ~ access m' t' ad.
Proof.
  intros. inversion_mstep;
  eauto using step_none_nacc_preservation,
    step_alloc_nacc_preservation,
    step_read_nacc_preservation,
    step_write_nacc_preservation.
Qed.

Lemma step_spawn_nacc_preservation : forall m t t' block ad,
  ~ access m t ad ->
  t --[EF_Spawn block]--> t' ->
  ~ access m t' ad.
Proof.
  intros * Hnacc. intros. induction_step; inversion_nacc Hnacc;
  eapply nacc_iff; eauto using not_access.
Qed.


Require Export extraInv.
Local Open Scope Z.

Definition propInv2 (hands dryer : array bool) (ctrlState : array nat) (ctrlTimer timer : Z) : Prop :=
 forall i, (0<i /\ i<=timer -> (dryer.[of_Z (i-1)]=OFF /\ hands.[of_Z i]=OFF -> dryer.[of_Z i]=OFF)).

Definition inv (hands dryer : array bool) (ctrlState : array nat) (ctrlTimer timer : Z) : Prop :=
 (propInv2 hands dryer ctrlState ctrlTimer timer) /\ (extraInv hands dryer ctrlState ctrlTimer timer).

Definition startnewloop (hands0 hands1 dryer0 dryer1 : array bool) (ctrlState0 ctrlState1 : array nat)
(ctrlTimer0 ctrlTimer1 timer0 timer1 : Z) : Prop :=
(inv hands0 dryer0 ctrlState0 ctrlTimer0 timer0)  /\ timer1=timer0+1 /\ ctrlTimer1=ctrlTimer0+1 /\
ctrlState1=ctrlState0.[of_Z timer1 <- ctrlState0.[of_Z (timer1-1)]] /\
dryer1=dryer0.[of_Z timer1 <- dryer0.[of_Z (timer1-1)]] /\ hands1=hands0.[of_Z timer1 <- logvar].

Theorem startnewloop_to_propInv: (startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0
timer1) ->
 (propInv2 hands1 dryer1 ctrlState1 ctrlTimer1 timer0).

Proof.
intros Hstartnewloop.
inversion_clear Hstartnewloop.
(*split invariant*)
inversion_clear H.
unfold propInv2.
intros.
inversion_clear H0.
inversion_clear H5.
inversion_clear H6.
inversion_clear H7.
(*prove that dryer0 and dryer1 are equal in all indexes j<timer1*)
assert (Hdryer0_dryer1_same : (forall j, j<timer1 -> dryer0.[of_Z j]=dryer1.[of_Z j])).
intros.
apply arr_same_before_upd with dryer0.[of_Z (timer1-1)] timer1.
split; assumption.
rewrite <- Hdryer0_dryer1_same.
rewrite <- Hdryer0_dryer1_same in H3.
replace hands1.[of_Z i] with hands0.[of_Z i] in H3.
apply H1.
assumption.
assumption.
apply arr_same_before_upd with logvar timer1.
split.
auto with zarith.
assumption.
auto with zarith.
auto with zarith.
Qed.


From Coq Require Import Strings.String.
From Coq Require Import Lists.List.
Import ListNotations.
From FY Require Export Utils.
From FY Require Export Syntax.
From FY Require Export Semantics.
From FY Require Export Assertion.
From FY Require Export Logic.

Definition X : string := "X".

Definition Prog : com :=
  <{ new_qubit;
     q 0 *= GH;
     X :=meas 0
    }>.

Print Prog.

Fact calc_0: 0.5 * ∣0⟩⟨0∣ = ∣0⟩⟨0∣ × (H × ∣0⟩⟨0∣ × (H) †) × (∣0⟩⟨0∣)†.
Proof.
Admitted.

Fact calc_1: 0.5 * ∣1⟩⟨1∣ = ∣1⟩⟨1∣ × (H × ∣0⟩⟨0∣ × (H) †) × (∣1⟩⟨1∣)†.
Proof. Admitted.

Theorem operational_sem:
  ceval 0 1 Prog [(( _ !-> 0%nat), I 1)]
  [(( X !-> 0%nat; _ !-> 0%nat), 0.5 * ∣0⟩⟨0∣ );
   (( X !-> 1%nat; _ !-> 0%nat), 0.5 * ∣1⟩⟨1∣ )].
Proof.
    eapply E_Seq.
    apply E_Init.
    simpl.
    eapply E_Seq.
    apply E_AppOne.
    simpl.
    rewrite calc_0.
    rewrite calc_1.
    eapply E_Meas.
Qed.

Definition pre : Assertion 0 := ((_ !-> 0%nat), (BTrue, I 1)).
Definition post : Assertion 1 := ((_ !-> 0%nat), (<{ X == (0 % nat)}>, ∣0⟩⟨0∣)).

Theorem exp: Expectation 1 1 [(( X !-> 0%nat; _ !-> 0%nat), 0.5 * ∣0⟩⟨0∣ );
(( X !-> 1%nat; _ !-> 0%nat), 0.5 * ∣1⟩⟨1∣ )] post = 0.5.
Proof.
  unfold Expectation, post.
  simpl.
  field_simplify.
  lra.
Qed.

Lemma pre_is_init_sub: pre = (init_sub 1 (AssertionOf 1%nat (StateOf pre) (PropOf pre) (∣0⟩⟨0∣))).
Proof. Admitted.

Lemma assrt_is_apply_sub:
(AssertionOf 1 (StateOf pre) (PropOf pre) ∣0⟩⟨0∣)
= (apply_sub 1 0 (geval GH) true
(AssertionOf 1 (StateOf pre) (PropOf pre) (H × ∣0⟩⟨0∣ × (H) †))) .
Proof. Admitted.

Theorem prog_correct: hoare_triple pre Prog post.
Proof.
    eapply fy_sequence.
    rewrite pre_is_init_sub.
    assert (H1: hoare_triple (init_sub 1%nat (StateOf pre, (PropOf pre, ∣0⟩⟨0∣)))
    <{ new_qubit }> (AssertionOf 1%nat (StateOf pre) (PropOf pre) ∣0⟩⟨0∣)).
    apply fy_init.
    apply H1.
    eapply fy_sequence.
    assert (H2: hoare_triple (apply_sub 1 0 (geval GH) true
    (AssertionOf 1 (StateOf pre) (PropOf pre) (H × ∣0⟩⟨0∣ × (H) †)))
    <{ q 0 *= GH }> (AssertionOf 1 (StateOf pre) (PropOf pre) (Utils.H × ∣0⟩⟨0∣ × Utils.H†))).
    apply fy_apply.
    rewrite assrt_is_apply_sub.
    apply H2.
    eapply fy_weakness.
    remember (AssertionOf 1%nat (_ !-> 0%nat)
      <{ X == (0 % nat) }> (H × ∣0⟩⟨0∣ × (H) †)) as pm.
    apply fy_measure.
    intros.
    unfold weaker,
     AssertPreMeas, AssertionOf.
    simpl.
    unfold PropOf, DensityOf, StateOf.
    simpl.
    induction st.
    simpl.
    lra.
    simpl.
    destruct (mergeMaps (fst a) (_ !-> 0%nat) X =? 0) eqn:bv1.
    simpl.
    admit.
    admit.
    admit.
Admitted.


(* Simplify contains theorems that show that
   Language definitions of regular expressions are equivalent.
*)

Require Import CoqStock.DubStep.
Require Import CoqStock.Invs.
Require Import CoqStock.List.
Require Import CoqStock.Listerine.
Require Import CoqStock.Untie.
Require Import CoqStock.WreckIt.

Require Import Brzozowski.Alphabet.
Require Import Brzozowski.ConcatLang.
Require Import Brzozowski.Decidable.
Require Import Brzozowski.Language.
Require Import Brzozowski.LogicOp.
Require Import Brzozowski.Regex.

(*
TODO: Good First Issue
Create a theorem for and prove a simplification rule below:

## Simplification rules mentioned in the Brzozowski paper.

R + R = R
P + Q = Q + P
(P + Q) + R = P + (Q + R)

R + ∅ = R
∅ + R = R
concat_lang_emptyset_r_is_emptyset: R,∅ = ∅
concat_lang_emptyset_l_is_emptyset: ∅,R = ∅
concat_lang_emptystr_r_is_r: R,λ = R
concat_lang_emptystr_l_is_l: λ,R = R

~∅+X = ~∅
~∅&X = X

~(P+Q) = ~P&~Q
~(P&Q) = ~P+~Q

Q&~λ = Q where nullable(Q) = false

## Extra simplification from the Scott Owen's regular expression re-examined paper

r&r = r
r&s = s&r
(r&s)&t = r&(s&t)
∅&r = ∅

(r,s),t = r,(s,t)

r** = r*
λ* = λ
∅* = λ
neg_lang_neg_lang_is_lang: ~~r = r
*)

Theorem neg_lang_neg_lang_is_lang: forall (r: regex),
  neg_lang (neg_lang {{r}})
  {<->}
  {{r}}.
Proof.
unfold lang_iff.
intros.
specialize denotation_is_decidable with (s := s) (r := r) as D.
destruct D.
- split.
  + auto.
  + intros.
    constructor.
    untie.
    invs H1.
    contradiction.
- split.
  + intros.
    invs H0.
    exfalso.
    apply H1.
    constructor.
    assumption.
  + intros.
    contradiction.
Qed.

Theorem concat_lang_emptyset_l_is_emptyset: forall (r: lang),
  concat_lang emptyset_lang r
  {<->}
  emptyset_lang.
Proof.
split.
- intros.
  invs H.
  invs H1.
- intros.
  invs H.
Qed.

Theorem concat_lang_emptyset_r_is_emptyset: forall (r: lang),
  concat_lang r emptyset_lang
  {<->}
  emptyset_lang.
Proof.
split.
- intros.
  invs H.
  invs H2.
- intros.
  invs H.
Qed.

Theorem concat_lang_emptystr_l_is_l: forall (r: lang),
  concat_lang emptystr_lang r
  {<->}
  r.
Proof.
split.
- intros.
  invs H.
  inversion_clear H1.
  cbn.
  assumption.
- intros.
  destruct_concat_lang.
  exists [].
  exists s.
  exists eq_refl.
  split.
  + constructor.
  + assumption.
Qed.

Theorem concat_lang_emptystr_r_is_r: forall (r: lang),
  concat_lang r emptystr_lang
  {<->}
  r.
Proof.
split.
- intros.
  invs H.
  wreckit.
  subst.
  inversion_clear H2.
  listerine.
  assumption.
- intros.
  destruct_concat_lang.
  exists s.
  exists [].
  assert (s ++ [] = s). listerine. reflexivity.
  exists H0.
  split.
  + assumption.
  + constructor.
Qed.

Theorem lift_or_lang_over_concat_lang_r: forall (p q r: lang),
  (concat_lang p (or_lang q r))
  {<->}
  or_lang (concat_lang p q) (concat_lang p r).
Proof.
split; intros.
- constructor.
  invs H.
  invs H2.
  destruct H.
  + left.
    destruct_concat_lang.
    exists p0.
    exists q0.
    exists eq_refl.
    auto.
  + right.
    destruct_concat_lang.
    exists p0.
    exists q0.
    exists eq_refl.
    auto.
- invs H.
  invs H0.
  + destruct_concat_lang.
    invs H.
    exists p0.
    exists q0.
    exists eq_refl.
    split.
    * assumption.
    * constructor.
      left.
      assumption.
  + destruct_concat_lang.
    invs H.
    exists p0.
    exists q0.
    exists eq_refl.
    split.
    * assumption.
    * constructor.
      right.
      assumption.
Qed.

Theorem lift_or_lang_over_concat_lang_l: forall (p q r: lang),
  (concat_lang (or_lang p q) r)
  {<->}
  or_lang (concat_lang p r) (concat_lang q r).
Proof.
split; intros.
- constructor.
  invs H.
  invs H1.
  destruct H.
  + left.
    destruct_concat_lang.
    exists p0.
    exists q0.
    exists eq_refl.
    auto.
  + right.
    destruct_concat_lang.
    exists p0.
    exists q0.
    exists eq_refl.
    auto.
- invs H.
  invs H0.
  + destruct_concat_lang.
    invs H.
    exists p0.
    exists q0.
    exists eq_refl.
    split.
    * constructor.
      left.
      assumption.
    * assumption.
  + destruct_concat_lang.
    invs H.
    exists p0.
    exists q0.
    exists eq_refl.
    split.
    * constructor.
      right.
      assumption.
    * assumption.
Qed.

Theorem or_lang_emptyset_r_is_l: forall (r: lang),
  or_lang r emptyset_lang
  {<->}
  r.
Proof.
intros.
split.
- intros.
  invs H.
  destruct H0.
  + assumption.
  + invs H.
- intros.
  constructor.
  left.
  assumption.
Qed.

Theorem or_lang_emptyset_l_is_r: forall (r: lang),
  or_lang emptyset_lang r
  {<->}
  r.
Proof.
intros.
split.
- intros.
  invs H.
  destruct H0.
  + invs H.
  + assumption.
- intros.
  constructor.
  right.
  assumption.
Qed.

Theorem or_lang_idemp: forall (R: lang),
  or_lang R R {<->} R.
Proof.
intros.
split; intros.
- invs H. invs H0; assumption.
- constructor. left. assumption.
Qed.

Theorem or_lang_comm: forall (P Q: lang),
  or_lang P Q {<->} or_lang Q P.
Proof.
intros.
split; intros; invs H; constructor; destruct H0; auto.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Product of Data Structures                                              *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibReflect.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Product type *)

(* ---------------------------------------------------------------------- *)
(** ** Definition *)

(** From the Prelude:

    Inductive prod A B : Type :=
      | pair : A -> B -> prod A B.

    Hint Constructors prod : core.

    Add Printing Let prod.
    Notation "x * y" := (prod x y) : type_scope.
    Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.

    Definition fst A B (p:A*B) : A :=
      match p with (x,y) => x end.

    Definition snd A B (p:A*B) : B :=
      match p with (x,y) => y end.

  Remark: to follow conventions [pair] should be renamed to [prod_intro].

*)

(* ---------------------------------------------------------------------- *)
(** ** Inhabited *)

Global Instance Inhab_prod : forall `{Inhab A, Inhab B}, Inhab (A * B).
Proof using. intros. apply (Inhab_of_val (arbitrary, arbitrary)). Qed.

(* ********************************************************************** *)
(** * Structure *)

(** Decomposition as projection *)

Lemma prod2_eq_tuple_proj : forall A1 A2 (x:A1*A2),
  x = (fst x, snd x).
Proof using. intros. destruct~ x. Qed.

(** Structural equality *)

Section Properties.
Variables (A1 A2 A3 A4 : Type).
Lemma eq_prod2 : forall (x1 y1:A1) (x2 y2:A2),
  x1 = y1 ->
  x2 = y2 ->
  (x1, x2) = (y1, y2).
Proof using. intros. subst~. Qed.

Lemma eq_prod3 : forall (x1 y1:A1) (x2 y2:A2) (x3 y3:A3),
  x1 = y1 ->
  x2 = y2 ->
  x3 = y3 ->
  (x1, x2, x3) = (y1, y2, y3).
Proof using. intros. subst~. Qed.

Lemma eq_prod4 : forall (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
  x1 = y1 ->
  x2 = y2 ->
  x3 = y3 ->
  x4 = y4 ->
  (x1, x2, x3, x4) = (y1, y2, y3, y4).
Proof using. intros. subst~. Qed.

End Properties.

#[global]
Hint Immediate eq_prod2 eq_prod3 eq_prod4.

(* ********************************************************************** *)
(** * Operations *)

(* ---------------------------------------------------------------------- *)
(** ** Definition of projections *)

(** [fst] and [snd] are defined in the Prelude

  Definition fst A B (p:A*B) : A :=
    match p with (x,y) => x end.

  Definition snd A B (p:A*B) : B :=
    match p with (x,y) => y end.

*)

Arguments fst {A} {B}.
Arguments snd {A} {B}.

(* ---------------------------------------------------------------------- *)
(** ** Notation for projections *)

(** N-ary projections are defined as notations and not as
    definitions, which has appeared to be more flexible with
    respect to type inference.
    TODO: investigate the possibility of using definitions. *)

Notation "'proj11' P" := P (at level 69, only parsing).

Notation "'proj21' P" := (proj1 P) (at level 69, only parsing).
Notation "'proj22' P" := (proj2 P) (at level 69, only parsing).

Notation "'proj31' P" := (proj1 P) (at level 69).
Notation "'proj32' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj33' P" := (proj2 (proj2 P)) (at level 69).

Notation "'proj41' P" := (proj1 P) (at level 69).
Notation "'proj42' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj43' P" := (proj1 (proj2 (proj2 P))) (at level 69).
Notation "'proj44' P" := (proj2 (proj2 (proj2 P))) (at level 69).

Notation "'proj51' P" := (proj1 P) (at level 69).
Notation "'proj52' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj53' P" := (proj1 (proj2 (proj2 P))) (at level 69).
Notation "'proj54' P" := (proj1 (proj2 (proj2 (proj2 P)))) (at level 69).
Notation "'proj55' P" := (proj2 (proj2 (proj2 (proj2 P)))) (at level 69).

(*-----------------------------------------------------*)
(** ** Currying *)

Section Currying.
Variables (A1 A2 A3 A4 A5 B : Type).
Definition curry1 f : A1 -> B :=
  f.
Definition curry2 f : A1 -> A2 -> B :=
  fun x1 x2 => f (x1,x2).
Definition curry3 f : A1 -> A2 -> A3 -> B :=
  fun x1 x2 x3 => f (x1,x2,x3).
Definition curry4 f : A1 -> A2 -> A3 -> A4 -> B :=
  fun x1 x2 x3 x4 => f (x1,x2,x3,x4).
Definition curry5 f : A1 -> A2 -> A3 -> A4 -> A5 -> B :=
  fun x1 x2 x3 x4 x5 => f (x1,x2,x3,x4,x5).
End Currying.

(*-----------------------------------------------------*)
(** ** Uncurrying *)

Section Uncurrying.
Variables (A1 A2 A3 A4 A5 B : Type).
Definition uncurry1 f : A1 -> B :=
  f.
Definition uncurry2 f : A1*A2 -> B :=
  fun p => match p with (x1,x2) =>
  f x1 x2 end.
Definition uncurry3 f : A1*A2*A3 -> B :=
  fun p => match p with (x1,x2,x3) =>
  f x1 x2 x3 end.
Definition uncurry4 f : A1*A2*A3*A4 -> B :=
  fun p => match p with (x1,x2,x3,x4) =>
  f x1 x2 x3 x4 end.
Definition uncurry5 f : A1*A2*A3*A4*A5 -> B :=
  fun p => match p with (x1,x2,x3,x4,x5) =>
  f x1 x2 x3 x4 x5 end.
End Uncurrying.

(* ---------------------------------------------------------------------- *)
(** ** Uncurrying for relations *)

(** [uncurrypN] turns a function of type [A1 -> A1 -> .. -> AN -> AN -> B]
    into a function of type [(A1*..*AN) -> (A1*..*AN) -> B]. *)

Section Uncurryp.
Variables (A1 A2 A3 A4 B : Type).
Definition uncurryp1 f : A1 -> A1 -> B :=
  f.
Definition uncurryp2 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x1 y1 x2 y2 end.
Definition uncurryp3 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x1 x2 x3 y1 y2 y3 end.
Definition uncurryp4 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x1 x2 x3 x4 y1 y2 y3 y4 end.
End Uncurryp.

(** Unfolding *)

Tactic Notation "unfold_uncurryp" :=
  unfold uncurryp1, uncurryp2, uncurryp3, uncurryp4.

Tactic Notation "unfolds_uncurryp" :=
  unfold uncurryp1, uncurryp2, uncurryp3, uncurryp4 in *.

(* ---------------------------------------------------------------------- *)
(** ** Inverse projections for relations *)

(* --TODO: rename to [unprojpNK] and define also [unprojNK] *)

(** [unprojNK] turns a function of type [AK -> AK -> B]
    into a function of type [(A1*..*AN) -> (A1*..*AN) -> B]. *)

Section Unproj.
Variables (A1 A2 A3 A4 A5 B : Type).

Definition unproj21 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x1 y1 end.
Definition unproj22 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x2 y2 end.
Definition unproj31 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x1 y1 end.
Definition unproj32 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x2 y2 end.
Definition unproj33 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x3 y3 end.
Definition unproj41 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x1 y1 end.
Definition unproj42 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x2 y2 end.
Definition unproj43 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x3 y3 end.
Definition unproj44 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x4 y4 end.
Definition unproj51 f : A1*A2*A3*A4*A5 -> A1*A2*A3*A4*A5 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4,x5),(y1,y2,y3,y4,y5) =>
  f x1 y1 end.
Definition unproj52 f : A1*A2*A3*A4*A5 -> A1*A2*A3*A4*A5 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4,x5),(y1,y2,y3,y4,y5) =>
  f x2 y2 end.
Definition unproj53 f : A1*A2*A3*A4*A5 -> A1*A2*A3*A4*A5 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4,x5),(y1,y2,y3,y4,y5) =>
  f x3 y3 end.
Definition unproj54 f : A1*A2*A3*A4*A5 -> A1*A2*A3*A4*A5 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4,x5),(y1,y2,y3,y4,y5) =>
  f x4 y4 end.
Definition unproj55 f : A1*A2*A3*A4*A5 -> A1*A2*A3*A4*A5 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4,x5),(y1,y2,y3,y4,y5) =>
  f x5 y5 end.

End Unproj.

Arguments unproj21 [A1] A2 [B].
Arguments unproj22 A1 [A2] [B].
Arguments unproj31 [A1] A2 A3 [B].
Arguments unproj32 A1 [A2] A3 [B].
Arguments unproj33 A1 A2 [A3] [B].
Arguments unproj41 [A1] A2 A3 A4 [B].
Arguments unproj42 A1 [A2] A3 A4 [B].
Arguments unproj43 A1 A2 [A3] A4 [B].
Arguments unproj44 A1 A2 A3 [A4] [B].
Arguments unproj51 [A1] A2 A3 A4 A5 [B].
Arguments unproj52 A1 [A2] A3 A4 A5 [B].
Arguments unproj53 A1 A2 [A3] A4 A5 [B].
Arguments unproj54 A1 A2 A3 [A4] A5 [B].
Arguments unproj55 A1 A2 A3 A4 [A5] [B].

(** Unfolding *)

Tactic Notation "unfold_unproj" :=
  unfold unproj21, unproj22, unproj31, unproj32, unproj33,
         unproj41, unproj42, unproj43, unproj44,
         unproj51.

Tactic Notation "unfolds_unproj" :=
  unfold unproj21, unproj22, unproj31, unproj32, unproj33,
         unproj41, unproj42, unproj43, unproj44,
         unproj51 in *.


Require Import List.
Export ListNotations.

Require Import genT.
Require Import gen_tacs.
Require Import List_lemmasT.
Require Import existsT.
Require Import K_Syntax.

(* Some useful lemmas about lists. *)

Lemma in_exch_list : forall {A : Type} (l0 l1 l2 l3 l4 : list A) (a : A),
  In a (l0 ++ l1 ++ l2 ++ l3 ++ l4) -> In a (l0 ++ l3 ++ l2 ++ l1 ++ l4).
Proof.
intros A l0 l1 l2 l3 l4 a H.
apply in_app_or in H. destruct H. apply in_or_app. left. assumption.
apply in_app_or in H. destruct H. apply in_or_app. right. apply in_or_app. right.
apply in_or_app. right. apply in_or_app. left. assumption.
apply in_app_or in H. destruct H. apply in_or_app. right. apply in_or_app. right.
apply in_or_app. left. assumption.
apply in_app_or in H. destruct H. apply in_or_app. right. apply in_or_app. left.
assumption.
apply in_or_app. right. apply in_or_app. right. apply in_or_app. right.
apply in_or_app. right. assumption.
Qed.

Lemma InT_exch_list : forall {A : Type} (l0 l1 l2 l3 l4 : list A) (a : A),
  InT a (l0 ++ l1 ++ l2 ++ l3 ++ l4) -> InT a (l0 ++ l3 ++ l2 ++ l1 ++ l4).
Proof.
intros A l0 l1 l2 l3 l4 a H.
apply InT_app_or in H. destruct H. apply InT_or_app. left. assumption.
apply InT_app_or in i. destruct i. apply InT_or_app. right. apply InT_or_app. right.
apply InT_or_app. right. apply InT_or_app. left. assumption.
apply InT_app_or in i. destruct i. apply InT_or_app. right. apply InT_or_app. right.
apply InT_or_app. left. assumption.
apply InT_app_or in i. destruct i. apply InT_or_app. right. apply InT_or_app. left.
assumption.
apply InT_or_app. right. apply InT_or_app. right. apply InT_or_app. right.
apply InT_or_app. right. assumption.
Qed.

Lemma partition_1_element : forall {A : Type} (l1 l2 l3 l4 l5 l6 l7 : list A) a,
l1 ++ l2 ++ l3 ++ l4 ++ l5 = l6 ++ a :: l7 ->
  (existsT2 l8 l9, l1 = l8 ++ a :: l9) +
  ((existsT2 l8 l9, l2 = l8 ++ a :: l9) +
  ((existsT2 l8 l9, l3 = l8 ++ a :: l9) +
  ((existsT2 l8 l9, l4 = l8 ++ a :: l9) +
  ((existsT2 l8 l9, l5 = l8 ++ a :: l9))))).
Proof.
intros A l1. induction l1.
- simpl. induction l2.
  * simpl. induction l3.
    + simpl. induction l4.
      { simpl. intros. right. right. right. right. exists l6. exists l7.
        assumption. }
      { intros. destruct l6. simpl in H. right. right. right. left. exists []. simpl.
        inversion H. exists l4. reflexivity.
        inversion H. apply IHl4 in H2. destruct H2. destruct s. destruct s. exfalso.
        apply app_cons_not_nil in e. assumption.
        destruct s. destruct s. destruct s. exfalso.
        apply app_cons_not_nil in e. assumption.
        destruct s. destruct s. destruct s. exfalso.
        apply app_cons_not_nil in e. assumption.
        destruct s. destruct s. destruct s. right. right. right.
        left. exists (a1 :: x). exists x0. simpl. rewrite e. reflexivity.
        destruct s. destruct s. right. right. right. right. exists x. exists x0.
        assumption. }
    + intros l4 l5 l6 l7 a0 E. destruct l6.
      { inversion E. right. right. left. exists []. exists l3. simpl. reflexivity. }
      { inversion E. apply IHl3 in H1. destruct H1.
        destruct s. destruct s. exfalso.
        apply app_cons_not_nil in e. assumption.
        destruct s. destruct s. destruct s. exfalso.
        apply app_cons_not_nil in e. assumption.
        destruct s. destruct s. destruct s. right. right. left. exists (a1 :: x).
        exists x0. rewrite e. simpl. reflexivity.
        right. right. right. assumption. }
  * intros l3 l4 l5 l6 l7 a0 E. destruct l6. inversion E.
    { inversion E. right. left. exists []. exists l2. simpl. reflexivity. }
    { inversion E. apply IHl2 in H1. destruct H1.
      destruct s. destruct s. exfalso.
      apply app_cons_not_nil in e. assumption.
      destruct s. destruct s. destruct s. right. left. exists (a1 :: x). exists x0.
      rewrite e. simpl. reflexivity.
      right. right. assumption. }
- intros l2 l3 l4 l5 l6 l7 a0 E. destruct l6.
  { inversion E. left. exists []. exists l1. auto. }
  { inversion E. apply IHl1 in H1. destruct H1.
    destruct s. destruct s. left. exists (a1 :: x). exists x0. rewrite e. auto.
    right. assumption. }
Qed.

Lemma partition_1_element2 : forall {A : Type} (l1 l2 l3 l4 l5 l6 l7 : list A) a,
l1 ++ l2 ++ l3 ++ l4 ++ l5 = l6 ++ a :: l7 ->
  ((existsT2 l8 l9, (l1 = l8 ++ a :: l9) * (l9 ++ l2 ++ l3 ++ l4 ++ l5 = l7) * (l8 = l6)) +
  ((existsT2 l8 l9, (l2 = l8 ++ a :: l9) * (l9 ++ l3 ++ l4 ++ l5 = l7) * (l1 ++ l8 = l6)) +
  ((existsT2 l8 l9, (l3 = l8 ++ a :: l9) * (l9 ++ l4 ++ l5 = l7) * (l1 ++ l2 ++ l8 = l6)) +
  ((existsT2 l8 l9, (l4 = l8 ++ a :: l9) * (l9 ++ l5 = l7) * (l1 ++ l2 ++ l3 ++ l8 = l6)) +
  ((existsT2 l8 l9, (l5 = l8 ++ a :: l9) * (l9 = l7) * (l1 ++ l2 ++ l3 ++ l4 ++ l8 = l6))))))).
Proof.
intros A l1. induction l1.
- simpl. induction l2.
  * simpl. induction l3.
    + simpl. induction l4.
      { simpl. intros. right. right. right. right. exists l6. exists l7.
        split. split. assumption. reflexivity. reflexivity. }
      { intros. destruct l6. simpl in H. right. right. right. left. exists []. simpl.
        inversion H. exists l4.  split. split. reflexivity. reflexivity. reflexivity.
        inversion H. apply IHl4 in H2. destruct H2. destruct s. destruct s. exfalso.
        repeat destruct p. apply app_cons_not_nil in e0. assumption.
        destruct s. destruct s. destruct s. exfalso.
        repeat destruct p. apply app_cons_not_nil in e0. assumption.
        destruct s. destruct s. destruct s. exfalso.
        repeat destruct p. apply app_cons_not_nil in e0. assumption.
        destruct s. destruct s. destruct s. right. right. right.
        left. exists (a1 :: x). exists x0. simpl. repeat destruct p. rewrite e0.
        split. split. reflexivity. assumption. subst. reflexivity.
        destruct s. destruct s. right. right. right. right. exists x. exists x0.
        split. split. repeat destruct p. assumption. repeat destruct p. subst. reflexivity.
        repeat destruct p. subst. reflexivity. }
    + intros l4 l5 l6 l7 a0 E. destruct l6.
      { inversion E. right. right. left. exists []. exists l3. simpl. split. split. reflexivity. reflexivity. reflexivity. }
      { inversion E. apply IHl3 in H1. destruct H1.
        destruct s. destruct s. exfalso.
        repeat destruct p. apply app_cons_not_nil in e0. assumption.
        destruct s. destruct s. destruct s. exfalso.
        repeat destruct p. apply app_cons_not_nil in e0. assumption.
        destruct s. destruct s. destruct s. right. right. left. exists (a1 :: x).
        exists x0. repeat destruct p. rewrite e0. simpl. split. split. reflexivity. assumption. subst. reflexivity.
        right. right. right. destruct s. left. repeat destruct s. exists x. exists x0. repeat destruct p.
        split. split. assumption. assumption. simpl. subst. reflexivity.
        repeat destruct s. right. exists x. exists x0. repeat destruct p. split. split. assumption. assumption. subst. reflexivity. }
  * intros l3 l4 l5 l6 l7 a0 E. destruct l6. inversion E.
    { inversion E. right. left. exists []. exists l2. simpl. split. split. reflexivity. reflexivity. reflexivity. }
    { inversion E. apply IHl2 in H1. destruct H1.
      destruct s. destruct s. exfalso.
      repeat destruct p. apply app_cons_not_nil in e0. assumption.
      destruct s. destruct s. destruct s. right. left. exists (a1 :: x). exists x0.
      repeat destruct p. rewrite e. simpl. subst. split. split. reflexivity. reflexivity. reflexivity.
      right. right. destruct s. repeat destruct s. repeat destruct p. left. exists x. exists x0. subst. split. split. reflexivity.
      reflexivity. reflexivity.
      destruct s. repeat destruct s. repeat destruct p. subst. right. left. exists x. exists x0. subst. split. split. reflexivity.
      reflexivity. reflexivity.
      repeat destruct s. repeat destruct p. right. right. exists x. exists x0. subst. split. split. reflexivity.
      reflexivity. reflexivity. }
- intros l2 l3 l4 l5 l6 l7 a0 E. destruct l6.
  { inversion E. left. exists []. exists l1. auto. }
  { inversion E. apply IHl1 in H1. destruct H1.
    destruct s. destruct s. left. exists (a1 :: x). exists x0. repeat destruct p. rewrite e0. split.
    split. subst. reflexivity. subst. reflexivity. subst. reflexivity.
    destruct s.
    repeat destruct s. right. left. exists x. exists x0. repeat destruct p. subst. split. split. subst. reflexivity.
    reflexivity. reflexivity.
    destruct s.
    repeat destruct s. right. right. left. exists x. exists x0. repeat destruct p. subst. split. split. subst. reflexivity.
    reflexivity. reflexivity.
    destruct s.
    repeat destruct s. right. right. right. left. exists x. exists x0. repeat destruct p. subst. split. split. subst. reflexivity.
    reflexivity. reflexivity.
    destruct s.
    repeat destruct s. right. right. right. right. exists x. exists x0. repeat destruct p. subst. split. split. subst. reflexivity.
    reflexivity. reflexivity. }
Qed.

Lemma add_1_element_split_lists : forall {A : Type} (l1 l2 l3 l4 : list A) a,
    l1 ++ l2 = l3 ++ l4 -> ((l1 = l3) * (l2 = l4)) +
    (existsT2 l5 l6, ((l5 ++ a :: l6 ++ l2 = l3 ++ a :: l4) * (l5 ++ l6 = l1) * (l6 ++ l2 = l4) * (l5 = l3)) +
                     ((l1 ++ l5 ++ a :: l6 = l3 ++ a :: l4) * (l5 ++ l6 = l2) * (l1 ++ l5 = l3) * (l6 = l4))).
Proof.
intros A l1. induction l1.
- intros. rewrite app_nil_l in H. destruct l3.
  + left. rewrite app_nil_l in H. split. reflexivity. assumption.
  + right. exists (a0 :: l3). exists l4. right. split. split. split.
    rewrite app_nil_l. reflexivity. symmetry. assumption. rewrite app_nil_l.
    reflexivity. reflexivity.
- destruct l3.
  + intros. right. exists []. exists (a :: l1). left. split. split. split.
    repeat rewrite app_nil_l. rewrite H. reflexivity. rewrite app_nil_l. reflexivity.
    rewrite app_nil_l in H. assumption. reflexivity.
  + intros. inversion H. apply IHl1 with (a:=a1) in H2. destruct H2.
    * destruct p. subst. left. split. reflexivity. reflexivity.
    * destruct s. destruct s. destruct s.
      { repeat destruct p. subst. right. exists (a0 :: l3). exists x0.
        left. split. split. split. reflexivity. reflexivity. reflexivity.
        reflexivity. }
      { repeat destruct p. subst. right. exists x. exists l4. right. split. split. split.
        repeat rewrite app_assoc. reflexivity. reflexivity. reflexivity. reflexivity. }
Qed.

Lemma app2_find_hole {A : Type} : forall (l1 l2 l3 l4 : list A),
              l1 ++ l2 = l3 ++ l4 ->
              (existsT2 l5,
                ((l3 = l1) * (l4 = l2)) +
                ((l3 = l1 ++ l5) * (l2 = l5 ++ l4)) +
                ((l1 = l3 ++ l5) * (l4 = l5 ++ l2))).
Proof.
induction l1.
- intros. exists l3. left. right. split. reflexivity. assumption.
- intros l2 l3 l4 E. destruct l3.
  * rewrite app_nil_l in E. exists (a :: l1). right. split. reflexivity.
    symmetry. assumption.
  * inversion E. apply IHl1 in H1. destruct H1. destruct s.
    + destruct s.
      { destruct p. subst. exists []. left. left. auto. }
      { destruct p. subst. exists x. left. right. auto. }
    + destruct p. subst. exists x. right. auto.
Qed.

Theorem in_splitT : forall x (l:list MPropF), In x l -> existsT2 l1 l2, l = l1++x::l2.
Proof.
intros x l. induction l.
- intro. inversion H.
- intro. destruct (eq_dec_form x a).
  * subst. exists nil. exists l. auto.
  * assert (In x l). inversion H. subst. exfalso. apply n. reflexivity. assumption.
    apply IHl in H0. destruct H0. destruct s. subst. exists ([a] ++ x0). exists x1.
    auto.
Qed.

Lemma InT_dec : forall l (a : MPropF) , (InT a l) + ((InT a l) -> False).
Proof.
induction l.
- intro. right. intro. inversion H.
- intro a0. pose (IHl a0). destruct s.
  * left. apply InT_cons. assumption.
  * destruct (eq_dec_form a a0).
    + subst. left. apply InT_eq.
    + right. intro. inversion H.
      { apply n. assumption. }
      { apply f. assumption. }
Qed.

Lemma eq_dec_listsF : forall (l0 l1 : list MPropF), {l0 = l1} + {l0 <> l1}.
Proof.
apply list_eq_dec. apply eq_dec_form.
Qed.

Lemma eq_dec_seqs : forall (s0 s1 : rel (list MPropF)), {s0 = s1} + {s0 <> s1}.
Proof.
intros. destruct s0. destruct s1. destruct (eq_dec_listsF l l1) ; destruct (eq_dec_listsF l0 l2).
- subst. left. reflexivity.
- subst. right. intro. inversion H. auto.
- subst. right. intro. inversion H. auto.
- subst. right. intro. inversion H. auto.
Qed.

Lemma seqs_in_splitT : forall (x : rel (list MPropF)) l,
       In x l -> existsT2 l1 l2, l = l1 ++ x :: l2.
Proof.
intros x l. induction l.
- intro. inversion H.
- intro. destruct (eq_dec_seqs x a).
  * subst. exists nil. exists l. auto.
  * assert (In x l). inversion H. subst. exfalso. apply n. reflexivity. assumption.
    apply IHl in H0. destruct H0. destruct s. subst. exists ([a] ++ x0). exists x1.
    auto.
Qed.

Lemma In_InT_seqs : forall (seq : rel (list MPropF)) seqs, In seq seqs -> InT seq seqs.
Proof.
intros seq seqs. induction seqs.
- intro. inversion H.
- intro. apply seqs_in_splitT in H. destruct H. destruct s. rewrite e. apply InT_or_app.
  right. apply InT_eq.
Qed.

Lemma list_split_form : forall (A B : MPropF) l0 l1 l2 l3, (l0 ++ A :: l1 = l2 ++ B :: l3) ->
                          ((A = B) * (l0 = l2) * (l1 = l3)) +
                          (existsT2 l4 l5, (l0 = l4 ++ l5) * (l5 ++ A :: l1 = l3) * (l2 ++ [B] = l4)) +
                          (existsT2 l4 l5, (l1 = l4 ++ l5) * (l0 ++ A :: l4 = l2) * (B :: l3 = l5)).
Proof.
intros A B l0. generalize dependent A. generalize dependent B. induction l0.
- intros. simpl in H. destruct l2.
  * simpl in H. left. left. inversion H. auto.
  * simpl. inversion H. subst. right. exists l2. exists (B :: l3). auto.
- simpl. simpl in IHl0. intros. destruct l2.
  * left. right. simpl. exists [B]. exists l0. simpl. inversion H. subst. auto.
  * inversion H. subst. pose (@IHl0 B A l1 l2 l3 H2). repeat destruct s.
    + repeat destruct p. subst. left. left. auto.
    + repeat destruct p. subst. left. right. exists ((m :: l2) ++ [B]). exists x0.
      auto.
    + repeat destruct p. subst. right. exists x. exists (B :: l3). auto.
Qed.


Require Import Coq.omega.Omega.
Require Import Examples.AutoSep.

(** * A trivial example to make sure the array proof automation isn't completely borked *)

Definition readS : spec := SPEC("x") reserving 0
  Al ls,
  PRE[V] [| $3 < natToW (length ls) |] * array ls (V "x")
  POST[R] [| R = selN ls 3 |] * array ls (V "x").

Definition writeS : spec := SPEC("x") reserving 0
  Al ls,
  PRE[V] [| $3 < natToW (length ls) |] * array ls (V "x")
  POST[_] array (updN ls 3 11) (V "x").

Definition bump := map (fun w : W => w ^+ $1).

Definition bumpS : spec := SPEC("arr", "len") reserving 3
  Al ls,
  PRE[V] [| V "len" = $ (length ls) |] * array ls (V "arr")
  POST[_] array (bump ls) (V "arr").

Open Scope list_scope.

Definition arrays := bmodule "read" {{
  bfunction "read"("x") [readS]
    "x" <- "x" + 12;;
    "x" <-* "x";;
    Return "x"
  end with bfunction "write"("x") [writeS]
    "x" <- "x" + 12;;
    "x" *<- 11;;
    Return 0
  end with bfunction "bump"("arr", "len", "i", "tmp", "tmp2") [bumpS]
    "i" <- 0;;
    [Al ls, Al done, Al pending,
      PRE[V] [| V "len" = $ (length ls) |] * [| V "i" = $ (length done) |] * [| ls = done ++ pending |]
        * array ls (V "arr")
      POST[_] Ex ls', [| ls' = done ++ bump pending |] * array ls' (V "arr") ]
    While ("i" < "len") {
      "tmp" <- 4 * "i";;
      "tmp" <- "arr" + "tmp";;
      "tmp2" <-* "tmp";;
      "tmp" *<- "tmp2" + 1;;
      "i" <- "i" + 1
    };;
    Return 0
  end
}}.

Hint Rewrite app_length : sepFormula.

Lemma shift_pos : forall (ls1 ls2 : list W),
  (length ls1 < length (ls1 ++ ls2))%nat
  -> length ls1 + length ls2 = length (ls1 ++ hd (natToW 0) ls2 ^+ natToW 1 :: nil) + length (tl ls2).
  intros; autorewrite with sepFormula in *;
    destruct ls2; simpl in *; unfold W; omega.
Qed.

Ltac pure' := intros; repeat match goal with
                               | [ H : sel _ _ = _ |- _ ] => rewrite H in *
                             end;
  try match goal with
        | [ _ : context[length (?A ++ ?B)] |- _ ] =>
          assert (goodSize (length (A ++ B))) by (eapply containsArray_goodSize; eauto)
      end;
  autorewrite with sepFormula in *; simpl length in *; autorewrite with sepFormula.

Ltac pure := pure'; try (apply f_equal; apply shift_pos; pure'); eauto 7.

Lemma nil_front : forall A n,
  n = @length A nil + n.
  reflexivity.
Qed.

Hint Immediate nil_front.

Lemma shift_updN : forall v pending done,
  (length pending > 0)%nat
  -> updN (done ++ pending) (length done) v = done ++ v :: tl pending.
  induction done; simpl; intuition;
    destruct pending; simpl in *; auto; omega.
Qed.

Theorem selN_hd : forall pending done,
  selN (done ++ pending) (length done) = hd $0 pending.
  induction done; simpl; intuition;
    destruct pending; reflexivity.
Qed.

Hint Rewrite shift_updN selN_hd using solve [ eauto ] : sepFormula.

Hint Rewrite DepList.pf_list_simpl : sepFormula.

Hint Rewrite sel_selN upd_updN using solve [ eauto 6 ] : sepFormula.

Hint Resolve shift_pos.

Lemma not_done_yet : forall A (done pending : list A),
  natToW (length done) < $ (length done + length pending)
  -> (length pending > 0)%nat.
  destruct pending; simpl; intuition;
    rewrite <- plus_n_O in *; unfold natToW in *; nomega.
Qed.

Hint Immediate not_done_yet.

Lemma shift_reorg : forall pending,
  (length pending > 0)%nat
  -> hd $0 pending ^+ $1 :: bump (tl pending)
  = bump pending.
  intros; autorewrite with sepFormula in *; destruct pending; simpl in *; auto; omega.
Qed.

Hint Rewrite shift_reorg using solve [ eauto ] : sepFormula.

Hint Rewrite Npow2_nat wordToN_nat wordToNat_natToWord_idempotent
  using nomega : N.

Lemma now_done : forall A (done pending : list A),
  natToW (length done + length pending) <= $ (length done)
  -> goodSize (length done + length pending)
  -> pending = nil.
  destruct pending; simpl; intuition; elimtype False; eauto.
Qed.

Hint Resolve now_done.

Lemma unbump : forall done pending,
  pending = nil
  -> done ++ pending = done ++ bump pending.
  intros; subst; reflexivity.
Qed.

Hint Resolve unbump.

Hint Rewrite wordToNat_natToW_goodSize using solve [ eauto ] : N.

Lemma bound_nat : forall (done pending : list W),
  natToW (length done) < natToW (length done + length pending)
  -> goodSize (length (done ++ hd $0 pending ^+ $1 :: tl pending))
  -> (length done < length done + length pending)%nat.
  intros; autorewrite with sepFormula N in *; simpl in *;
    apply lt_goodSize'; eauto; destruct pending; simpl in *; eauto using goodSize_weaken.
Qed.

Hint Resolve bound_nat.

Hint Extern 1 (himp _ _ _) => reflexivity.

Lemma goodSize_prefix : forall a b : list W,
  goodSize (length (a ++ b))
  -> goodSize (length a).
  intros; autorewrite with sepFormula in *; eapply goodSize_weaken; eauto.
Qed.

Lemma goodSize_full : forall a b : list W,
  goodSize (length (a ++ b))
  -> goodSize (length a + length b).
  intros; autorewrite with sepFormula in *; eapply goodSize_weaken; eauto.
Qed.

Hint Extern 1 (goodSize (length _)) => eapply goodSize_prefix; eapply containsArray_goodSize.
Hint Extern 1 (goodSize (length _ + length _)) => eapply goodSize_full; eapply containsArray_goodSize.

Hint Extern 1 (_ < _)%nat => apply lt_goodSize'; [ assumption | | ].

Theorem arraysOk : moduleOk arrays.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract (sep_auto; pure).
(*TIME  Print Timing Profile. *)
Qed.


From Undecidability.L Require Export Util.L_facts.
From Undecidability.L.Tactics Require Import LTactics GenEncode.
(* ** Encoding of booleans *)

(* Definition bool_enc (b:bool) : term:= *)
(*   Eval simpl in *)
(*     if b then .\"t", "f"; "t" else .\"t", "f"; "f". *)

MetaCoq Run (tmGenEncodeInj "bool_enc" bool).
(* For each encoding, Lrewrite must contain an lemma that solves goals like "encode b s t >* match ...end". The database Lrewrite also calls Lproc to discharge the other assumptions *)
#[export] Hint Resolve bool_enc_correct : Lrewrite.

#[global]
Instance term_negb : computable negb.
Proof.
  extract.
Qed.

#[global]
Instance term_andb : computable andb.
Proof.
  extract.
Qed.

#[global]
Instance term_orb : computable orb.
Proof.
  extract.
Qed.

Definition OmegaLift := lam Omega.

Lemma OmegaLift_proc : proc OmegaLift.
Proof.  unfold OmegaLift.  Lproc. Qed.
#[export] Hint Resolve OmegaLift_proc : LProc.

Import L_Notations.

Definition trueOrDiverge := lam (var 0 I OmegaLift I).

Lemma trueOrDiverge_proc : proc trueOrDiverge.
Proof.  unfold trueOrDiverge. Lproc. Qed.
#[export] Hint Resolve trueOrDiverge_proc : LProc.

Lemma trueOrDiverge_true : trueOrDiverge (enc true) >(4) I.
Proof.
  unfold trueOrDiverge. cbv - [pow]. Lsimpl.
Qed.

#[export] Hint Resolve trueOrDiverge_true : Lrewrite.


Require Export SystemFR.Notations.
Require Export SystemFR.Evaluator.
Require Extraction.
Import Notations.UnTyped.

Definition capturedVariable2_example := Eval compute in
   [|
    let minus := def_rec f x y => match y with
                                 | 0 => x
                                 |s y' => match x with
                                         | 0 => 0
                                         | s x' => (f x' y') end
                                 end
    in
    let double := def_rec f x => match x with
                                | 0 => 0
                                | s x' => (s (s (f x'))) end
    in
    let x := (
         let x := 5 in
         let f := fun x => (double x) in
         let x := (f x) in
         minus x x) in
    x
    |].

Example capturedVariable2 : (eval capturedVariable2_example 1000) =  Some zero.
Proof.
  native_compute ; reflexivity. Qed.

(*
(* Extraction *)
Extraction Language Ocaml.
Set Extraction AccessOpaque.
Extraction "capturedVariable2.ml" capturedVariable2_example eval.
*)


Require Import equiv.
Require Import register_type.

Lemma updated_assignment_models_former_afterL :
  forall phi theta' j d,
    theta' |= former phi ->
    (theta', d) |= inv phi j ->
    update theta' j d |= former (afterL phi j).
Proof.
  intros phi theta' j d theta_phi theta'_d_b.
  unfold models; unfold assignment_models_rel.
  split.
    apply former_is_simpl_rel.
  intros i0 j0.
  unfold update; unfold former; unfold afterL;
  unfold after.
  case_eq (i0 =? j); intros i0j.
  - case_eq (j0 =? j); intros j0j.
  + split; intros H.
  * right; apply beq_nat_true; exact j0j.
  * reflexivity.
  + split; intros H.
  * left.
    apply theta'_d_b; auto.
  * destruct H as [H | H].
      apply theta'_d_b in H; auto.
    apply beq_nat_false in j0j.
    contradiction.
  - case_eq (j0 =? j); intros j0j.
  + split; intros H.
  * apply theta'_d_b; exact H.
  * apply theta'_d_b in H; exact H.
  + unfold former.
    split; intros H;
    apply theta_phi; exact H.
Qed.

Lemma deriv_implies_afterL :
  forall phi theta theta' j d,
    (theta', theta) |= phi ->
    theta j = d ->
      (theta', d) |= inv phi j /\
      (update theta' j d, theta) |= afterL phi j.
Proof.
  intros phi theta theta' j d;
  intros theta_phi theta_j_d.
  split.
  - (* (theta', d) |= inv phi j *)
    unfold models; unfold assignmentD_models_guard.
    intros i.
    split; intros H.
    { unfold inv.
      apply theta_phi.
      rewrite H. auto. }
    rewrite <- theta_j_d.
    apply theta_phi.
    apply H.
  - (* ((update theta' j d), theta) |= afterL phi j *)
    unfold models; unfold two_assignments_model_rel.
    split. (* 4 cases *)
    { (* update theta' j d i = update theta' j d j0
         <-> afterL phi j (X i) (X j0) *)
      split; intros H.
    + (* -> *)
      unfold afterL. unfold after.
      case_eq (i =? j); intros ij.
    * (* ij: (i =? j) = true *)
      unfold inv.
      unfold update in H.
      rewrite ij in H.
      case_eq (j0 =? j); intros j0j.
        right. apply beq_nat_eq. auto.
      rewrite j0j in H.
      left.
      apply theta_phi.
      rewrite theta_j_d. auto.
    * (* ij: (i =? j) = false *)
      unfold update in H.
      rewrite ij in H.
      case_eq (j0 =? j); intros j0j.
    -- (* j0j: (j0 =? j) = true *)
      rewrite j0j in H.
      unfold inv.
      apply theta_phi.
      rewrite theta_j_d. auto.
    -- (* j0j: (j0 =? j) = false *)
      rewrite j0j in H.
      unfold former.
      apply theta_phi. assumption.
    + (* <- *)
      unfold update.
      unfold afterL in H.
      unfold after in H.
      case_eq (i =? j); intros ij.
    * (* ij: (i =? j) = true *)
      rewrite ij in H.
      destruct H as [H | H].
    -- unfold inv in H.
      apply theta_phi in H.
      rewrite H.
      rewrite theta_j_d.
      case (j0 =? j); trivial.
    -- rewrite H.
      rewrite <- beq_nat_refl. trivial.
    * (* ij: (i =? j) = false *)
      rewrite ij in H.
      case_eq (j0 =? j); intros j0j.
    -- (* j0j: (j0 =? j) = true *)
      rewrite j0j in H.
      unfold inv in H.
      apply theta_phi in H.
      rewrite theta_j_d in H. assumption.
    -- (* j0j: (j0 =? j) = false *)
      rewrite j0j in H.
      unfold former in H.
      apply theta_phi in H. assumption.
    }
    split. (* last 3 cases *)
    { (* theta i = theta j0 <-> afterL phi j (X' i) (X' j0) *)
      split; intros H.
    + (* -> *)
      unfold afterL.
      apply theta_phi in H.
      assumption.
    + (* <- *)
      unfold afterL in H.
      apply theta_phi.
      assumption.
    }
    split. (* last 2 cases *)
    { (* update theta' j d i = theta j0 <-> afterL phi j (X i) (X' j0) *)
      split; intros H.
    + (* -> *)
      unfold afterL.
      case_eq (i =? j); intros ij.
    * apply theta_phi.
      rewrite theta_j_d.
      unfold update in H.
      rewrite ij in H.
      assumption.
    * apply theta_phi.
      unfold update in H.
      rewrite ij in H.
      assumption.
    + (* <- *)
      unfold afterL in H.
      unfold update.
      case_eq (i =? j); intros ij.
    * rewrite ij in H.
      apply theta_phi in H.
      rewrite theta_j_d in H.
      assumption.
    * rewrite ij in H.
      apply theta_phi in H.
      assumption.
    }
    { (* theta i = update theta' j d j0 <-> afterL phi j (X' i) (X j0) *)
      split; intros H.
    + (* -> *)
      unfold afterL.
      case_eq (j0 =? j); intros j0j.
    * apply theta_phi.
      rewrite theta_j_d.
      unfold update in H.
      rewrite j0j in H. auto.
    * apply theta_phi.
      unfold update in H.
      rewrite j0j in H.
      assumption.
    + (* <- *)
      unfold afterL in H.
      unfold update.
      case_eq (j0 =? j); intros j0j.
    * rewrite j0j in H.
      apply theta_phi in H.
      rewrite theta_j_d in H. auto.
    * rewrite j0j in H.
      apply theta_phi in H.
      assumption.
    }
Qed.

Lemma afterL_is_equiv_rel :
forall phi j,
is_equiv_rel phi ->
is_equiv_rel (afterL phi j).
Proof.
  intros phi j [phi_refl [phi_sym phi_tran]].
  repeat split.
- unfold is_reflexive.
  intros x.
  unfold afterL; unfold after.
  case x.
+ intros i.
  case_eq (i =? j); intros ij.
* right; apply beq_nat_true; exact ij.
* unfold former.
  apply phi_refl.
+ intros i.
  apply phi_refl.
- unfold is_symmetric.
  intros x y.
  unfold afterL; unfold after.
  case x, y.
+ case_eq (i =? j); case_eq (i0 =? j); intros i0j; intros ij.
* intros _.
  right.
  apply beq_nat_true; assumption.
* intros [H | H].
    assumption.
  apply beq_nat_false in i0j; contradiction.
* auto.
* unfold former.
  apply phi_sym.
+ case_eq (i =? j); intros ij; auto.
+ case_eq (i0 =? j); intros i0j; auto.
+ apply phi_sym.

- unfold is_transitive.
  intros x y z.
  case x, y, z;
  unfold afterL; unfold after.
+ case_eq (i =? j); case_eq (i0 =? j); intros i0j; intros ij.
* intros [_ [H | H]]; auto.
* case_eq (i1 =? j); intros i1j.
-- intros _.
  right; apply beq_nat_true; assumption.
-- intros [[H1 | H1] H2].
++ unfold inv in H1.
  unfold former in H2.
  apply phi_sym in H2.
  left.
  unfold inv.
  apply (phi_tran _ (X i0) _).
  split; assumption.
++ apply beq_nat_false in i0j. contradiction.
* case_eq (i1 =? j); intros i1j.
-- intros [H _]; assumption.
-- unfold inv; unfold former.
  intros [H1 [H2 | H2]].
++ apply phi_sym in H2.
  apply (phi_tran _ (X' j) _); auto.
++ apply beq_nat_false in i1j. contradiction.
* case_eq (i1 =? j); intros i1j.
-- unfold inv; unfold former.
  intros [H1 H2].
  apply (phi_tran _ (X i0) _); auto.
-- unfold former.
  apply phi_tran.
+ case_eq (i =? j); case_eq (i0 =? j); intros i0j; intros ij.
* intros [[H1 | H1] H2]; assumption.
* intros [[H1 | H1] H2].
-- unfold inv in H1.
  apply phi_sym in H1.
  apply (phi_tran _ (X i0) _).
  split; assumption.
-- apply beq_nat_false in i0j. contradiction.
* unfold inv.
  apply phi_tran.
* unfold former.
  apply phi_tran.
+ case_eq (i =? j); case_eq (i1 =? j); intros i1j; intros ij.
* intros _.
  right; apply beq_nat_true; assumption.
* intros [H1 H2].
  left.
  unfold inv.
  apply phi_sym.
  apply (phi_tran _ (X' i0) _).
  split; assumption.
* intros [H1 H2].
  apply phi_sym in H2.
  unfold inv.
  apply (phi_tran _ (X' i0) _).
  split; assumption.
* unfold former.
  apply phi_tran.
+ case_eq (i =? j); intros ij; apply phi_tran.
+ case_eq (i0 =? j); case_eq (i1 =? j); intros i1j; intros i0j.
* intros [H1 _]; assumption.
* intros [H1 [H2 | H2]].
-- unfold inv in H2.
  apply phi_sym.
  apply (phi_tran _ (X' j) _).
  split; assumption.
-- apply beq_nat_false in i1j. contradiction.
* intros [H1 H2].
  unfold inv in H2.
  apply phi_sym.
  apply (phi_tran _ (X i0) _).
  split; assumption.
* unfold former.
  apply phi_tran.
+ case_eq (i0 =? j); intros i0j.
* intros [H1 H2].
  apply phi_sym in H1.
  apply (phi_tran _ (X' j) _).
  split; assumption.
* apply phi_tran.
+ case_eq (i1 =? j); intros i1j.
* intros [H1 H2].
  apply phi_sym in H2.
  apply phi_sym.
  apply (phi_tran _ (X' i0) _).
  split; assumption.
* apply phi_tran.
+ apply phi_tran.
Qed.


(*|
#######################################################
How does decidable equality works with ``List.remove``?
#######################################################

:Link: https://stackoverflow.com/q/46589021
|*)

(*|
Question
********

I am starting in Coq and discovered that I have to provide a proof of
decidable equality to use ``List.remove``, e.g.
|*)

Require Import Coq.Lists.List.
Import List.ListNotations.

Inductive T : Set := A | B | C.

Lemma eq_dec : forall a b : T, {a = b} + {a <> b}.
Proof.
  destruct a, b; try (left; reflexivity); try (right; congruence).
Qed.

Definition f (xs : list T) : list T := List.remove eq_dec A xs.

(*| This now type-checks, but I don't understand how to use it. |*)

Theorem foo : f [A; B; C] = [B; C].
Proof. Fail reflexivity. (* .unfold .fails *)
Abort. (* .none *)

(*|
How does this decidable equality work and what is some good source I
could read about it?

Edit 1
======

I just learned about the `decide equality
<https://coq.inria.fr/distrib/8.6.1/refman/Reference-Manual010.html#hevea_tactic174>`__
tactic, which

    solves a goal of the form ``forall x y : R, {x=y} + {~x=y}``,
    where ``R`` is an inductive type such that its constructors do not
    take proofs or functions as arguments, nor objects in dependent
    types.

So ``eq_dec`` can rewriten:
|*)

Reset eq_dec. (* .none *)
Lemma eq_dec : forall a b : T, {a = b} + {a <> b}.
Proof. decide equality. Defined.

(*|
Edit 2
======

I just learned about the `Scheme Equality for T
<https://coq.inria.fr/distrib/8.6.1/refman/Reference-Manual015.html#hevea_command235>`__
command, which

    Tries to generate a Boolean equality and a proof of the
    decidability of the usual equality. If identi involves some other
    inductive types, their equality has to be defined first.

So ``T_beq : T -> T -> bool`` and ``T_eq_dec : forall x y : T, {x = y}
+ {x <> y}`` can be automatically generated.
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

The problem is that you used the ``Qed`` command to end your proof.
This causes the ``eq_dec`` function you just defined to become opaque,
thus preventing Coq from simplifying expressions involving it. A
simple solution in this case is to use ``Defined`` instead:
|*)

Reset Initial. (* .none *)
Require Import Coq.Lists.List.
Import List.ListNotations.

Inductive T : Set := A | B | C.

Lemma eq_dec : forall a b : T, {a = b} + {a <> b}.
Proof.
  destruct a, b; try (left; reflexivity); try (right; congruence).
Defined.

Definition f (xs : list T) : list T := List.remove eq_dec A xs.

Theorem foo : f [A; B; C] = [B; C].
Proof. reflexivity. Qed.

(*|
You can check Adam Chlipala's `CPDT book
<http://adam.chlipala.net/cpdt/html/Subset.html>`__ to learn more
about this style of programming.

There is also an alternative approach, which I personally prefer. The
idea is to program normal equality tests that return booleans, and
prove after the fact that the tests are correct. This is useful for
two reasons.

1. It allows reusing standard boolean operators to write these
   functions; and
2. functions that involve proofs (like ``eq_dec``) can interact badly
   with Coq's reduction machinery, because the reduction needs to take
   the proofs into account.

You can read more about this alternative style in the `Software
Foundations book
<https://softwarefoundations.cis.upenn.edu/lf-current/IndProp.html#lab223>`__.
You can also have a look at the `mathematical components
<https://math-comp.github.io/math-comp/>`__ library, which uses this
style pervasively -- for example, to define a notion of `type with
decidable equality
<http://ssr.msr-inria.inria.fr/~jenkins/current/mathcomp.ssreflect.eqtype.html>`__.
|*)

(*|
Answer (Yves)
*************

You can also keep the proof of decidable equality opaque, but in this
case you have to use another tactic than ``reflexivity`` to prove your
result.

In the same context as your example, try this:
|*)

Reset foo. (* .none *)
Theorem foo : f [A; B; C] = [B; C].
Proof.
  unfold f. simpl.
  case (eq_dec A A); [intros _ | intros abs; case abs; auto].
  case (eq_dec A B); [discriminate | intros _].
  case (eq_dec A C); [discriminate | intros _].
  reflexivity.
Qed.

(*|
Knowing that this solution exists may be very useful when you want to
reason more abstractly about the equality between elements of your
type and when computation cannot do everything for you.

----

**Q:** Could this pattern be automated using Ltac? i.e. a
``reduce_eq_dec x y`` that would detect whether ``x`` is syntactically
equal to ``y`` and use either the ``case`` or ``discriminate``
approach you highlighted?

**A:** yes, and using ``try`` you don't even have to be able to tested
whether ``x`` and ``y`` really are equal.
|*)