(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University

  This file is part of Velisarios.

  Velisarios is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Velisarios is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export Omega.
Require Export tactics2.
Require Export Morphisms Setoid Field.

Class Cast A B := cast: A -> B.
Arguments cast _ _ {Cast} _.
Notation "' x" := (cast _ _ x) (at level 20).
Typeclasses Transparent Cast.

Section DTime.

  Fixpoint ntimes {T} (n : nat) (zero one : T) (add : T -> T -> T) : T :=
    match n with
    | 0 => zero
    | S n => add one (ntimes n zero one add)
    end.

  Class DTimeContext :=
    MkDTimeContext
      {
        dt_T                : Type;
        dt_0                : dt_T;
        dt_1                : dt_T;
        dt_add              : dt_T -> dt_T -> dt_T;
        dt_mul              : dt_T -> dt_T -> dt_T;
        dt_sub              : dt_T -> dt_T -> dt_T;
        dt_opp              : dt_T -> dt_T;
        dt_eq               : relation dt_T;
        dt_lt               : relation dt_T;
        dt_le               : relation dt_T;
        dt_eqv              : Equivalence dt_eq;
        dt_ring             : ring_theory dt_0 dt_1 dt_add dt_mul dt_sub dt_opp dt_eq;
        dt_nat_inj          : nat -> dt_T;
        dt_approx           : dt_T -> nat;

        dt_add_morph        : forall x y, dt_eq x y -> forall u v, dt_eq u v -> dt_eq (dt_add x u) (dt_add y v);
        dt_mul_morph        : forall x y, dt_eq x y -> forall u v, dt_eq u v -> dt_eq (dt_mul x u) (dt_mul y v);
        dt_opp_morph        : forall x y, dt_eq x y -> dt_eq (dt_opp x) (dt_opp y);
        dt_le_morph         : forall x y, dt_eq x y -> forall u v, dt_eq u v -> dt_le x u -> dt_le y v;
        dt_lt_morph         : forall x y, dt_eq x y -> forall u v, dt_eq u v -> dt_lt x u -> dt_lt y v;

        dt_nat_inj_cond     : forall (n : nat), dt_eq (dt_nat_inj n) (ntimes n dt_0 dt_1 dt_add);
        dt_le_refl          : forall t , dt_le t t;
        dt_lt_irrefl        : forall x, ~ (dt_lt x x);
        dt_add_le_compat    : forall a b c d, dt_le a c -> dt_le b d -> dt_le (dt_add a b) (dt_add c d);
        dt_add_lt_le_compat : forall a b c d, dt_lt a c -> dt_le b d -> dt_lt (dt_add a b) (dt_add c d);
        dt_mul_le_compat_r  : forall a b c, dt_le a b -> dt_le dt_0 c -> dt_le (dt_mul a c) (dt_mul b c);
        dt_mul_lt_compat_r  : forall a b c, dt_lt a b -> dt_lt dt_0 c -> dt_lt (dt_mul a c) (dt_mul b c);
        dt_le_trans         : forall a b c, dt_le a b -> dt_le b c -> dt_le a c;
        dt_lt_trans         : forall a b c, dt_lt a b -> dt_lt b c -> dt_lt a c;
        dt_le_lt_trans      : forall a b c, dt_le a b -> dt_lt b c -> dt_lt a c;
        dt_lt_le_trans      : forall a b c, dt_lt a b -> dt_le b c -> dt_lt a c;

        dt_mul_0_l          : forall x, dt_eq (dt_mul dt_0 x) dt_0;
        dt_mul_le_r_le      : forall x y z, dt_lt dt_0 z -> dt_le (dt_mul x z) (dt_mul y z) -> dt_le x y;
        dt_mul_lt_r_lt      : forall x y z, dt_lt dt_0 z -> dt_lt (dt_mul x z) (dt_mul y z) -> dt_lt x y;
        dt_lt_0_1           : dt_lt dt_0 dt_1;
        dt_lt_le_weak       : forall a b, dt_lt a b -> dt_le a b;
        dt_lt_le_dec        : forall x y, {dt_lt x y} + {dt_le y x};
        dt_eq_dec           : forall x y, {dt_eq x y} + {~ dt_eq x y};
        dt_nat_inj_add_dist : forall n m, dt_eq (dt_add (dt_nat_inj n) (dt_nat_inj m)) (dt_nat_inj (n + m));
        dt_nat_nat_inj_le   : forall n m, n <= m -> dt_le (dt_nat_inj n) (dt_nat_inj m);
        dt_nat_nat_inj_lt   : forall n m, n < m -> dt_lt (dt_nat_inj n) (dt_nat_inj m); (* FIX: DO we really need this one? *)
        dt_nat_inj_lt_nat   : forall n m, dt_lt (dt_nat_inj n) (dt_nat_inj m) -> n < m;
      }.

  Context { dtc : DTimeContext }.

  Global Add Parametric Relation :
    dt_T dt_eq
      reflexivity  proved by (@Equivalence_Reflexive  dt_T dt_eq dt_eqv)
      symmetry     proved by (@Equivalence_Symmetric  dt_T dt_eq dt_eqv)
      transitivity proved by (@Equivalence_Transitive dt_T dt_eq dt_eqv)
    as dt_eq_rel.

  Global Add Parametric Relation :
    dt_T dt_le
      reflexivity  proved by dt_le_refl
      transitivity proved by dt_le_trans
    as dt_le_rel.

  Global Add Parametric Relation :
    dt_T dt_lt
      transitivity proved by dt_lt_trans
    as dt_lt_rel.

  Global Add Morphism dt_add with signature (dt_eq ==> dt_eq ==> dt_eq) as dt_add_ext.
  Proof. exact dt_add_morph. Qed.

  Global Add Morphism dt_mul with signature (dt_eq ==> dt_eq ==> dt_eq) as dt_mul_ext.
  Proof. exact dt_mul_morph. Qed.

  Global Add Morphism dt_opp with signature (dt_eq ==> dt_eq) as dt_opp_ext.
  Proof. exact dt_opp_morph. Qed.

  Add Ring rg_dt : dt_ring.

  Global Instance dt_le_eq : Proper (dt_eq ==> dt_eq ==> flip impl) dt_le.
  Proof.
    introv h1 h2 h3.
    eapply dt_le_morph; try exact h3; symmetry; auto.
  Qed.

  Global Instance dt_le_eq1 : forall x,  Proper (dt_eq ==> flip impl) (dt_le x).
  Proof.
    introv h1 h2.
    eapply dt_le_morph; try exact h2; try symmetry; auto; try reflexivity.
  Qed.

  Global Instance dt_lt_eq : Proper (dt_eq ==> dt_eq ==> flip impl) dt_lt.
  Proof.
    introv h1 h2 h3.
    eapply dt_lt_morph; try exact h3; symmetry; auto.
  Qed.

  Global Instance dt_add_eq : Proper (dt_eq ==> dt_eq ==> dt_eq) dt_add.
  Proof.
    introv h1 h2.
    eapply dt_add_morph; auto.
  Qed.

  (* We use positive rationals to model time *)
  Record PosDTime :=
    MkPosDTime
      {
        pos_dt_t :> dt_T;
        pos_dt_le : dt_le dt_0 pos_dt_t
      }.

  Lemma dt_le_0_ntimes :
    forall n,
      dt_le dt_0 (ntimes n dt_0 dt_1 dt_add).
  Proof.
    induction n; simpl; try reflexivity;[].
    pose proof (Radd_0_l dt_ring dt_0) as z.
    pose proof (dt_add_le_compat dt_0 dt_0 dt_1 (ntimes n dt_0 dt_1 dt_add)) as w.
    repeat (autodimp w hyp).
    { apply dt_lt_le_weak; apply dt_lt_0_1. }
    eapply dt_le_trans;[|exact w].
    rewrite z; reflexivity.
  Qed.

  Definition pdt_lt (q1 q2 : PosDTime) := dt_lt q1 q2.

  Definition pdt_mult (q1 q2 : PosDTime) : PosDTime.
  Proof.
    exists (dt_mul q1 q2).
    destruct q1 as [q1 c1], q2 as [q2 c2]; simpl.
    pose proof (dt_mul_le_compat_r dt_0 q1 q2) as w.
    repeat (autodimp w hyp).
    eapply dt_le_trans;[|exact w]; clear w.
    rewrite dt_mul_0_l; try reflexivity; auto.
  Defined.

  Definition pdt_plus (q1 q2 : PosDTime) : PosDTime.
  Proof.
    exists (dt_add q1 q2).
    destruct q1 as [q1 c1], q2 as [q2 c2]; simpl.
    pose proof (dt_add_le_compat dt_0 dt_0 q1 q2) as w.
    repeat (autodimp w hyp).
    eapply dt_le_trans;[|exact w]; clear w.
    rewrite (Radd_0_l dt_ring dt_0); try reflexivity.
  Defined.

  Delimit Scope dtime with dtime.
  Open Scope dtime.
  Infix "<"  := dt_lt  (at level 70) : dtime.
  Infix "<=" := dt_le  (at level 70) : dtime.
  Infix "+"  := dt_add : dtime.
  Infix "-"  := dt_sub : dtime.
  Infix "*"  := dt_mul : dtime.
  Infix "==" := dt_eq  (at level 70) : dtime.
  Notation "a <= b <= c" := ((a <= b) /\ (b <= c)) : dtime.
  Close Scope dtime.

  Definition nat2pdt : nat -> PosDTime.
  Proof.
    introv n.
    exists (dt_nat_inj n).
    rewrite dt_nat_inj_cond.
    apply dt_le_0_ntimes.
  Defined.

  Global Coercion nat2pdt : nat >-> PosDTime.

  Global Instance n2t : Cast nat PosDTime.
  Proof.
    introv n.
    exists (dt_nat_inj n).
    rewrite dt_nat_inj_cond.
    apply dt_le_0_ntimes.
  Defined.

  Class TimeConstraint :=
    {
      mu  : PosDTime; (* maximum message generation and transmission delay *)
      tau : PosDTime; (* maximum clock drift *)

      dlt : PosDTime; (* minimum message generation and transmission delay *)

      mu_strict_pos  : (0 < mu)%dtime;
      tau_strict_pos : (0 < tau)%dtime;
      dlt_strict_pos : (0 < dlt)%dtime;

      dlt_le_mu      : (dlt <= mu)%dtime;
    }.

  Context { tc : TimeConstraint }.

  (* use this abstraction instead of [mu + tau] *)
  Definition epoch_duration : dt_T := (mu + tau)%dtime.

  Lemma eq_dt_0 : dt_eq (dt_nat_inj 0) dt_0.
  Proof.
    rewrite dt_nat_inj_cond; simpl; auto; try reflexivity.
  Qed.

  Lemma eq_dt_1 : dt_eq (dt_nat_inj 1) dt_1.
  Proof.
    rewrite dt_nat_inj_cond; simpl; auto.
    rewrite (Radd_comm dt_ring).
    rewrite (Radd_0_l dt_ring); reflexivity.
  Qed.

  Lemma mu_plus_tau_pos : (0 < mu + tau)%dtime.
  Proof.
    pose proof (dt_add_lt_le_compat dt_0 dt_0 mu tau) as w.
    rewrite (Radd_0_l dt_ring dt_0) in w.
    rewrite <- eq_dt_0 in w; apply w; auto;
      try (apply mu_strict_pos).
      try (apply dt_lt_le_weak; apply tau_strict_pos).
  Qed.
  Hint Resolve mu_plus_tau_pos : dtime.

  Lemma mu_plus_tau_pos2 : (dt_0 < mu + tau)%dtime.
  Proof.
    rewrite <- eq_dt_0; eauto 2 with dtime.
  Qed.
  Hint Resolve mu_plus_tau_pos2 : dtime.

  Lemma mu_plus_tau_ge_0 : (0 <= mu + tau)%dtime.
  Proof.
    apply dt_lt_le_weak; apply mu_plus_tau_pos.
  Qed.
  Hint Resolve mu_plus_tau_ge_0 : dtime.

  Lemma mu_plus_tau_ge_dt0 : (dt_0 <= mu + tau)%dtime.
  Proof.
    rewrite <- eq_dt_0; eauto 2 with dtime.
  Qed.
  Hint Resolve mu_plus_tau_ge_dt0 : dtime.

  Lemma dt_le_lt_dec : forall x y, {(x <= y)%dtime} + {(y < x)%dtime}.
  Proof.
    introv.
    destruct (dt_lt_le_dec y x); tcsp.
  Defined.

  Definition PosDTime0 : PosDTime.
  Proof.
    exact (MkPosDTime dt_0 (dt_le_refl _)).
  Defined.

  Lemma time_plus_tau_le_aux :
    forall (t : PosDTime) (n1 n2 : nat),
      n1 < S n2
      -> (t <= n1 * (mu + tau))%dtime
      -> (t + (mu + tau) <= (S n2) * (mu + tau))%dtime.
  Proof.
    introv w1 w2.

    eapply dt_le_trans;[apply dt_add_le_compat;[eauto|apply dt_le_refl] |]; clear w2.

    pose proof (Rdistr_l
                  dt_ring
                  n1
                  1
                  (mu + tau)%dtime) as xx.
    simpl in *.
    rewrite eq_dt_1, (Rmul_1_l dt_ring) in xx.
    rewrite <- xx; clear xx.
    apply dt_mul_le_compat_r;[|rewrite <- eq_dt_0;eauto 2 with dtime];[].
    rewrite <- eq_dt_1.
    rewrite dt_nat_inj_add_dist; simpl.
    apply dt_nat_nat_inj_le; try omega.
  Qed.

  Lemma time_plus_mu_tau_lt :
    forall (t1 t2 : PosDTime) (n1 n2 : nat),
      n1 < S n2
      -> (t1 <= n1 * (mu + tau))%dtime
      -> ((S n2) * (mu + tau) < t2)%dtime
      -> (t1 + (mu + tau) < t2)%dtime.
  Proof.
    introv w1 w2 w3.
    eapply dt_le_lt_trans;[|eauto]; clear w3.
    eapply time_plus_tau_le_aux; eauto.
  Qed.

  Lemma time_plus_mu_tau_le :
    forall (t1 t2 : PosDTime) (n1 n2 : nat),
      n1 < S n2
      -> (t1 <= n1 * (mu + tau))%dtime
      -> ((S n2) * (mu + tau) < t2)%dtime
      -> (t1 + (mu + tau) <= t2)%dtime.
  Proof.
    introv w1 w2 w3.
    apply dt_lt_le_weak.
    eapply time_plus_mu_tau_lt; eauto.
  Qed.

  Lemma dt_mul_1_l :
    forall t, (dt_nat_inj 1 * t == t)%dtime.
  Proof.
    introv; simpl.
    rewrite eq_dt_1.
    apply (Rmul_1_l dt_ring).
  Qed.

  Lemma dt_add_0_l :
    forall t, (dt_nat_inj 0 + t == t)%dtime.
  Proof.
    introv; simpl.
    rewrite eq_dt_0.
    apply (Radd_0_l dt_ring).
  Qed.

  Lemma dt_mul_le_r :
    forall x y z, (0 < z)%dtime -> (x * z <= y * z)%dtime <-> (x <= y)%dtime.
  Proof.
    introv gt0; split; intro h.

    { eapply dt_mul_le_r_le;eauto.
      rewrite <- eq_dt_0; auto. }

    { apply dt_mul_le_compat_r; auto.
      apply dt_lt_le_weak.
      rewrite <- eq_dt_0; auto. }
  Qed.

  Lemma lt_0_twice_implies_lt_prod :
    forall a b,
      (nat2pdt 0 < a)%dtime
      -> (nat2pdt 0 < b)%dtime
      -> (nat2pdt 0 < a * b)%dtime.
  Proof.
    introv H1 H2.
    pose proof (dt_mul_lt_compat_r (nat2pdt 0) a b) as xx.
    repeat (autodimp xx hyp);[rewrite <- eq_dt_0; eauto |].
    pose proof (dt_mul_0_l b) as yy.
    rewrite <- eq_dt_0 in yy. simpl in *.
    rewrite yy in xx. clear yy.
    eauto.
  Qed.
  Hint Resolve lt_0_twice_implies_lt_prod : dtime.

  Lemma lt_implies_trans :
    forall a b c d,
      a < b
      -> (dt_0 < c)%dtime
      -> (d <= nat2pdt(S a) * c)%dtime
      -> (d <= nat2pdt(S b) * c)%dtime.
  Proof.
    introv h1 h2 h3.
    eapply dt_lt_le_weak.

    assert (nat2pdt(S a) < nat2pdt(S b))%dtime as temp1
        by (eapply lt_n_S in h1; eapply dt_nat_nat_inj_lt; eauto).

    pose proof(dt_mul_lt_compat_r (nat2pdt(S a)) (nat2pdt(S b)) c) as xx.
    repeat(autodimp xx hyp). clear temp1.

    eapply dt_le_lt_trans in h3; eauto.
  Qed.
  Hint Resolve lt_implies_trans : dtime.

  Lemma S_dt_T_mul :
    forall a b,
      ((dt_nat_inj (S a)) * b == ((dt_nat_inj a) * b) + b)%dtime.
  Proof.
    introv.
    assert (S a = a + 1) as xx by omega.
    rewrite xx; clear xx.
    rewrite <- dt_nat_inj_add_dist.
    pose proof (Rdistr_l dt_ring (dt_nat_inj a) (dt_nat_inj 1) b) as xx.
    rewrite xx; clear xx.
    apply dt_add_ext; try reflexivity.
    rewrite dt_mul_1_l; try reflexivity.
  Qed.

End DTime.

(* What's up with dt_lt_rel? *)
Existing Instances dt_eq_rel dt_le_rel (*dt_lt_rel*).

Hint Resolve mu_plus_tau_pos : dtime.
Hint Resolve mu_plus_tau_ge_0 : dtime.
Hint Resolve mu_plus_tau_pos2 : dtime.
Hint Resolve mu_plus_tau_ge_dt0 : dtime.
Hint Resolve lt_0_twice_implies_lt_prod : dtime.
Hint Resolve lt_implies_trans : dtime.

Delimit Scope dtime with dtime.
Open Scope dtime.
Infix "<"  := dt_lt  (at level 70) : dtime.
Infix "<=" := dt_le  (at level 70) : dtime.
Infix "+"  := dt_add : dtime.
Infix "-"  := dt_sub : dtime.
Infix "*"  := dt_mul : dtime.
Infix "==" := dt_eq  (at level 70) : dtime.
Notation "a <= b <= c" := ((a <= b) /\ (b <= c)) : dtime.
Close Scope dtime.


Require Export XR_frac_part.
Require Export XR_Ropp_le_contravar.
Require Export XR_up_tech.
Require Export XR_IZR_eq.
Require Export XR_Rplus_lt_le_compat.

Local Open Scope R_scope.

Lemma Rminus_Int_part1 : forall r1 r2:R,
  frac_part r2 <= frac_part r1 ->
  Int_part (r1 - r2) = (Int_part r1 - Int_part r2)%Z.
Proof.
  intros x y.
  unfold frac_part.
  unfold Int_part.
  intro h.
  set (u:=up(x-y)).
  apply eq_IZR.
  repeat rewrite minus_IZR.
  repeat rewrite minus_IZR in h.
  simpl.
  unfold Rminus.
  rewrite Ropp_plus_distr.
  rewrite Ropp_involutive.
  repeat rewrite Rplus_assoc.
  rewrite (Rplus_comm (-R1)).
  repeat rewrite Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_r.
  unfold Rminus in h.
  repeat rewrite Ropp_plus_distr in h.
  repeat rewrite Ropp_involutive in h.
  repeat rewrite <- Rplus_assoc in h.
  apply Rplus_le_reg_r in h.
  apply Rplus_eq_reg_r with R1.
  rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r.
  apply Ropp_le_contravar in h.
  repeat rewrite Ropp_plus_distr in h.
  repeat rewrite Ropp_involutive in h.
  rewrite (Rplus_comm (-x)) in h.
  rewrite (Rplus_comm (-y)) in h.

  assert (hax:=archimed x).
  assert (hay:=archimed y).

  destruct hax as [ haxl haxr ].
  destruct hay as [ hayl hayr ].

  assert (ut:=up_tech).

  specialize (ut (x-y)).
  symmetry.

  change R1 with (IZR 1).
  rewrite <- opp_IZR.
  repeat rewrite <- plus_IZR.
  apply IZR_eq.
  fold u in ut.

  specialize (ut (up x - up y))%Z.
  apply ut.

  {
    rewrite minus_IZR.
    apply Rplus_le_reg_r with (-x).
    unfold Rminus.
    repeat rewrite Rplus_assoc.
    rewrite (Rplus_comm x).
    repeat rewrite Rplus_assoc.
    rewrite Rplus_opp_l.
    rewrite Rplus_0_r.
    apply Rplus_le_reg_r with (IZR (up y)).
    repeat rewrite Rplus_assoc.
    rewrite (Rplus_comm (- IZR (up y))).
    repeat rewrite Rplus_assoc.
    rewrite Rplus_opp_r.
    rewrite Rplus_0_r.
    rewrite (Rplus_comm (-y)).
    exact h.
  }
  {
    rewrite plus_IZR.
    rewrite minus_IZR.
    unfold Rminus.
    repeat rewrite Rplus_assoc.
    apply Rplus_lt_le_compat.
    { exact haxl. }
    {
      apply Rplus_le_reg_l with (IZR (up y)).
      repeat rewrite <- Rplus_assoc.
      rewrite Rplus_opp_r.
      rewrite Rplus_0_l.
      unfold Rminus in hayr.
      exact hayr.
    }
  }
Qed.


Require Import Rupicola.Lib.Api.

Section Tree.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Notation address := word.

  Inductive annotation :=
  | Borrowed (a: address)
  | Reserved (a: address)
  | Owned.

  Notation Annotated alpha := (annotation * alpha)%type.

  Inductive tree {alpha : Type} :=
  | Empty : tree
  | Node : alpha -> tree -> tree -> tree.

  Arguments tree : clear implicits.

  Section defs.
    Context {alpha : Type}.

    Fixpoint owned (t : tree alpha)
      : tree (Annotated alpha) :=
      match t with
      | Empty => Empty
      | Node a l r => Node (Owned, a) (owned l) (owned r)
      end.

    Definition setRoot (t : tree alpha) (a : alpha)
      : tree alpha :=
      match t with
      | Empty => Empty
      | Node _ l r => Node a l r
      end.

    Fixpoint lookup
             (t : tree alpha)
             (cond : alpha -> bool)
      : option alpha :=
      match t with
      | Empty => None
      | Node a l r =>
        if cond a then Some a
        else match lookup l cond with
             | Some a => Some a
             | None => lookup r cond
             end
      end.

    Fixpoint replace
             (t : tree alpha)
             (cond : alpha -> bool)
             (a' : alpha)
      : tree alpha * bool :=
      match t with
      | Empty => (t, false)
      | Node a l r =>
        if cond a then (Node a' l r, true)
        else match replace l cond a' with
             | (l', true) => (Node a l' r, true)
             | (_, false) =>
               match replace r cond a' with
               | (r', true) => (Node a l r', true)
               | (_,false) => (Node a l r, false)
               end
             end
      end.

    Section sep.
      Context {Alpha : word -> alpha -> mem -> Prop}
              {word_size_in_bytes : Z}.

      Local Notation word_offset :=
        (word.of_Z word_size_in_bytes).

      Definition AnnotatedAlpha
                 (addr : word)
                 (x : Annotated alpha)
        : mem -> Prop :=
        match x with
        | (Borrowed p, _) => emp (addr = p)
        | (Reserved p, a) => sep (Alpha addr a) (emp (addr = p))
        | (Owned, a) => Alpha addr a
        end.

      Fixpoint Tree
               (addr : word)
               (t : tree (Annotated alpha))
        : mem -> Prop :=
        match t with
        | Empty => emp (addr = word.of_Z 0)
        | Node a r l =>
          let laddr := word.add addr word_offset in
          let raddr := word.add laddr word_offset in
          sep (AnnotatedAlpha addr a)
              (sep (Tree laddr l) (Tree raddr r))
        end.
    End sep.
  End defs.

  Section proofs.
    Context {alpha : Type}.
    Lemma owned_setRoot_comm t (a : alpha) :
      setRoot (owned t) (Owned, a) = owned (setRoot t a).
    Proof. destruct t; reflexivity. Qed.

    Definition lift {T} (f : alpha -> T) (x : Annotated alpha) :=
      f (snd x).

    Lemma owned_replace_comm t cond (a : alpha) :
      replace (owned t) (lift cond) (Owned, a)
      = (owned (fst (replace t cond a)),
         snd (replace t cond a)).
    Proof.
      induction t; cbn [replace owned];
        try reflexivity.
      repeat match goal with
             | _ => progress subst
             | _ => progress unfold lift in *
             | _ => progress cbn [owned fst snd] in *
             | H : (_,_) = (_,_) |- _ =>
               inversion H; clear H
             | |- context [match ?x with _ => _ end] =>
               destruct x eqn:?
             | _ => reflexivity
             end.
    Qed.

    Section sep.
      Context
        {word_ok : word.ok word} {mem_ok : map.ok mem}
        {locals_ok : map.ok locals}
        {env_ok : map.ok env}
        {ext_spec_ok : Semantics.ext_spec.ok ext_spec}
        {Alpha : word -> alpha -> mem -> Prop}
        {word_size_in_bytes : Z}.

      Local Notation word_offset :=
        (word.of_Z word_size_in_bytes).
      Local Notation Tree :=
        (@Tree _ Alpha word_size_in_bytes).

      Lemma lookup_replace t cond :
        forall a olda pt pa R mem,
          sep (sep (Tree pt t) (Alpha pa a)) R mem ->
          lookup t cond = Some (Borrowed pa, olda) ->
          sep (Tree pt (fst (replace t cond (Owned, a)))) R mem.
      Proof.
        induction t; intros;
          repeat match goal with
                 | _ => progress subst
                 | _ => progress cbn in *
                 | H : Some _ = Some _ |- _ =>
                   inversion H; clear H
                 | H : context [match ?x with _ => _ end] |- _ =>
                   destruct x eqn:?
                 | |- context [match ?x with _ => _ end] =>
                   destruct x eqn:?
                 | H : sep (sep (sep _ _) _) _ _ |- _ =>
                   apply sep_assoc in H; progress sepsimpl
                 | _ => congruence
                 | _ => ecancel_assumption
                 end.
        1: use_sep_assumption; cancel.
        2: exfalso.
        3: exfalso.
        4: exfalso.
        5: use_sep_assumption; cancel.
        6: exfalso.
      Abort.
    End sep.

    Lemma replace_replace t cond (a1 a2 : alpha) :
      cond a1 = true ->
      replace (fst (replace t cond a1)) cond a2 =
      replace t cond a2.
    Proof.
      (* induction t; intros; *)
      (*   repeat match goal with *)
      (*          | _ => progress cbn [replace fst snd] in * *)
      (*          | _ => progress subst *)
      (*          | _ => progress intuition *)
      (*          | H : (_,_) = (_,_) |- _ => *)
      (*            inversion H; clear H *)
      (*          | |- context [match ?x with _ => _ end] => *)
      (*            destruct x eqn:? *)
      (*          | _ => reflexivity *)
      (*          | _ => congruence *)
      (*          end. *)
    Abort.

    Section borrowing.
      Context {Alpha : word -> alpha -> mem -> Prop}
              {word_size_in_bytes : Z}.

      Open Scope nat_scope.
      Definition a (n: nat) := n + 1.
      Definition b (n: nat) := a n + 1.
      Definition c (n: nat) := b n + 1.

      Hint Unfold a : test.
      Hint Unfold b : test.
      Hint Unfold c : test.

      (* Goal c 3 = 5. *)
      (*   autounfold with test. *)

      (* Lemma borrow_reserved : *)
      (*   forall addr t cond pa a, *)
      (*     find t (lift cond) = Some (Reserved pa, a) -> *)
      (*     Tree (Alpha := Alpha) addr t -> *)
      (*     sep (Alpha a) (Tree addr (replace t (lift cond) (Borrowed pa, a))). *)
      (* Abort. *)

      (* Lemma owned_replace_comm t cond (a : alpha) : *)
      (*   replace (owned t) (lift cond) (Owned, a) *)
      (*   = (owned (fst (replace t cond a)), *)
      (*       snd (replace t cond a)). *)
      (* Abort. *)
    End borrowing.
  End proofs.
End Tree.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils.

Set Implicit Arguments.

Set Default Proof Using "Type".

Reserved Notation " e '⇢' x " (at level 58).
Reserved Notation " e [ v / x ] " (at level 57, v at level 0, x at level 0,
                                   left associativity, format "e [ v / x ]").
Reserved Notation " e ⦃  x '⇠' v ⦄ " (at level 57, v at level 0, x at level 0, left associativity).

Section env.

  Variable (X Y : Type) (X_eq_dec : eqdec X) (Y_default : Y).

  Definition env := X -> Y.

  Implicit Type e : env.

  Definition get_env e x := e x.

  Definition set_env e x v : env := fun y => if X_eq_dec x y then v else e y.

  Definition nil_env : env := fun _ => Y_default.

  Fact get_set_env_eq e v p q : p = q -> get_env (set_env e p v) q = v.
  Proof. intros []; unfold set_env, get_env; destruct (X_eq_dec p p) as [ | [] ]; auto. Qed.

  Fact get_set_env_neq e v p q : p <> q -> get_env (set_env e p v) q = get_env e q.
  Proof. simpl; intros H; unfold set_env, get_env; destruct (X_eq_dec p q); auto; destruct H; auto. Qed.

End env.

Arguments nil_env {X}.

Opaque get_env.
Opaque set_env.

Local Notation " e ⇢ x " := (@get_env _ _ e x).
Local Notation " e ⦃  x ⇠ v ⦄ " := (@set_env _ _ _ e x v).

(* find the value of x inside the environment t *)

Ltac find_val x t :=
  match t with
    | ?s⦃x⇠?v⦄ => v
    | ?s⦃_⇠_⦄ => find_val x s
  end.

Tactic Notation "rew" "env" :=
  repeat once lazymatch goal with
    |              |- context[ _⦃ ?x⇠_⦄⇢?x ] => rewrite get_set_env_eq  with (1 := eq_refl x)
    | _ : ?x = ?y  |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_eq  with (p := x) (q := y)
    | _ : ?y = ?x  |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_eq  with (p := x) (q := y)
    | _ : ?x <> ?y |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y)
    | _ : ?y <> ?x |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y)
    |              |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y);
                                                  [ | discriminate ]
  end; auto.

(*
Tactic Notation "rew" "envi" :=
  repeat once lazymatch goal with
    | |- context f[ _[_/?l]#>?l ] => rewrite get_set_env_eq with (x := l)
    | _ : ?l <> ?m |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m)
    | _ : ?m <> ?l |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m)
    | |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m); [ | discriminate ]
  end; auto.
*)

Tactic Notation "rew" "env" "in" hyp(H) := revert H; rew env; intros H.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** %\subsection*{ support :  omit.v }%*)
(** - (omit v i) = $\langle v_0...v_{i-1},v_{i+1}...v_{n-1}\rangle$ *)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export empty.
Require Export conshdtl.

(** %\label{omit}% *)
Definition omit :
  forall (A : Setoid) (n : Nat), seq n A -> fin n -> seq (pred n) A.
destruct n.
auto.
induction  n as [| n Hrecn].
intros.
apply (empty_seq A).
intros.
case X0.
intro x; case x.
intro.
exact (Seqtl X).
intros.
exact (head X;; Hrecn (Seqtl X) (Build_finiteT (lt_S_n _ _ in_range_prf))).
Defined.

Lemma omit_comp :
 forall (A : Setoid) (n : Nat) (v v' : seq n A) (i i' : fin n),
 v =' v' in _ -> i =' i' in _ -> omit v i =' omit v' i' in _.
destruct n.
intros.
auto with algebra.
induction  n as [| n Hrecn].
intros.
unfold omit in |- *.
unfold nat_rect in |- *.
auto with algebra.
intros v v' i.
case i.
intros x l i'.
case i'.
intros.
apply Trans with (omit v' (Build_finiteT l)).
unfold omit in |- *.
unfold nat_rect in |- *.
generalize l H0; clear H0 l.
destruct x as [| n0].
intros.
change (Seqtl v =' Seqtl v' in _) in |- *.
apply Seqtl_comp; auto with algebra.
intros.
simpl in |- *.
apply cons_comp; auto with algebra.
unfold omit in Hrecn.
unfold nat_rect in Hrecn.
apply Hrecn.
change (Seqtl v =' Seqtl v' in _) in |- *.
apply Seqtl_comp; auto with algebra.
auto with algebra.
unfold omit in |- *.
unfold nat_rect in |- *.
generalize l H0; clear H0 l.
destruct x as [| n0].
destruct index as [| n0].
intros; auto with algebra.
intros.
simpl in H0.
inversion H0.
intros.
generalize l H0; clear H0 l.
destruct index as [| n1].
intros.
simpl in H0.
inversion H0.
intros.
simpl in |- *.
apply cons_comp; auto with algebra.
unfold omit in Hrecn.
unfold nat_rect in Hrecn.
apply Hrecn; auto with algebra.
Qed.

Hint Resolve omit_comp: algebra.

(** - The following are actually definitions. omit_removes does the following:
 suppose v:(seq n A) and i:(fin n). Define w:=(omit v i). Then given j, (w j)
 = (v j') for some j'. Omit_removes returns this j' and a proof of this fact
 (packed together in a sigma-type). *)

Lemma omit_removes :
 forall (n : Nat) (A : Setoid) (v : seq n A) (i : fin n) (j : fin (pred n)),
 sigT (fun i' => v i' =' omit v i j in _).
destruct n.
intros.
apply False_rect; auto with algebra.

intros.
generalize (j:fin n).
clear j.
intro j.

induction  n as [| n Hrecn].
apply False_rect.
apply fin_O_nonexistent; auto with algebra.

case i.
intro x; case x.
intros.
set (l := in_range_prf) in *.
case j.
intros.
set (l0 := in_range_prf0) in *.
apply
 (existT
    (fun i' : fin (S (S n)) =>
     Ap v i' =' omit v (Build_finiteT l) (Build_finiteT l0) in _)
    (Build_finiteT (lt_n_S _ _ l0))).
apply Trans with (Seqtl v (Build_finiteT l0)); auto with algebra.

intros.
rename in_range_prf into l.
case j.
intro x0; case x0.
intro l0.
apply
 (existT
    (fun i' : fin (S (S n)) =>
     Ap v i' =' Ap (omit v (Build_finiteT l)) (Build_finiteT l0) in _)
    (Build_finiteT (lt_O_Sn (S n)))).
apply Trans with (head (omit v (Build_finiteT l))); auto with algebra.

intros.
rename in_range_prf into l0.
generalize
 (Hrecn (Seqtl v) (Build_finiteT (lt_S_n _ _ l))
    (Build_finiteT (lt_S_n _ _ l0))).
intro.
inversion_clear X.
generalize H.
clear H.
case x1.
intros.
apply
 (existT
    (fun i' : fin (S (S n)) =>
     Ap v i' =' Ap (omit v (Build_finiteT l)) (Build_finiteT l0) in _)
    (Build_finiteT (lt_n_S _ _ in_range_prf))).
apply
 Trans
  with
    ((head v;; omit (Seqtl v) (Build_finiteT (lt_S_n _ _ l)))
       (Build_finiteT l0)); auto with algebra.
Defined.

(** - omit_removes' on the other hand does this: suppose again v:(seq n A) and i:(fin n)
 and define w:=(omit v i). Suppose that this time j:(fin n). If [~i='j] then (v j)='(w j')
 for some j'; again omit_removes' returns this j' and a proof. *)

Lemma omit_removes' :
 forall (n : Nat) (A : Setoid) (v : seq n A) (i j : fin n),
 ~ i =' j in _ -> sigT (fun j' => v j =' omit v i j' in _).
destruct n.
intros.
apply False_rect; auto with algebra.

induction  n as [| n Hrecn].
intros.
absurd (i =' j in _).
auto.
apply fin_S_O_unique; auto with algebra.
intros A v i.
elim i.
intro i'; case i'.
intros Hi j.
elim j.
intro j'; case j'.
intros.
simpl in H.
absurd (0 = 0); auto.
intros n0 p0 H.
exists (Build_finiteT (lt_S_n _ _ p0)).
simpl in |- *.
apply Ap_comp; auto with algebra.
simpl in |- *.
auto.

intros gat Hg vraag.
elim vraag.
intro vr; case vr.
intros Hvr H.
exists (Build_finiteT (lt_O_Sn n)).
simpl in |- *.
unfold head in |- *.
apply Ap_comp; auto with algebra.
simpl in |- *.
auto.

intros vr' Hvr H.
assert
 (~ Build_finiteT (lt_S_n _ _ Hg) =' Build_finiteT (lt_S_n _ _ Hvr) in fin _).
simpl in |- *; simpl in H; auto.
set (aw := Hrecn _ (Seqtl v) _ _ H0) in *.
case aw.
intro x; elim x.
intros.
exists (Build_finiteT (lt_n_S _ _ in_range_prf)).
apply Trans with (Seqtl v (Build_finiteT (lt_S_n vr' (S n) Hvr))).
apply Sym.
apply Seqtl_to_seq; auto with algebra.
apply
 Trans
  with
    (omit (Seqtl v) (Build_finiteT (lt_S_n gat (S n) Hg))
       (Build_finiteT in_range_prf)); auto with algebra.
Defined.


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

Ralph Matthes

2022
*)

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

Contents :

- defines a notion of binary products for displayed categories that gives binary products on its total category
- same programme for terminal objects

 ************************************************************)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Local Open Scope cat.
Local Open Scope mor_disp.

Section FixDispCat.

  Context {C : category} (D : disp_cat C).

  Definition is_dispBinProduct_naive (c d p : C) (p1 : p --> c) (p2 : p --> d) (cc : D c)
    (dd : D d) (pp : D p) (pp1 : pp -->[p1] cc) (pp2 : pp -->[p2] dd) : UU :=
    ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd),
      ∃! (fg : a --> p) (fgfg : aa -->[fg] pp),
      ∑ fgok : ((fg · p1 = f) × (fg · p2 = g)),
        (fgfg ;; pp1 = transportb _ (pr1 fgok) ff) × (fgfg ;; pp2 = transportb _ (pr2 fgok) gg).

  Definition is_dispBinProduct (c d : C) (P : BinProduct C c d)
    (cc : D c) (dd : D d) (pp : D (BinProductObject _ P))
    (pp1 : pp -->[BinProductPr1 _ P] cc) (pp2 : pp -->[BinProductPr2 _ P] dd) : UU :=
    ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd),
      ∃! (fgfg : aa -->[BinProductArrow _ P f g] pp),
      (fgfg ;; pp1 = transportb _ (BinProductPr1Commutes _ _ _ P _ f g) ff) ×
      (fgfg ;; pp2 = transportb _ (BinProductPr2Commutes _ _ _ P _ f g) gg).

  Definition dispBinProduct (c d : C) (P : BinProduct C c d) (cc : D c) (dd : D d) : UU :=
    ∑ pppp1pp2 : (∑ pp : D (BinProductObject _ P),
                     (pp -->[BinProductPr1 _ P] cc) × (pp -->[BinProductPr2 _ P] dd)),
        is_dispBinProduct c d P cc dd (pr1 pppp1pp2) (pr1 (pr2 pppp1pp2)) (pr2 (pr2 pppp1pp2)).

  Definition dispBinProductObject {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d}
    (dP : dispBinProduct c d P cc dd) : D (BinProductObject _ P) := pr1 (pr1 dP).

  Definition dispBinProductPr1 {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d}
    (dP : dispBinProduct c d P cc dd) : dispBinProductObject P dP -->[BinProductPr1 _ P] cc :=
    pr1 (pr2 (pr1 dP)).

  Definition dispBinProductPr2 {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d}
    (dP : dispBinProduct c d P cc dd) : dispBinProductObject P dP -->[BinProductPr2 _ P] dd :=
    pr2 (pr2 (pr1 dP)).

  Definition is_dispBinProduct_dispBinProduct {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d}
    (dP : dispBinProduct c d P cc dd) :
    is_dispBinProduct c d P cc dd (dispBinProductObject P dP) (dispBinProductPr1 P dP) (dispBinProductPr2 P dP).
  Proof.
    exact (pr2 dP).
  Defined.

  Definition dispBinProductArrow {c d : C} (P : BinProduct C c d) {cc : D c} {dd : D d}
    (dP : dispBinProduct c d P cc dd) {a : C} {f : a --> c} {g : a --> d} {aa : D a} (ff : aa -->[f] cc) (gg : aa -->[g] dd) :
       aa -->[BinProductArrow _ P f g] dispBinProductObject P dP.
  Proof.
    exact (pr1 (pr1 (is_dispBinProduct_dispBinProduct P dP _ _ _ _ ff gg))).
  Defined.

  Lemma dispBinProductPr1Commutes {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d) (dP : dispBinProduct c d P cc dd):
    ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd),
      dispBinProductArrow P dP ff gg ;; dispBinProductPr1 P dP = transportb _ (BinProductPr1Commutes _ _ _ P _ f g) ff.
  Proof.
    intros a f g aa ff gg.
    exact (pr1 (pr2 (pr1 (is_dispBinProduct_dispBinProduct P dP _ _ _ _ ff gg)))).
  Qed.

  Lemma dispBinProductPr2Commutes {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d) (dP : dispBinProduct c d P cc dd):
    ∏ (a : C) (f : a --> c) (g : a --> d) (aa : D a) (ff : aa -->[f] cc) (gg : aa -->[g] dd),
      dispBinProductArrow P dP ff gg ;; dispBinProductPr2 P dP = transportb _ (BinProductPr2Commutes _ _ _ P _ f g) gg.
  Proof.
    intros a f g aa ff gg.
    exact (pr2 (pr2 (pr1 (is_dispBinProduct_dispBinProduct P dP _ _ _ _ ff gg)))).
  Qed.

  Lemma dispBinProductArrowUnique  {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d)
    (dP : dispBinProduct c d P cc dd) {x : C} (xx : D x) (f : x --> c) (g : x --> d) (ff : xx -->[f] cc) (gg : xx -->[g] dd)
    (kk : xx -->[BinProductArrow _ P f g] dispBinProductObject P dP) :
    kk ;; dispBinProductPr1 P dP = transportb _ (BinProductPr1Commutes _ _ _ P _ f g) ff ->
    kk ;; dispBinProductPr2 P dP = transportb _ (BinProductPr2Commutes _ _ _ P _ f g) gg ->
    kk = dispBinProductArrow P dP ff gg.
  Proof.
    intros H1 H2.
    apply path_to_ctr; split; assumption.
  Qed.

  (* transparent proofs for the standard binary products -- upstream?
  Definition BinProductArrowUnique' (c d : C) (P : BinProduct C c d) (x : C)
    (f : x --> c) (g : x --> d) (k : x --> BinProductObject C P) :
    k · BinProductPr1 C P = f -> k · BinProductPr2 C P = g ->
    k = BinProductArrow C P f g.
  Proof.
    intros; apply path_to_ctr; split; assumption.
  Defined.

  Definition BinProductArrowEta' (c d : C) (P : BinProduct C c d) (x : C)
    (f : x --> BinProductObject C P) :
    f = BinProductArrow C P (f · BinProductPr1 C P) (f · BinProductPr2 C P).
  Proof.
    apply BinProductArrowUnique'; apply idpath.
  Defined.
*)

  Lemma dispBinProductArrowEta {c d : C} (P : BinProduct C c d) (cc : D c) (dd : D d)
    (dP : dispBinProduct c d P cc dd) {x : C} (xx : D x) {fg : x --> BinProductObject C P }
    (fgfg : xx -->[ fg] dispBinProductObject P dP) :
    fgfg =
      transportb (mor_disp xx (dispBinProductObject P dP)) (BinProductArrowEta C c d P x fg)
        (dispBinProductArrow P dP (fgfg ;; dispBinProductPr1 P dP) (fgfg ;; dispBinProductPr2 P dP)).
  Proof.
    apply transportf_transpose_right.
    apply dispBinProductArrowUnique.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      unfold transportb.
      apply (maponpaths (fun z => transportf (mor_disp xx cc) z (fgfg ;; dispBinProductPr1 P dP))).
      apply C.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      unfold transportb.
      apply (maponpaths (fun z => transportf (mor_disp xx dd) z (fgfg ;; dispBinProductPr2 P dP))).
      apply C.
  Qed.

  Lemma dispBinProduct_endo_is_identity {a b : C} (aa : D a) (bb : D b)
    (P : BinProduct _ a b) (dP : dispBinProduct a b P aa bb)
    {k : BinProductObject _ P --> BinProductObject _ P} (kk: dispBinProductObject P dP -->[k] dispBinProductObject P dP)
    (H1 : k · BinProductPr1 _ P = BinProductPr1 _ P) (dH1 : kk ;; dispBinProductPr1 P dP = transportb _ H1 (dispBinProductPr1 P dP))
    (H2 : k · BinProductPr2 _ P = BinProductPr2 _ P) (dH2 : kk ;; dispBinProductPr2 P dP = transportb _ H2 (dispBinProductPr2 P dP))
    : transportf _ (BinProduct_endo_is_identity C a b P k H1 H2) (id_disp (dispBinProductObject P dP)) = kk.
  Proof.
    apply pathsinv0.
    etrans.
    { apply dispBinProductArrowEta. }
    apply pathsinv0, transportf_comp_lemma.
    apply dispBinProductArrowUnique.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite id_left_disp.
      rewrite transport_f_b.
      apply transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0; exact dH1. }
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite id_left_disp.
      rewrite transport_f_b.
      apply transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0; exact dH2. }
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
  Qed.

  Definition dispBinProductOfArrows {c d : C} {Pcd : BinProduct C c d}
    {cc : D c} {dd : D d}
    (dPcd : dispBinProduct c d Pcd cc dd)
    {a b : C} {Pab : BinProduct C a b}
    {aa : D a} {bb : D b}
    (dPab : dispBinProduct a b Pab aa bb)
    {f : a --> c} {g : b --> d}
    (ff : aa -->[f] cc) (gg : bb -->[g] dd)
    : dispBinProductObject Pab dPab -->[BinProductOfArrows C Pcd Pab f g] dispBinProductObject Pcd dPcd :=
    dispBinProductArrow Pcd dPcd (dispBinProductPr1 Pab dPab ;; ff) (dispBinProductPr2 Pab dPab ;; gg).

  Lemma dispBinProductOfArrowsPr1 {c d : C} {Pcd : BinProduct C c d}
    {cc : D c} {dd : D d}
    (dPcd : dispBinProduct c d Pcd cc dd)
    {a b : C} {Pab : BinProduct C a b}
    {aa : D a} {bb : D b}
    (dPab : dispBinProduct a b Pab aa bb)
    {f : a --> c} {g : b --> d}
    (ff : aa -->[f] cc) (gg : bb -->[g] dd) :
    dispBinProductOfArrows dPcd dPab ff gg ;; dispBinProductPr1 Pcd dPcd =
      transportb _ (BinProductOfArrowsPr1 _ Pcd Pab f g) (dispBinProductPr1 Pab dPab ;; ff).
  Proof.
    unfold dispBinProductOfArrows.
    etrans.
    { apply dispBinProductPr1Commutes. }
    apply (maponpaths (fun z => transportb (mor_disp (dispBinProductObject Pab dPab) cc) z (dispBinProductPr1 Pab dPab ;; ff))).
    apply C.
  Qed.

  Lemma dispBinProductOfArrowsPr2 {c d : C} {Pcd : BinProduct C c d}
    {cc : D c} {dd : D d}
    (dPcd : dispBinProduct c d Pcd cc dd)
    {a b : C} {Pab : BinProduct C a b}
    {aa : D a} {bb : D b}
    (dPab : dispBinProduct a b Pab aa bb)
    {f : a --> c} {g : b --> d}
    (ff : aa -->[f] cc) (gg : bb -->[g] dd) :
    dispBinProductOfArrows dPcd dPab ff gg ;; dispBinProductPr2 Pcd dPcd =
      transportb _ (BinProductOfArrowsPr2 _ Pcd Pab f g) (dispBinProductPr2 Pab dPab ;; gg).
  Proof.
    unfold dispBinProductOfArrows.
    etrans.
    { apply dispBinProductPr2Commutes. }
    apply (maponpaths (fun z => transportb (mor_disp (dispBinProductObject Pab dPab) dd) z (dispBinProductPr2 Pab dPab ;; gg))).
    apply C.
  Qed.

  Lemma dispPostcompWithBinProductArrow {c d : C} {Pcd : BinProduct C c d} {cc : D c} {dd : D d} (dPcd : dispBinProduct c d Pcd cc dd)
    {a b : C} {Pab : BinProduct C a b} {aa : D a} {bb : D b} (dPab : dispBinProduct a b Pab aa bb)
    {f : a --> c} {g : b --> d} (ff : aa -->[f] cc) (gg : bb -->[g] dd)
    {x : C} {xx : D x} {k : x --> a} {h : x --> b} (kk: xx -->[k] aa) (hh: xx -->[h] bb) :
    dispBinProductArrow Pab dPab kk hh ;; dispBinProductOfArrows dPcd dPab ff gg =
      transportb _ (postcompWithBinProductArrow C Pcd Pab f g k h) (dispBinProductArrow Pcd dPcd (kk ;; ff) (hh ;; gg)).
  Proof.
    apply transportb_transpose_right.
    apply dispBinProductArrowUnique.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite assoc_disp_var.
      rewrite dispBinProductOfArrowsPr1.
      rewrite transport_f_f.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_prewhisker. }
      rewrite assoc_disp.
      rewrite dispBinProductPr1Commutes.
      rewrite transport_f_b.
      apply transportf_comp_lemma.
      unfold transportb.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_postwhisker. }
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite assoc_disp_var.
      rewrite dispBinProductOfArrowsPr2.
      rewrite transport_f_f.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_prewhisker. }
      rewrite assoc_disp.
      rewrite dispBinProductPr2Commutes.
      rewrite transport_f_b.
      apply transportf_comp_lemma.
      unfold transportb.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_postwhisker. }
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
  Qed.

  Lemma dispPrecompWithBinProductArrow {c d : C} {Pcd : BinProduct C c d}
    {cc : D c} {dd : D d} (dPcd : dispBinProduct c d Pcd cc dd)
    {a : C} {aa : D a}
    {f : a --> c} {g : a --> d} (ff: aa -->[f] cc) (gg: aa -->[g] dd)
    {x : C} {xx : D x} {k : x --> a} (kk: xx -->[k] aa) :
    kk ;; dispBinProductArrow Pcd dPcd ff gg  =
      transportb _ (precompWithBinProductArrow C Pcd f g k) (dispBinProductArrow Pcd dPcd (kk ;; ff) (kk ;; gg)).
  Proof.
    apply transportb_transpose_right.
    apply dispBinProductArrowUnique.
    - rewrite mor_disp_transportf_postwhisker.
      rewrite assoc_disp_var.
      rewrite dispBinProductPr1Commutes.
      rewrite transport_f_f.
      etrans.
      { apply maponpaths.
        apply mor_disp_transportf_prewhisker. }
      rewrite transport_f_f.
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
    - rewrite mor_disp_transportf_postwhisker.
      rewrite assoc_disp_var.
      rewrite dispBinProductPr2Commutes.
      rewrite transport_f_f.
      etrans.
      { apply maponpaths.
        apply mor_disp_transportf_prewhisker. }
      rewrite transport_f_f.
      apply transportf_comp_lemma.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
  Qed.

  Definition dispBinProducts (Ps : BinProducts C)  : UU := ∏ (c d : C) (cc : D c) (dd : D d),
      dispBinProduct c d (Ps c d) cc dd.

  Lemma dispBinProductOfArrows_comp { Ps : BinProducts C } (dPs : dispBinProducts Ps) {a b c d x y : C}
    {aa : D a} {bb : D b} {cc : D c} {dd: D d} {xx : D x} {yy : D y}
    {f : a --> c} {f' : b --> d} {g : c --> x} {g' : d --> y}
    (ff : aa -->[f] cc) (ff' : bb -->[f'] dd) (gg : cc -->[g] xx) (gg' : dd -->[g'] yy) :
    dispBinProductOfArrows (dPs _ _ _ _) (dPs _ _ _ _) ff ff' ;; dispBinProductOfArrows (dPs _ _ _ _) (dPs _ _ _ _) gg gg' =
      transportb _ (BinProductOfArrows_comp _ _ _ _ _ _ _ _ f f' g g') (dispBinProductOfArrows (dPs _ _ _ _) (dPs _ _ _ _) (ff;;gg) (ff';;gg')).
  Proof.
    apply transportb_transpose_right.
    apply dispBinProductArrowUnique.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite assoc_disp_var.
      rewrite dispBinProductOfArrowsPr1.
      rewrite transport_f_f.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_prewhisker. }
      do 2 rewrite assoc_disp.
      rewrite dispBinProductOfArrowsPr1.
      do 2 rewrite transport_f_b.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      { apply maponpaths.
        apply mor_disp_transportf_postwhisker. }
      rewrite transport_f_f.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
    - etrans.
      { apply mor_disp_transportf_postwhisker. }
      rewrite assoc_disp_var.
      rewrite dispBinProductOfArrowsPr2.
      rewrite transport_f_f.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      2: { apply pathsinv0, mor_disp_transportf_prewhisker. }
      do 2 rewrite assoc_disp.
      rewrite dispBinProductOfArrowsPr2.
      do 2 rewrite transport_f_b.
      apply pathsinv0, transportf_comp_lemma.
      etrans.
      { apply maponpaths.
        apply mor_disp_transportf_postwhisker. }
      rewrite transport_f_f.
      apply transportf_comp_lemma_hset;
        try apply homset_property; apply idpath.
  Qed.

  Definition total_category_Binproducts_data (Ps : BinProducts C) (dPs : dispBinProducts Ps) (ccc ddd : total_category D) :
    ∑ p : total_category D, total_category D ⟦ p, ccc ⟧ × total_category D ⟦ p, ddd ⟧.
  Proof.
    induction ccc as [c cc].
    induction ddd as [d dd].
    - exists (BinProductObject _ (Ps c d) ,, dispBinProductObject (Ps c d) (dPs c d cc dd)).
      split.
      + use tpair.
        * apply BinProductPr1.
        * apply dispBinProductPr1.
      + use tpair.
        * apply BinProductPr2.
        * apply dispBinProductPr2.
  Defined.

  Definition total_category_Binproducts_mediating_morphism (Ps : BinProducts C) (dPs : dispBinProducts Ps)
    {c d x : C} {cc : D c} {dd: D d} {xx : D x} {f : x --> c} (ff: xx -->[f] cc) {g : x --> d} (gg: xx -->[g] dd) :
     ∑ h : x --> BinProductObject C (Ps c d), xx -->[h] dispBinProductObject (Ps c d) (dPs c d cc dd).
  Proof.
    use tpair.
    - apply BinProductArrow; assumption.
    - apply dispBinProductArrow; assumption.
  Defined.

  Local Lemma total_category_Binproducts_mediating_morphism_ok (Ps : BinProducts C) (dPs : dispBinProducts Ps)
    {c d x : C} {cc : D c} {dd: D d} {xx : D x} {f : x --> c} (ff: xx -->[f] cc) {g : x --> d} (gg: xx -->[g] dd) :
    BinProductArrow C (Ps c d) f g · BinProductPr1 C (Ps c d),, dispBinProductArrow (Ps c d) (dPs c d cc dd) ff gg ;; dispBinProductPr1 (Ps c d) (dPs c d cc dd) = f,, ff ×
    BinProductArrow C (Ps c d) f g · BinProductPr2 C (Ps c d),, dispBinProductArrow (Ps c d) (dPs c d cc dd) ff gg ;; dispBinProductPr2 (Ps c d) (dPs c d cc dd) = g,, gg.
  Proof.
    split.
    - use total2_paths_f; cbn.
      + apply BinProductPr1Commutes.
      + apply transportf_pathsinv0.
        apply pathsinv0.
        apply dispBinProductPr1Commutes.
    - use total2_paths_f; cbn.
      + apply BinProductPr2Commutes.
      + apply transportf_pathsinv0.
        apply pathsinv0.
        apply dispBinProductPr2Commutes.
  Qed.

  Local Lemma total_category_Binproducts_mediating_morphism_unique (Ps : BinProducts C) (dPs : dispBinProducts Ps)
    {c d x : C} {cc : D c} {dd: D d} {xx : D x} {f : x --> c} (ff: xx -->[f] cc) {g : x --> d} (gg: xx -->[g] dd)
    {fg : x --> BinProductObject C (Ps c d)} (fgfg : xx -->[fg] dispBinProductObject (Ps c d) (dPs c d cc dd)) :
    fg · BinProductPr1 C (Ps c d),, fgfg ;; dispBinProductPr1 (Ps c d) (dPs c d cc dd) = f,, ff ×
    fg · BinProductPr2 C (Ps c d),, fgfg ;; dispBinProductPr2 (Ps c d) (dPs c d cc dd) = g,, gg →
    fg,, fgfg = total_category_Binproducts_mediating_morphism Ps dPs ff gg.
  Proof.
    intro H.
    induction H as [H1 H2].
    cbn in *.
    induction (total2_paths_equiv _ _ _ H1) as [H1l H1r].
    induction (total2_paths_equiv _ _ _ H2) as [H2l H2r].
    clear H1 H2.
    use total2_paths_f; cbn.
    - use path_to_ctr; split; assumption.
    - cbn in *.
      rewrite <- H1r, <- H2r.
      clear H1r H2r ff gg.
      induction H1l.
      induction H2l.
      (* apply dispBinProductArrowEta. would work with [BinProductArrowEta'] *)
      (* we proceed as follows: *)
      cbn.
      etrans.
      2: { assert (aux := dispBinProductArrowEta (Ps c d) cc dd (dPs _ _ cc dd) xx fgfg).
           apply transportf_transpose_left in aux.
           exact aux. }
      apply (maponpaths (fun z => transportf (mor_disp xx (dispBinProductObject (Ps c d) (dPs c d cc dd))) z fgfg)).
      apply C.
  Qed.

  Definition total_category_Binproducts (Ps : BinProducts C) (dPs : dispBinProducts Ps) : BinProducts (total_category D).
  Proof.
    intros ccc ddd.
    use tpair.
    - apply (total_category_Binproducts_data Ps dPs).
    - induction ccc as [c cc].
      induction ddd as [d dd].
      intros aaa fff ggg.
      destruct aaa as [a aa]; destruct fff as [f ff]; destruct ggg as [g gg].
      cbn.
      use unique_exists.
      + exact (total_category_Binproducts_mediating_morphism Ps dPs ff gg).
      + exact (total_category_Binproducts_mediating_morphism_ok Ps dPs ff gg).
      + intro y.
        apply isapropdirprod.
        * apply (homset_property (total_category D) (a ,, aa) (c ,, cc)).
        * apply (homset_property (total_category D) (a ,, aa) (d ,, dd)).
      + intro fgfgfg.
        induction fgfgfg as [fg fgfg].
        exact (total_category_Binproducts_mediating_morphism_unique Ps dPs ff gg fgfg).
  Defined.

(** ** analogously for terminal objects *)

  Definition is_dispTerminal (P : Terminal C) (pp : D (TerminalObject P)) : UU :=
    ∏ (a : C) (aa : D a), iscontr (aa -->[TerminalArrow P a] pp).

  Definition dispTerminal (P : Terminal C) : UU :=
    ∑ pp :  D (TerminalObject P), is_dispTerminal P pp.

  Definition dispTerminalObject {P : Terminal C} (dP : dispTerminal P) : D (TerminalObject P) := pr1 dP.

  Definition is_dispTerminal_dispTerminal (P : Terminal C) (dP : dispTerminal P) :
    is_dispTerminal P (dispTerminalObject dP) := pr2 dP.

  Definition dispTerminalArrow (P : Terminal C) (dP : dispTerminal P) {a : C} (aa : D a) :
    aa -->[TerminalArrow P a] dispTerminalObject dP := pr1 (is_dispTerminal_dispTerminal P dP a aa).

  Lemma dispTerminalArrowUnique  (P : Terminal C)
    (dP : dispTerminal P) {x : C} (xx : D x)
    (kk : xx -->[TerminalArrow P x] dispTerminalObject dP) :
    kk = dispTerminalArrow P dP xx.
  Proof.
    apply (pr2 (pr2 dP x xx)).
  Qed.

  Lemma dispTerminalArrowUnique'  (P : Terminal C)
    (dP : dispTerminal P) {x : C} (xx : D x) (f: x --> TerminalObject P)
    (kk : xx -->[f] dispTerminalObject dP) :
    kk = transportb _ (TerminalArrowUnique P x f) (dispTerminalArrow P dP xx).
  Proof.
    apply transportf_transpose_right.
    apply dispTerminalArrowUnique.
  Qed.

  Lemma dispTerminalArrowEq {T : Terminal C} {TT: dispTerminal T} {a : C} {aa : D a} {f g : a --> T}
    (ff: aa -->[f] dispTerminalObject TT) (gg: aa -->[g] dispTerminalObject TT) :
    ff = transportb _ (TerminalArrowEq f g) gg.
  Proof.
    induction (TerminalArrowEq f g).
    cbn.
    rewrite (dispTerminalArrowUnique' _ _ _ _ ff).
    rewrite (dispTerminalArrowUnique' _ _ _ _ gg).
    apply idpath.
  Qed.

  Definition total_category_Terminal (P : Terminal C) (dP : dispTerminal P) : Terminal (total_category D).
  Proof.
    use tpair.
    - exists (TerminalObject P).
      exact (dispTerminalObject dP).
    - intros aaa.
      destruct aaa as [a aa].
      cbn.
      use tpair.
      + exact (TerminalArrow P a,, dispTerminalArrow P dP aa).
      + intro fff.
        induction fff as [f ff].
        use total2_paths_f; cbn.
        * apply TerminalArrowUnique.
        * apply dispTerminalArrowUnique.
  Defined.

End FixDispCat.


Require Import Toy.Imp Toy.Language_noderef.
Require Import Toy.UnifySL.implementation.
Import T.

Module Assertion_Shallow.
Import Denote_Aexp.
Import Denote_Bexp.
Import Denote_Com.

Definition exp {A : Type} (P : A -> Assertion) : Assertion := fun st => exists a, P a st.

Definition inj (b : bexp) : Assertion := fun st => true_set (beval b) (fst st).

Definition eqp (a : aexp) (v : Z) : Assertion := fun st => (aeval a) (fst st) = Some v.

Definition safea (a : aexp) : Assertion := fun st => ~ (aeval a) (fst st) = None.

Definition safeb (b : bexp) : Assertion := fun st => ~ error_set (beval b) (fst st).

Definition mapsto_ (p : addr) : Assertion := fun st => (exists v, (snd st) p = Some v) /\ (forall p', p <> p' -> (snd st) p' = None).

Definition mapsto (p : addr) (v : Z) : Assertion := fun st => (snd st) p = Some v /\ (forall p', p <> p' -> (snd st) p' = None).

Definition derives : Assertion -> Assertion -> Prop := fun P Q => forall st, P st -> Q st.

Definition store_update (s : store) (X : var) (v : option Z) : store :=
  match v with
  | Some n => fun Y => if (Nat.eq_dec Y X) then n else s Y
  | None => fun Y => 0
  end.

Definition heap_update (h : heap) (p : addr) (v : option Z) : heap :=
  fun q => if (Z.eq_dec p q) then v else h q.

Definition subst_set (P : Assertion) (X : var) (v : Z) : Assertion :=
  fun st => P (store_update (fst st) X (Some v), snd st).

Definition subst_load (P : Assertion) (X : var) (v : Z) : Assertion :=
  fun st => P (store_update (fst st) X (Some v), snd st).

(* Definition join_heap : heap -> heap -> heap -> Prop :=
  fun h1 h2 h3 =>
    forall p : Z,
      (exists v, h1 p = Some v /\ h2 p = None /\ h3 p = Some v) \/
      (exists v, h1 p = None /\ h2 p = Some v /\ h3 p = Some v) \/
      (h1 p = None /\ h2 p = None /\ h3 p = None).

Definition join : state -> state -> state -> Prop :=
  fun st1 st2 st3 => fst st1 = fst st2 /\ fst st2 = fst st3 /\ join_heap (snd st1) (snd st2) (snd st3).

Definition sepcon (P Q : Assertion) : Assertion :=
  fun st => exists st1 st2, join st1 st2 st /\ P st1 /\ Q st2. *)
End Assertion_Shallow.

Module Validity.
Import Assertion_Shallow.
Import Denote_Com.

Definition valid (P : Assertion) (c : com) (Q Rb Rc : Assertion) : Prop :=
  forall st1 st2, P st1 ->
    (~ com_error (ceval c) st1) /\
    (com_normal (ceval c) st1 st2 -> Q st2) /\
    (com_break (ceval c) st1 st2 -> Rb st2) /\
    (com_cont (ceval c) st1 st2 -> Rc st2).

End Validity.

Module tacticforOSA.

Ltac UFsepcon := unfold sepcon in *;
                 unfold WeakSemantics.WeakSemantics.sepcon in *;
                 unfold SeparationAlgebra.join in *.

Ltac UFjoin := unfold stateJ in *; unfold stateJoin in *;
               unfold OSAGenerators.prod_Join in *;
               unfold SeparationAlgebra.join in *;
               unfold store_join in *;
               unfold OSAGenerators.equiv_Join in *.

Ltac UFheapjoin := unfold heap_join in *;
                   unfold OSAExamples.Heap_Join in *;
                   unfold OSAGenerators.fun_Join in *;
                   unfold SeparationAlgebra.join in *;
                   unfold OSAGenerators.option_Join in *.

Lemma osajoin : forall (st1 st2 st : state),
  (forall x, @OSAGenerators.option_join Z (@OSAGenerators.trivial_Join Z)
          (snd st1 x) (snd st2 x) (snd st x)) <->
  (forall p, (exists v, snd st1 p = Some v /\ snd st2 p = None /\ snd st p = Some v) \/
             (exists v, snd st1 p = None /\ snd st2 p = Some v /\ snd st p = Some v) \/
             (snd st1 p = None ) /\ (snd st2 p = None) /\ (snd st p = None)).
Proof.
  intros.
  unfold iff; split.
  + intros.
    specialize (H p).
    destruct (snd st1 p), (snd st2 p), (snd st p).
    - inversion H. tauto.
    - inversion H.
    - inversion H. rewrite <- H0.
      left. exists z. tauto.
    - inversion H.
    - inversion H.
      right. left. exists z0. tauto.
    - inversion H.
    - inversion H.
    - right. right. tauto.
  + intros.
    specialize (H x).
    destruct (snd st1 x), (snd st2 x), (snd st x).
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H0.
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [? [? ?]]. inversion H.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H0.
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [? [? ?]]. inversion H.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]].
        inversion H. inversion H1. subst. constructor.
      * destruct H as [v [? [? ?]]]. inversion H0.
      * destruct H as [? [? ?]]. inversion H.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H1.
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [? [? ?]]. inversion H.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [v [? [? ?]]].
        inversion H0. inversion H1. subst. constructor.
      * destruct H as [? [? ?]]. inversion H0.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [v [? [? ?]]]. inversion H1.
      * destruct H as [? [? ?]]. inversion H0.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [v [? [? ?]]]. inversion H0.
      * destruct H as [? [? ?]]. inversion H1.
    - destruct H as [? | [? | ?]].
      * destruct H as [v [? [? ?]]]. inversion H.
      * destruct H as [v [? [? ?]]]. inversion H0.
      * constructor.
Qed.

End tacticforOSA.


Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Local Open Scope logic.

Lemma wand_frame_intro {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q: A),
  Q |-- P -* P * Q.
Proof.
  intros.
  apply wand_sepcon_adjoint.
  rewrite sepcon_comm; auto.
Qed.

Lemma wand_frame_intro' {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q R: A),
  P * Q |-- R ->
  Q |-- P -* R.
Proof.
  intros.
  apply wand_sepcon_adjoint.
  rewrite sepcon_comm; auto.
Qed.

Lemma wand_frame_elim {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q: A),
  P * (P -* Q) |-- Q.
Proof.
  intros.
  rewrite sepcon_comm.
  apply wand_sepcon_adjoint; auto.
Qed.

Lemma wand_frame_elim' {A} {ND: NatDed A} {SL: SepLog A}: forall (P P' Q: A),
  P |-- P' -> P * (P' -* Q) |-- Q.
Proof.
  intros.
  rewrite sepcon_comm.
  apply wand_sepcon_adjoint; auto.
  apply wand_derives; auto.
Qed.

Lemma wand_frame_ver {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q R: A),
  (P -* Q) * (Q -* R) |-- P -* R.
Proof.
  intros.
  apply -> wand_sepcon_adjoint.
  rewrite (sepcon_comm _ P), <- sepcon_assoc.
  eapply derives_trans.
  + eapply sepcon_derives; [apply wand_frame_elim | apply derives_refl].
  + apply wand_frame_elim.
Qed.

Lemma wand_frame_hor {A} {ND: NatDed A} {SL: SepLog A}: forall (P1 P2 Q1 Q2: A),
  (P1 -* Q1) * (P2 -* Q2) |-- P1 * P2 -* Q1 * Q2.
Proof.
  intros.
  apply -> wand_sepcon_adjoint.
  rewrite <- (sepcon_assoc _ P1), (sepcon_comm _ P1), <- (sepcon_assoc P1), (sepcon_assoc _ _ P2), (sepcon_comm _ P2).
  apply sepcon_derives; apply wand_frame_elim.
Qed.

Lemma wand_frame_frame {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q F: A),
  P -* Q |-- P * F -* Q * F.
Proof.
  intros.
  apply -> wand_sepcon_adjoint.
  rewrite <- sepcon_assoc, (sepcon_comm _ P).
  apply sepcon_derives; [apply wand_frame_elim | auto].
Qed.


Require Import Coq.Strings.String Coq.Classes.RelationClasses.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Compilers.Relations.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.RewriteHyp.
Require Import Crypto.Util.Notations.
Local Open Scope ctype_scope.
Local Open Scope expr_scope.

Section language.
  Context {base_type_code : Type}
          {interp_base_type : base_type_code -> Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst).

  Local Notation exprf := (@exprf base_type_code op interp_base_type).
  Local Notation expr := (@expr base_type_code op interp_base_type).
  Local Notation Expr := (@Expr base_type_code op).
  Local Notation interpf := (@interpf base_type_code interp_base_type op interp_op).
  Local Notation interp := (@interp base_type_code interp_base_type op interp_op).
  Local Notation Interp := (@Interp base_type_code interp_base_type op interp_op).

  Lemma eq_in_flatten_binding_list
        {t x x' T e}
        (HIn : List.In (existT (fun t : base_type_code => (interp_base_type t * interp_base_type t)%type) t (x, x')%core)
                       (flatten_binding_list (t:=T) e e))
    : x = x'.
  Proof using Type.
    induction T; simpl in *; [ | | rewrite List.in_app_iff in HIn ];
      repeat first [ progress destruct_head or
                   | progress destruct_head False
                   | progress destruct_head and
                   | progress inversion_sigma
                   | progress inversion_prod
                   | progress subst
                   | solve [ eauto ] ].
  Qed.

  Local Hint Resolve List.in_app_or List.in_or_app eq_in_flatten_binding_list.

  Section wf.
    Lemma interpf_wff
             {t} {e1 e2 : exprf t}
             {G}
             (HG : forall t x x',
                 List.In (existT (fun t : base_type_code => (interp_base_type t * interp_base_type t)%type) t (x, x')%core) G
                 -> x = x')
             (Rwf : wff G e1 e2)
    : interpf e1 = interpf e2.
    Proof using Type.
      induction Rwf; simpl; auto;
        specialize_by auto; try congruence.
      rewrite_hyp !*; auto.
      repeat match goal with
             | [ H : context[List.In _ (_ ++ _)] |- _ ]
               => setoid_rewrite List.in_app_iff in H
             end.
      match goal with
      | [ H : _ |- _ ]
        => apply H; intros; destruct_head' or; solve [ eauto ]
      end.
    Qed.

    Local Hint Resolve interpf_wff.

    Lemma interp_wf
             {t} {e1 e2 : expr t}
             (Rwf : wf e1 e2)
    : forall x, interp e1 x = interp e2 x.
    Proof using Type.
      destruct Rwf; simpl; eauto.
    Qed.
  End wf.
End language.


(** We test memory usage of typeclass resification of let-binders to HOAS *)
Require Import PerformanceExperiments.Harness.
Generalizable All Variables.
Axiom Let_In : forall {A P} (v : A) (f : forall x : A, P x), P v.
Fixpoint nested_lets (n : nat) (init : nat) : nat
  := match n with
     | O => init + init
     | S n => Let_In (init + init) (fun x => nested_lets n x)
     end.

Inductive expr :=
| Zero
| Succ (n : expr)
| Plus (x y : expr)
| LetIn (x : expr) (f : nat -> expr)
| Var (v : nat)
.

Axiom P : expr -> Prop.
Axiom p : forall e, P e.

Class reified_of (v : nat) (e : expr) := dummy : True.
Global Hint Mode reified_of ! - : typeclass_instances.
Global Instance reify_plus {x ex y ey} {_:reified_of x ex} {_:reified_of y ey}
  : reified_of (x + y) (Plus ex ey) := I.
Global Instance reify_LetIn {x ex f ef} {_:reified_of x ex} {_:forall v ev, reified_of v (Var ev) -> reified_of (f v) (ef ev)}
  : reified_of (Let_In x f) (LetIn ex ef) := I.
Global Instance reify_0 : reified_of 0 Zero := I.
Global Instance reify_S {n en} {_:reified_of n en} : reified_of (S n) (Succ en) := I.
Definition reify (v : nat) {ev : expr} {_ : reified_of v ev} := ev.
Global Hint Extern 1 (reified_of _ ?ev) => progress cbv [ev] : typeclass_instances.
Global Hint Extern 0 (reified_of _ _) => progress cbv [nested_lets] : typeclass_instances.
Notation reified v := (match _ with e => match _ : reified_of v e with _ => e end end) (only parsing).

Ltac mkgoal n := constr:(True).
Ltac redgoal _ := idtac.
Ltac time_solve_goal0 n :=
  restart_timer;
  assert (P (reified (nested_lets n 0)));
  [ finish_timing ("Tactic call reify-regression-cubic");
    time "abstract-regression-linear" abstract apply p
  | ].

Definition args_of_size (s : size) : list nat
  := match s with
     | Sanity => seq 1 3
     | SuperFast => seq 1 100
     | Fast => List.map (fun x => x * 10) (seq 1 20)
     | Medium => []
     | Slow => []
     | VerySlow => []
     end.

Ltac run0 sz := Harness.runtests args_of_size default_describe_goal mkgoal redgoal time_solve_goal0 sz.

(*
Goal True. run0 Fast.
*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** %\subsection*{ extras :  before\_after.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export omit_facts.

(** - Some stuff I thought would be useful some day but wasn't *)

Definition before (N N' : nat) (i : fin N) (j : fin N') := index i < index j.
Definition after (N N' : nat) (i : fin N) (j : fin N') := index i > index j.

Definition notbefore (N N' : nat) (i : fin N) (j : fin N') :=
  index i = index j \/ after i j.
Definition notafter (N N' : nat) (i : fin N) (j : fin N') :=
  before i j \/ index i = index j.

Lemma decide_fin :
 forall (N N' : nat) (i : fin N) (i' : fin N'),
 before i i' \/ index i = index i' \/ after i i'.
simpl in |- *.
unfold before, after in |- *.
intros.
case i; case i'.
simpl in |- *.
intros x l x0 l0.
clear l0 l i' i N N'.
induction  x as [| x Hrecx]; induction  x0 as [| x0 Hrecx0];
 unfold gt in |- *; auto with arith.
case Hrecx.
auto with arith.
intro.
unfold gt in |- *; case H.
intro; left.
rewrite H0.
auto.
unfold gt in |- *.
intro.
right.
case H0.
auto.
intros.
cut (S x < S m \/ S x = S m).
intro.
case H2.
auto.
auto.
left.
auto with arith.
Qed.

Lemma decide_before :
 forall (N N' : nat) (i : fin N) (j : fin N'), before i j \/ notbefore i j.
unfold notbefore in |- *.
apply decide_fin.
Qed.

Lemma decide_after :
 forall (N N' : nat) (i : fin N) (j : fin N'), after i j \/ notafter i j.
unfold notafter in |- *.
intros.
case (decide_before i j).
auto.
unfold notbefore in |- *.
tauto.
Qed.

Lemma seq_properties_split_before_eq_after :
 forall (A : Setoid) (n : nat) (v : seq n A) (i : fin n) (P : Predicate A),
 (forall j : fin n, before j i -> Pred_fun P (v j)) ->
 Pred_fun P (v i) ->
 (forall j : fin n, after j i -> Pred_fun P (v j)) ->
 forall j : fin n, Pred_fun P (v j).
intros.
case (decide_fin j i); auto.
intro.
case H2; auto.
generalize H0.
elim P.
simpl in |- *.
unfold pred_compatible in |- *.
intros.
apply Pred_compatible_prf with (v i); auto with algebra.
Qed.

Lemma predicate_split_seq_before_notbefore :
 forall (A : Setoid) (n : nat) (v : seq n A) (i : fin n) (P : Predicate A),
 (forall j : fin n, before j i -> Pred_fun P (v j)) ->
 (forall j : fin n, notbefore j i -> Pred_fun P (v j)) ->
 forall j : fin n, Pred_fun P (v j).
intros.
case (decide_before j i); auto.
Qed.

Lemma predicate_split_seq_after_notafter :
 forall (A : Setoid) (n : nat) (v : seq n A) (i : fin n) (P : Predicate A),
 (forall j : fin n, after j i -> Pred_fun P (v j)) ->
 (forall j : fin n, notafter j i -> Pred_fun P (v j)) ->
 forall j : fin n, Pred_fun P (v j).
intros.
case (decide_after j i); auto.
Qed.

Lemma seq_properties_split_before_notbefore :
 forall (A : Setoid) (n : nat) (v : seq n A) (i : fin n) (P : A -> Prop),
 (forall j : fin n, before j i -> P (v j)) ->
 (forall j : fin n, notbefore j i -> P (v j)) -> forall j : fin n, P (v j).
intros.
case (decide_before j i); auto.
Qed.

Lemma seq_properties_split_after_notafter :
 forall (A : Setoid) (n : nat) (v : seq n A) (i : fin n) (P : A -> Prop),
 (forall j : fin n, after j i -> P (v j)) ->
 (forall j : fin n, notafter j i -> P (v j)) -> forall j : fin n, P (v j).
intros.
case (decide_after j i); auto.
Qed.

Definition next (n : nat) (i : fin n) : fin (S n) :=
  match i with
  | Build_finiteT ni Hi => Build_finiteT (lt_n_S _ _ Hi)
  end.
Definition prev :
  forall (n : nat) (i : fin (S n)),
  ~ i =' Build_finiteT (lt_O_Sn n) in _ -> fin n.
intros n i; case i.
intro x; case x.
simpl in |- *.
intros.
absurd (0 = 0); auto.
intros.
exact (Build_finiteT (lt_S_n _ _ in_range_prf)).
Defined.


From Hammer Require Import Hammer.

From Coq Require Import Arith.Arith.

From PLF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import Stlc.
From PLF Require Import LibTactics.

From PLF Require Imp.

From Coq Require Import Lists.List.
Import ListNotations.

Lemma solving_by_reflexivity :
2 + 3 = 5.
Proof. hammer_hook "UseAuto" "UseAuto.solving_by_reflexivity". auto. Qed.

Lemma solving_by_apply : forall (P Q : nat->Prop),
(forall n, Q n -> P n) ->
(forall n, Q n) ->
P 2.
Proof. hammer_hook "UseAuto" "UseAuto.solving_by_apply". auto. Qed.

Lemma solving_by_eapply : forall (P Q : nat->Prop),
(forall n m, Q m -> P n) ->
Q 1 ->
P 2.
Proof. hammer_hook "UseAuto" "UseAuto.solving_by_eapply". auto. eauto. Qed.

Lemma solving_conj_goal : forall (P : nat->Prop) (F : Prop),
(forall n, P n) ->
F ->
F /\ P 2.
Proof. hammer_hook "UseAuto" "UseAuto.solving_conj_goal". auto. Qed.

Lemma solving_conj_hyp : forall (F F' : Prop),
F /\ F' ->
F.
Proof. hammer_hook "UseAuto" "UseAuto.solving_conj_hyp". auto. eauto. jauto.  Qed.

Lemma solving_conj_hyp' : forall (F F' : Prop),
F /\ F' ->
F.
Proof. hammer_hook "UseAuto" "UseAuto.solving_conj_hyp'". intros. jauto_set. eauto. Qed.

Lemma solving_conj_more : forall (P Q R : nat->Prop) (F : Prop),
(F /\ (forall n m, (Q m /\ R n) -> P n)) ->
(F -> R 2) ->
Q 1 ->
P 2 /\ F.
Proof. hammer_hook "UseAuto" "UseAuto.solving_conj_more". jauto.  Qed.

Lemma solving_conj_hyp_forall : forall (P Q : nat->Prop),
(forall n, P n /\ Q n) ->
P 2.
Proof. hammer_hook "UseAuto" "UseAuto.solving_conj_hyp_forall".
auto. eauto. iauto. jauto.

intros. destruct (H 2). auto.
Qed.

Lemma solved_by_jauto : forall (P Q : nat->Prop) (F : Prop),
(forall n, P n) /\ (forall n, Q n) ->
P 2.
Proof. hammer_hook "UseAuto" "UseAuto.solved_by_jauto". jauto.  Qed.

Lemma solving_disj_goal : forall (F F' : Prop),
F ->
F \/ F'.
Proof. hammer_hook "UseAuto" "UseAuto.solving_disj_goal". auto. Qed.

Lemma solving_disj_hyp : forall (F F' : Prop),
F \/ F' ->
F' \/ F.
Proof. hammer_hook "UseAuto" "UseAuto.solving_disj_hyp". auto. eauto. jauto. iauto. Qed.

Lemma solving_tauto : forall (F1 F2 F3 : Prop),
((~F1 /\ F3) \/ (F2 /\ ~F3)) ->
(F2 -> F1) ->
(F2 -> F3) ->
~F2.
Proof. hammer_hook "UseAuto" "UseAuto.solving_tauto". iauto. Qed.

Lemma solving_exists_goal : forall (f : nat->Prop),
f 2 ->
exists x, f x.
Proof. hammer_hook "UseAuto" "UseAuto.solving_exists_goal".
auto.
eauto.
Qed.

Lemma solving_exists_hyp : forall (f g : nat->Prop),
(forall x, f x -> g x) ->
(exists a, f a) ->
(exists a, g a).
Proof. hammer_hook "UseAuto" "UseAuto.solving_exists_hyp".
auto. eauto. iauto.
jauto.

Qed.

Lemma negation_study_1 : forall (P : nat->Prop),
P 0 ->
(forall x, ~ P x) ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.negation_study_1".
intros P H0 HX.
eauto.
unfold not in *. eauto.
Qed.

Lemma negation_study_2 : forall (P : nat->Prop),
P 0 ->
(forall x, ~ P x) ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.negation_study_2". jauto.  Qed.

Lemma equality_by_auto : forall (f g : nat->Prop),
(forall x, f x = g x) ->
g 2 = f 2.
Proof. hammer_hook "UseAuto" "UseAuto.equality_by_auto". auto. Qed.

Lemma search_depth_0 :
True /\ True /\ True /\ True /\ True /\ True.
Proof. hammer_hook "UseAuto" "UseAuto.search_depth_0".
auto.
Abort.

Lemma search_depth_1 : forall (P : nat->Prop),
P 0 ->
(P 0 -> P 1) ->
(P 1 -> P 2) ->
(P 2).
Proof. hammer_hook "UseAuto" "UseAuto.search_depth_1".
auto 0.
auto 1.
auto 2.
auto 3.

Qed.

Lemma search_depth_3 : forall (P : nat->Prop),
(P 0) ->
(forall k, P (k-1) -> P k) ->
(P 4).
Proof. hammer_hook "UseAuto" "UseAuto.search_depth_3". auto. Qed.

Lemma search_depth_4 : forall (P : nat->Prop),
(P 0) ->
(forall k, P (k-1) -> P k) ->
(P 5).
Proof. hammer_hook "UseAuto" "UseAuto.search_depth_4". auto. auto 6. Qed.

Lemma search_depth_5 : forall (P : nat->Prop),
(P 0) ->
(forall k, P (k-1) -> P k) ->
(P 4 /\ P 4).
Proof. hammer_hook "UseAuto" "UseAuto.search_depth_5". auto. auto 6. Qed.

Lemma working_of_auto_1 : forall (P : nat->Prop),
(P 0) ->
(forall k, P (k-1) -> P k) ->
(forall k, P (k+1) -> P k) ->
(P 2).

Proof. hammer_hook "UseAuto" "UseAuto.working_of_auto_1". intros P H1 H2 H3.  eauto. Qed.

Lemma working_of_auto_2 : forall (P : nat->Prop),
(P 0) ->
(forall k, P (k+1) -> P k) ->
(forall k, P (k-1) -> P k) ->
(P 2).
Proof. hammer_hook "UseAuto" "UseAuto.working_of_auto_2". intros P H1 H3 H2.  eauto. Qed.

Lemma nat_le_refl : forall (x:nat), x <= x.
Proof. hammer_hook "UseAuto" "UseAuto.nat_le_refl". apply le_n. Qed.

Hint Resolve nat_le_refl.

Ltac auto_star ::= try solve [ jauto ].

Ltac auto_tilde ::= auto.

Module DeterministicImp.
Import Imp.

Theorem ceval_deterministic: forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseAuto" "UseAuto.DeterministicImp.ceval_deterministic".
intros c st st1 st2 E1 E2.
generalize dependent st2.
(induction E1); intros st2 E2; inversion E2; subst.
-  reflexivity.
-  reflexivity.
-
assert (st' = st'0) as EQ1.
{  apply IHE1_1; assumption. }
subst st'0.
apply IHE1_2. assumption.

-
apply IHE1. assumption.
-
rewrite H in H5. inversion H5.

-
rewrite H in H5. inversion H5.
-
apply IHE1. assumption.

-
reflexivity.
-
rewrite H in H2. inversion H2.

-
rewrite H in H4. inversion H4.
-
assert (st' = st'0) as EQ1.
{  apply IHE1_1; assumption. }
subst st'0.
apply IHE1_2. assumption.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseAuto" "UseAuto.DeterministicImp.ceval_deterministic'".
admit.
Admitted.

Theorem ceval_deterministic'': forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseAuto" "UseAuto.DeterministicImp.ceval_deterministic''".
introv E1 E2. gen st2.
induction E1; intros; inverts E2; tryfalse.
- auto.
- auto.
- assert (st' = st'0). auto. subst. auto.
- auto.
- auto.
- auto.
- assert (st' = st'0). auto. subst. auto.
Qed.

Theorem ceval_deterministic''': forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseAuto" "UseAuto.DeterministicImp.ceval_deterministic'''".

introv E1 E2. gen st2.
induction E1; intros; inverts E2; tryfalse.
- auto.
- auto.

- dup 4.

+ assert (st' = st'0). apply IHE1_1. apply H1.
skip.

+ forwards: IHE1_1. apply H1.
skip.

+ forwards: IHE1_1. eauto.
skip.

+ forwards*: IHE1_1.
skip.

Abort.

Theorem ceval_deterministic'''': forall c st st1 st2,
st =[ c ]=> st1  ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseAuto" "UseAuto.DeterministicImp.ceval_deterministic''''".
introv E1 E2. gen st2.
induction E1; intros; inverts* E2; tryfalse.
- forwards*: IHE1_1. subst*.
- forwards*: IHE1_1. subst*.
Qed.

End DeterministicImp.

Set Warnings "-notation-overridden,-parsing".
From PLF Require Import StlcProp.
Module PreservationProgressStlc.
Import STLC.
Import STLCProp.

Theorem preservation : forall t t' T,
has_type empty t T  ->
t --> t'  ->
has_type empty t' T.
Proof with eauto. hammer_hook "UseAuto" "UseAuto.PreservationProgressStlc.preservation".
remember (@empty ty) as Gamma.
intros t t' T HT. generalize dependent t'.
(induction HT); intros t' HE; subst Gamma.
-
inversion HE.
-
inversion HE.
-
inversion HE; subst...

+
apply substitution_preserves_typing with T11...
inversion HT1...
-
inversion HE.
-
inversion HE.
-
inversion HE; subst...
Qed.

Theorem preservation' : forall t t' T,
has_type empty t T  ->
t --> t'  ->
has_type empty t' T.
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressStlc.preservation'".
admit.
Admitted.

Theorem progress : forall t T,
has_type empty t T ->
value t \/ exists t', t --> t'.
Proof with eauto. hammer_hook "UseAuto" "UseAuto.PreservationProgressStlc.progress".
intros t T Ht.
remember (@empty ty) as Gamma.
(induction Ht); subst Gamma...
-
inversion H.
-
right. destruct IHHt1...
+
destruct IHHt2...
*
inversion H; subst; try solve_by_invert.
exists ([x0:=t2]t)...
*
destruct H0 as [t2' Hstp]. exists (app t1 t2')...
+
destruct H as [t1' Hstp]. exists (app t1' t2)...
-
right. destruct IHHt1...
destruct t1; try solve_by_invert...
inversion H. exists (test x0 t2 t3)...
Qed.

Theorem progress' : forall t T,
has_type empty t T ->
value t \/ exists t', t --> t'.
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressStlc.progress'".
admit.
Admitted.

End PreservationProgressStlc.

From PLF Require Import Smallstep.
Require Import Program.
Module Semantics.

Theorem multistep__eval : forall t v,
normal_form_of t v -> exists n, v = C n /\ t ==> n.
Proof. hammer_hook "UseAuto" "UseAuto.Semantics.multistep__eval".
intros t v Hnorm.
unfold normal_form_of in Hnorm.
inversion Hnorm as [Hs Hnf]; clear Hnorm.
rewrite nf_same_as_value in Hnf. inversion Hnf. clear Hnf.
exists n. split. reflexivity.
induction Hs; subst.
-
apply E_Const.
-
eapply step__eval. eassumption. apply IHHs. reflexivity.
Qed.

Theorem multistep_eval_ind : forall t v,
t -->* v -> forall n, C n = v -> t ==> n.
Proof. hammer_hook "UseAuto" "UseAuto.Semantics.multistep_eval_ind".
admit.
Admitted.

Theorem multistep__eval' : forall t v,
normal_form_of t v -> exists n, v = C n /\ t ==> n.
Proof. hammer_hook "UseAuto" "UseAuto.Semantics.multistep__eval'".
admit.
Admitted.

Theorem multistep__eval'' : forall t v,
normal_form_of t v -> exists n, v = C n /\ t ==> n.
Proof. hammer_hook "UseAuto" "UseAuto.Semantics.multistep__eval''".
admit.
Admitted.

End Semantics.

From Coq Require Import omega.Omega.
From PLF Require Import References.
Import STLCRef.
Require Import Program.
Module PreservationProgressReferences.
Hint Resolve store_weakening extends_refl.

Theorem preservation : forall ST t t' T st st',
has_type empty ST t T ->
store_well_typed ST st ->
t / st --> t' / st' ->
exists ST',
(extends ST' ST /\
has_type empty ST' t' T /\
store_well_typed ST' st').
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressReferences.preservation".

remember (@empty ty) as Gamma. introv Ht. gen t'.
(induction Ht); introv HST Hstep;

subst Gamma; inverts Hstep; eauto.

-

exists ST. inverts Ht1. splits*. applys* substitution_preserves_typing.

-

forwards: IHHt1. eauto. eauto. eauto.

jauto_set_hyps; intros.

jauto_set_goal; intros.

eauto. eauto. eauto.

-

forwards*: IHHt2.

- forwards*: IHHt.
- forwards*: IHHt.
- forwards*: IHHt1.
- forwards*: IHHt2.
- forwards*: IHHt1.

-
+

exists (ST ++ T1::nil). inverts keep HST. splits.

apply extends_app.

applys_eq T_Loc 1.

rewrite app_length. simpl. omega.

unfold store_Tlookup. rewrite <- H. rewrite* app_nth2.

rewrite minus_diag. simpl. reflexivity.
apply* store_well_typed_app.

- forwards*: IHHt.

-
+

exists ST. splits*.

lets [_ Hsty]: HST.

applys_eq* Hsty 1.

inverts* Ht.

- forwards*: IHHt.

-
+

exists ST. splits*. applys* assign_pres_store_typing. inverts* Ht1.

- forwards*: IHHt1.
- forwards*: IHHt2.
Qed.

Lemma nth_eq_last' : forall (A : Type) (l : list A) (x d : A) (n : nat),
n = length l -> nth n (l ++ x::nil) d = x.
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressReferences.nth_eq_last'". intros. subst. apply nth_eq_last. Qed.

Lemma preservation_ref : forall (st:store) (ST : store_ty) T1,
length ST = length st ->
Ref T1 = Ref (store_Tlookup (length st) (ST ++ T1::nil)).
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressReferences.preservation_ref".
intros. dup.

unfold store_Tlookup. rewrite* nth_eq_last'.

fequal. symmetry. apply* nth_eq_last'.
Qed.

Theorem preservation' : forall ST t t' T st st',
has_type empty ST t T ->
store_well_typed ST st ->
t / st --> t' / st' ->
exists ST',
(extends ST' ST /\
has_type empty ST' t' T /\
store_well_typed ST' st').
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressReferences.preservation'".
remember (@empty ty) as Gamma. introv Ht. gen t'.
induction Ht; introv HST Hstep; subst Gamma; inverts Hstep; eauto.
- exists ST. inverts Ht1. splits*. applys* substitution_preserves_typing.
- forwards*: IHHt1.
- forwards*: IHHt2.
- forwards*: IHHt.
- forwards*: IHHt.
- forwards*: IHHt1.
- forwards*: IHHt2.
- forwards*: IHHt1.
- exists (ST ++ T1::nil). inverts keep HST. splits.
apply extends_app.
applys_eq T_Loc 1.
rewrite app_length. simpl. omega.
unfold store_Tlookup. rewrite* nth_eq_last'.
apply* store_well_typed_app.
- forwards*: IHHt.
- exists ST. splits*. lets [_ Hsty]: HST.
applys_eq* Hsty 1. inverts* Ht.
- forwards*: IHHt.
- exists ST. splits*. applys* assign_pres_store_typing. inverts* Ht1.
- forwards*: IHHt1.
- forwards*: IHHt2.
Qed.

Theorem progress : forall ST t T st,
has_type empty ST t T ->
store_well_typed ST st ->
(value t \/ exists t' st', t / st --> t' / st').
Proof. hammer_hook "UseAuto" "UseAuto.PreservationProgressReferences.progress".
introv Ht HST. remember (@empty ty) as Gamma.
induction Ht; subst Gamma; tryfalse; try solve [left*].
- right. destruct* IHHt1 as [K|].
inverts K; inverts Ht1.
destruct* IHHt2.
- right. destruct* IHHt as [K|].
inverts K; try solve [inverts Ht]. eauto.
- right. destruct* IHHt as [K|].
inverts K; try solve [inverts Ht]. eauto.
- right. destruct* IHHt1 as [K|].
inverts K; try solve [inverts Ht1].
destruct* IHHt2 as [M|].
inverts M; try solve [inverts Ht2]. eauto.
- right. destruct* IHHt1 as [K|].
inverts K; try solve [inverts Ht1]. destruct* n.
- right. destruct* IHHt.
- right. destruct* IHHt as [K|].
inverts K; inverts Ht as M.
inverts HST as N. rewrite* N in M.
- right. destruct* IHHt1 as [K|].
destruct* IHHt2.
inverts K; inverts Ht1 as M.
inverts HST as N. rewrite* N in M.
Qed.

End PreservationProgressReferences.

From PLF Require Sub.
Module SubtypingInversion.
Import Sub.

Lemma abs_arrow : forall x S1 s2 T1 T2,
has_type empty (abs x S1 s2) (Arrow T1 T2) ->
subtype T1 S1
/\ has_type (update empty x S1) s2 T2.
Proof with eauto. hammer_hook "UseAuto" "UseAuto.SubtypingInversion.abs_arrow".
intros x S1 s2 T1 T2 Hty.
apply typing_inversion_abs in Hty.
destruct Hty as [S2 [Hsub Hty]].
apply sub_inversion_arrow in Hsub.
destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
inversion Heq; subst...
Qed.

Lemma abs_arrow' : forall x S1 s2 T1 T2,
has_type empty (abs x S1 s2) (Arrow T1 T2) ->
subtype T1 S1
/\ has_type (update empty x S1) s2 T2.
Proof. hammer_hook "UseAuto" "UseAuto.SubtypingInversion.abs_arrow'".
admit.
Admitted.

End SubtypingInversion.

Lemma order_matters_1 : forall (P : nat->Prop),
(forall n m, P m -> m <> 0 -> P n) ->
P 2 ->
P 1.
Proof. hammer_hook "UseAuto" "UseAuto.order_matters_1".
eauto.

Qed.

Lemma order_matters_2 : forall (P : nat->Prop),
(forall n m, m <> 0 -> P m -> P n) ->
P 5 ->
P 1.
Proof. hammer_hook "UseAuto" "UseAuto.order_matters_2".
eauto.

intros P H K.
eapply H.

eauto.

Abort.

Axiom P : nat -> Prop.

Definition myFact := forall x, x <= 3 -> P x.

Lemma demo_hint_unfold_goal_1 :
(forall x, P x) ->
myFact.
Proof. hammer_hook "UseAuto" "UseAuto.demo_hint_unfold_goal_1".
auto.
unfold myFact. auto.
Qed.

Hint Unfold myFact.

Lemma demo_hint_unfold_goal_2 :
(forall x, P x) ->
myFact.
Proof. hammer_hook "UseAuto" "UseAuto.demo_hint_unfold_goal_2". auto. Qed.

Lemma demo_hint_unfold_context_1 :
(True -> myFact) ->
P 3.
Proof. hammer_hook "UseAuto" "UseAuto.demo_hint_unfold_context_1".
intros.
auto.
unfold myFact in *. auto.
Qed.

Lemma demo_hint_unfold_context_2 :
myFact ->
P 3.
Proof. hammer_hook "UseAuto" "UseAuto.demo_hint_unfold_context_2". auto. Qed.

Parameter le_not_gt : forall x,
(x <= 3) ->
~ (x > 3).

Parameter gt_not_le : forall x,
(x > 3) ->
~ (x <= 3).

Parameter le_gt_false : forall x,
(x <= 3) ->
(x > 3) ->
False.

Section DemoAbsurd1.

Hint Resolve le_not_gt.

Lemma demo_auto_absurd_1 :
(exists x, x <= 3 /\ x > 3) ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.demo_auto_absurd_1".
intros. jauto_set.
eauto.
eapply le_not_gt. eauto. eauto.
Qed.

Hint Resolve le_gt_false.

Lemma demo_auto_absurd_2 :
(exists x, x <= 3 /\ x > 3) ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.demo_auto_absurd_2".
dup.

intros. jauto_set.  eauto.

jauto.
Qed.

End DemoAbsurd1.

Lemma demo_false : forall x,
(x <= 3) ->
(x > 3) ->
4 = 5.
Proof. hammer_hook "UseAuto" "UseAuto.demo_false".
intros. dup 4.

- false. eapply le_gt_false.
+ auto.

+ skip.

- false. eapply le_gt_false.
+ eauto.
+ eauto.

- false le_gt_false. eauto. eauto.

- false le_not_gt. eauto. eauto.

Abort.

Parameter typ : Type.

Parameter subtype : typ -> typ -> Prop.

Parameter subtype_refl : forall T,
subtype T T.

Parameter subtype_trans : forall S T U,
subtype S T -> subtype T U -> subtype S U.

Hint Resolve subtype_refl.

Section HintsTransitivity.

Hint Resolve subtype_trans.

Lemma transitivity_bad_hint_1 : forall S T,
subtype S T.
Proof. hammer_hook "UseAuto" "UseAuto.transitivity_bad_hint_1".
intros.  eauto.
Abort.

End HintsTransitivity.

Hint Extern 1 (subtype ?S ?U) =>
match goal with
| H: subtype S ?T |- _ => apply (@subtype_trans S T U)
| H: subtype ?T U |- _ => apply (@subtype_trans S T U)
end.

Lemma transitivity_workaround_1 : forall T1 T2 T3 T4,
subtype T1 T2 ->
subtype T2 T3 ->
subtype T3 T4 ->
subtype T1 T4.
Proof. hammer_hook "UseAuto" "UseAuto.transitivity_workaround_1".
intros.  eauto.
Qed.

Lemma transitivity_workaround_2 : forall S T,
subtype S T.
Proof. hammer_hook "UseAuto" "UseAuto.transitivity_workaround_2".
intros.  eauto.
Abort.

Require Import Omega.

Lemma omega_demo_1 : forall (x y : nat),
(y <= 4) ->
(x + x + 1 <= y) ->
(x <> 0) ->
(x = 1).
Proof. hammer_hook "UseAuto" "UseAuto.omega_demo_1". intros. omega. Qed.

Lemma omega_demo_2 : forall (x y z : nat),
(x + y = z + z) ->
(x - y <= 4) ->
(x - z <= 2).
Proof. hammer_hook "UseAuto" "UseAuto.omega_demo_2". intros. omega. Qed.

Lemma omega_demo_3 : forall (x y : nat),
(x + 5 <= y) ->
(y - x < 3) ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.omega_demo_3". intros. omega. Qed.

Lemma omega_demo_4 : forall (x y : nat) (P : Prop),
(x + 5 <= y) ->
(y - x < 3) ->
P.
Proof. hammer_hook "UseAuto" "UseAuto.omega_demo_4".
intros.

false. omega.
Qed.

Require Import ZArith.
Module RingDemo.
Open Scope Z_scope.

Lemma ring_demo : forall (x y z : Z),
x * (y + z) - z * 3 * x
= x * y - 2 * x * z.
Proof. hammer_hook "UseAuto" "UseAuto.RingDemo.ring_demo". intros. ring. Qed.

End RingDemo.

Lemma congruence_demo_1 :
forall (f : nat->nat->nat) (g h : nat->nat) (x y z : nat),
f (g x) (g y) = z ->
2 = g x ->
g y = h z ->
f 2 (h z) = z.
Proof. hammer_hook "UseAuto" "UseAuto.congruence_demo_1". intros. congruence. Qed.

Lemma congruence_demo_2 :
forall (f : nat->nat->nat) (g h : nat->nat) (x y z : nat),
(forall a, g a = h a) ->
f (g x) (g y) = z ->
g x = 2 ->
f 2 (h y) = z.
Proof. hammer_hook "UseAuto" "UseAuto.congruence_demo_2". congruence. Qed.

Lemma congruence_demo_4 : forall (f g : nat->nat),
(forall a, f a = g a) ->
f (g (g 2)) = g (f (f 2)).
Proof. hammer_hook "UseAuto" "UseAuto.congruence_demo_4". congruence. Qed.

Lemma congruence_demo_3 :
forall (f g h : nat->nat) (x : nat),
(forall a, f a = h a) ->
g x = f x ->
g x <> h x ->
False.
Proof. hammer_hook "UseAuto" "UseAuto.congruence_demo_3". congruence. Qed.


Require compcert.backend.Tunnelingproof.
Require LTLX.

Import Coqlib.
Import Globalenvs.
Import Events.
Import Smallstep.
Import LTLX.
Import Tunneling.
Export Tunnelingproof.

Section WITHCONFIG.
Context `{external_calls_prf: ExternalCalls}.

Variable prog: program.
Let tprog := tunnel_program prog.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Let MATCH_PROG: match_prog prog tprog.
Proof.
  apply transf_program_match.
Qed.

Lemma transf_initial_states:
  forall init_ls i sg args m,
  forall st1, initial_state init_ls prog i sg args m st1 ->
  exists st2, initial_state init_ls tprog i sg args m st2 /\ match_states st1 st2.
Proof.
  intros. inversion H.
  econstructor; split.
  econstructor.
  unfold tprog. erewrite symbols_preserved; eauto.
  unfold tprog. erewrite function_ptr_translated; eauto.
  subst. rewrite sig_preserved. auto.
  assumption.
  constructor; auto. constructor.
Qed.

Lemma transf_final_states:
  forall init_ls,
  forall sg,
  forall st1 st2 r,
  match_states st1 st2 -> final_state init_ls sg st1 r -> final_state init_ls sg st2 r.
Proof.
  intros. inv H0. inv H. inv H4. econstructor; eauto.
Qed.

Theorem transf_program_correct:
  forall init_ls i sg args m,
  forward_simulation (semantics init_ls prog i sg args m) (semantics init_ls tprog i sg args m).
Proof.
  intros.
  eapply forward_simulation_opt.
  eapply senv_preserved; eauto.
  apply transf_initial_states.
  apply transf_final_states.
  apply tunnel_step_correct; auto.
Qed.

End WITHCONFIG.


(* Transfer between N and nat *)
(* Copyright Théo Zimmermann 2015
 * This Source Code Form is subject to the terms of the Mozilla Public License, v.2.0.
 * If a copy of the MPL was not distributed with this file, You can obtain one at
 * http://mozilla.org/MPL/2.0/.
 *)

From Coq Require Import BinNatDef Nnat CMorphisms Program.Basics.
Require Import Transfer.

Definition natN x x' := N.of_nat x = x'.

Instance natN_nb : forall n : nat, Related natN n (N.of_nat n) | 10.
Proof. reflexivity. Qed.

Instance natN_nb' : forall n : N, Related natN (N.to_nat n) n | 10.
Proof. apply N2Nat.id. Qed.

(* Totality of natN *)

Instance natN_bitotal :
  Related ((natN ##> iffT) ##> iffT) forall_def forall_def.
Proof.
  unfold natN.
  intros ? ? HP.
  split; intros ? ?; eapply HP; trivial using N2Nat.id.
Qed.

Module N2Nat_transfer.

(* Preliminaries *)

Lemma natN_bis x x' : natN x x' -> N.to_nat x' = x.
Proof.
  intros <-.
  apply Nat2N.id.
Qed.

Lemma natN_bis_recip x x' : N.to_nat x' = x -> natN x x'.
Proof.
  intros <-.
  apply N2Nat.id.
Qed.

Import N2Nat.

Ltac solve thm :=
  intros;
  unfold arrow, impl;
  repeat (intros ? ? <-%natN_bis);
  try (apply natN_bis_recip);
  (apply thm || symmetry ; apply thm).

(* This symmetry is required for some theorem which
   we translate with eq when we should really have used
   flip eq *)

(* Rewrite all theorems from N2Nat *)

Instance inj : Related (natN ##> natN ##> arrow) eq eq.
Proof.
  solve inj.
Qed.

Instance inj_iff : Related (natN ##> natN ##> iff) eq eq.
Proof.
  solve inj_iff.
Qed.

Instance inj_iffT : Related (natN ##> natN ##> iffT) eq eq.
Proof.
  intros ? ? reln ? ? relm.
  split;
  unfold natN in *.
  - rewrite <- reln.
    intros -> .
    assumption.
  - rewrite <- relm.
    intros -> .
    now apply Nat2N.inj.
Qed.

(* inj_double, inj_succ_double *)

Instance inj_succ : Related (natN ##> natN) S N.succ.
Proof.
  solve inj_succ.
Qed.

Instance inj_add : Related (natN ##> natN ##> natN) Nat.add N.add.
Proof.
  solve inj_add.
Qed.

Instance inj_mul : Related (natN ##> natN ##> natN) Nat.mul N.mul.
Proof.
  solve inj_mul.
Qed.

Instance inj_sub : Related (natN ##> natN ##> natN) Nat.sub N.sub.
Proof.
  solve inj_sub.
Qed.

Instance inj_pred : Related (natN ##> natN) Nat.pred N.pred.
Proof.
  solve inj_pred.
Qed.

Instance inj_div2 : Related (natN ##> natN) Nat.div2 N.div2.
Proof.
  solve inj_div2.
Qed.

Instance inj_compare :
  Related (natN ##> natN ##> eq) Nat.compare N.compare.
Proof.
  solve inj_compare.
Qed.

Instance inj_max : Related (natN ##> natN ##> natN) Nat.max N.max.
Proof.
  solve inj_max.
Qed.

Instance inj_min : Related (natN ##> natN ##> natN) Nat.min N.min.
Proof.
  solve inj_min.
Qed.

Instance inj_iter :
  forall {A} (f : A -> A) (x : A),
  Related (natN ##> eq)
    (fun n => Nat.iter n f x) (fun n => N.iter n f x).
Proof.
  solve inj_iter.
Qed.

End N2Nat_transfer.

Module Nat2N_transfer.

Import Nat2N.

(* Preliminaries *)

Ltac solve thm :=
  intros;
  unfold arrow, impl, flip;
  repeat (intros ? ? <-);
  try (rewrite natN);
  apply thm.

Instance inj : Related (natN ##> natN ##> flip impl) eq eq.
Proof.
  solve inj.
Qed.

(* The rest would mean proving all the same theorems again,
   so we won't do it although that can be done. *)

(* Etc *)

End Nat2N_transfer.