From Coq Require Import ZArith.
From mathcomp Require Import ssreflect ssrbool ssrnat seq.
From Common Require Import Var Bits.
From mQhasm Require Import bvDSL bvVerify Options zVerify.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope N_scope.
Open Scope bvdsl_scope.

Definition fe25519_sq : program :=
let         wsize :=   64%nat in

let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)

let            z0 :=   5 in (* *[uint64 *](rp +  0) *)
let            z1 :=   6 in (* *[uint64 *](rp +  8) *)
let            z2 :=   7 in (* *[uint64 *](rp + 16) *)
let            z3 :=   8 in (* *[uint64 *](rp + 24) *)
let            z4 :=   9 in (* *[uint64 *](rp + 32) *)

let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in

let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in
let            c5 :=  35 in
let            c6 :=  36 in
let            c7 :=  37 in

let          x119 :=  41 in
let          x219 :=  42 in
let          x319 :=  43 in
let          x419 :=  44 in

let           r01 :=  50 in
let           r11 :=  51 in
let           r21 :=  52 in
let           r31 :=  53 in
let           r41 :=  54 in
let           rax :=  55 in
let           rdx :=  56 in

let             t :=  60 in
let       redmask :=  61 in

let           tmp := 998 in
let         carry := 999 in

[::
      (*  *)
      (* int64 rp *)
      (* int64 xp *)
      (*  *)
      (* input rp *)
      (* input xp *)
      (*  *)
      (* int64 r0 *)
      (* int64 r1 *)
      (* int64 r2 *)
      (* int64 r3 *)
      (* int64 r4 *)
      (*  *)
      (* int64 c1 *)
      (* int64 c2 *)
      (* int64 c3 *)
      (* int64 c4 *)
      (* int64 c5 *)
      (* int64 c6 *)
      (* int64 c7 *)
      (* caller c1 *)
      (* caller c2 *)
      (* caller c3 *)
      (* caller c4 *)
      (* caller c5 *)
      (* caller c6 *)
      (* caller c7 *)
      (* stack64 c1_stack *)
      (* stack64 c2_stack *)
      (* stack64 c3_stack *)
      (* stack64 c4_stack *)
      (* stack64 c5_stack *)
      (* stack64 c6_stack *)
      (* stack64 c7_stack *)
      (* stack64 x119_stack *)
      (* stack64 x219_stack *)
      (* stack64 x319_stack *)
      (* stack64 x419_stack *)
      (*  *)

      (* #required for  macro *)

      (* int64 r01 *)
      (* int64 r11 *)
      (* int64 r21 *)
      (* int64 r31 *)
      (* int64 r41 *)
      (* int64 rax *)
      (* int64 rdx *)

      (* int64 t *)
      (* int64 redmask *)

      (*  *)
      (* enter fe25519_sq *)
      (*  *)
      (* c1_stack = c1 *)
      (* c2_stack = c2 *)
      (* c3_stack = c3 *)
      (* c4_stack = c4 *)
      (* c5_stack = c5 *)
      (* c6_stack = c6 *)
      (* c7_stack = c7 *)
      (*  *)
      (*   #BEGIN MACRO  *)
      (*   rax = *[uint64 *](xp + 0) *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 0) *)
      (*   r0 = rax *)
      (*   r01 = rdx *)
bvAssign rax (bvVar x0);
bvMulf rdx rax (bvVar rax) (bvVar x0);
bvAssign r0 (bvVar rax);
bvAssign r01 (bvVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 8) *)
      (*   r1 = rax *)
      (*   r11 = rdx *)
bvAssign rax (bvVar x0);
bvMul rax (bvVar rax) (bvConst (fromPosZ 2%Z));
bvMulf rdx rax (bvVar rax) (bvVar x1);
bvAssign r1 (bvVar rax);
bvAssign r11 (bvVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 16) *)
      (*   r2 = rax *)
      (*   r21 = rdx *)
bvAssign rax (bvVar x0);
bvMul rax (bvVar rax) (bvConst (fromPosZ 2%Z));
bvMulf rdx rax (bvVar rax) (bvVar x2);
bvAssign r2 (bvVar rax);
bvAssign r21 (bvVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   r3 = rax *)
      (*   r31 = rdx *)
bvAssign rax (bvVar x0);
bvMul rax (bvVar rax) (bvConst (fromPosZ 2%Z));
bvMulf rdx rax (bvVar rax) (bvVar x3);
bvAssign r3 (bvVar rax);
bvAssign r31 (bvVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   r4 = rax *)
      (*   r41 = rdx *)
bvAssign rax (bvVar x0);
bvMul rax (bvVar rax) (bvConst (fromPosZ 2%Z));
bvMulf rdx rax (bvVar rax) (bvVar x4);
bvAssign r4 (bvVar rax);
bvAssign r41 (bvVar rdx);
      (*  *)
      (*   rax = *[uint64 *](xp + 8) *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 8) *)
      (*   carry? r2 += rax *)
      (*   r21 += rdx + carry *)
bvAssign rax (bvVar x1);
bvMulf rdx rax (bvVar rax) (bvVar x1);
bvAddC carry r2 (bvVar r2) (bvVar rax);
bvAdc r21 (bvVar r21) (bvVar rdx) carry;
      (*   rax = *[uint64 *](xp + 8) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 16) *)
      (*   carry? r3 += rax *)
      (*   r31 += rdx + carry *)
bvAssign rax (bvVar x1);
bvMul rax (bvVar rax) (bvConst (fromPosZ 2%Z));
bvMulf rdx rax (bvVar rax) (bvVar x2);
bvAddC carry r3 (bvVar r3) (bvVar rax);
bvAdc r31 (bvVar r31) (bvVar rdx) carry;
      (*   rax = *[uint64 *](xp + 8) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   carry? r4 += rax *)
      (*   r41 += rdx + carry *)
bvAssign rax (bvVar x1);
bvMul rax (bvVar rax) (bvConst (fromPosZ 2%Z));
bvMulf rdx rax (bvVar rax) (bvVar x3);
bvAddC carry r4 (bvVar r4) (bvVar rax);
bvAdc r41 (bvVar r41) (bvVar rdx) carry;
      (*   rax = *[uint64 *](xp + 8) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r0 += rax *)
      (*   r01 += rdx + carry *)
bvAssign rax (bvVar x1);
bvMul rax (bvVar rax) (bvConst (fromPosZ 38%Z));
bvMulf rdx rax (bvVar rax) (bvVar x4);
bvAddC carry r0 (bvVar r0) (bvVar rax);
bvAdc r01 (bvVar r01) (bvVar rdx) carry;
      (*    *)
      (*   rax = *[uint64 *](xp + 16) *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 16) *)
      (*   carry? r4 += rax *)
      (*   r41 += rdx + carry *)
bvAssign rax (bvVar x2);
bvMulf rdx rax (bvVar rax) (bvVar x2);
bvAddC carry r4 (bvVar r4) (bvVar rax);
bvAdc r41 (bvVar r41) (bvVar rdx) carry;
      (*   rax = *[uint64 *](xp + 16) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   carry? r0 += rax *)
      (*   r01 += rdx + carry *)
bvAssign rax (bvVar x2);
bvMul rax (bvVar rax) (bvConst (fromPosZ 38%Z));
bvMulf rdx rax (bvVar rax) (bvVar x3);
bvAddC carry r0 (bvVar r0) (bvVar rax);
bvAdc r01 (bvVar r01) (bvVar rdx) carry;
      (*   rax = *[uint64 *](xp + 16) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r1 += rax *)
      (*   r11 += rdx + carry *)
bvAssign rax (bvVar x2);
bvMul rax (bvVar rax) (bvConst (fromPosZ 38%Z));
bvMulf rdx rax (bvVar rax) (bvVar x4);
bvAddC carry r1 (bvVar r1) (bvVar rax);
bvAdc r11 (bvVar r11) (bvVar rdx) carry;
      (*    *)
      (*   rax = *[uint64 *](xp + 24) *)
      (*   rax *= 19 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   carry? r1 += rax *)
      (*   r11 += rdx + carry *)
bvAssign rax (bvVar x3);
bvMul rax (bvVar rax) (bvConst (fromPosZ 19%Z));
bvMulf rdx rax (bvVar rax) (bvVar x3);
bvAddC carry r1 (bvVar r1) (bvVar rax);
bvAdc r11 (bvVar r11) (bvVar rdx) carry;
      (*   rax = *[uint64 *](xp + 24) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r2 += rax *)
      (*   r21 += rdx + carry *)
bvAssign rax (bvVar x3);
bvMul rax (bvVar rax) (bvConst (fromPosZ 38%Z));
bvMulf rdx rax (bvVar rax) (bvVar x4);
bvAddC carry r2 (bvVar r2) (bvVar rax);
bvAdc r21 (bvVar r21) (bvVar rdx) carry;
      (*    *)
      (*   rax = *[uint64 *](xp + 32) *)
      (*   rax *= 19 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r3 += rax *)
      (*   r31 += rdx + carry *)
bvAssign rax (bvVar x4);
bvMul rax (bvVar rax) (bvConst (fromPosZ 19%Z));
bvMulf rdx rax (bvVar rax) (bvVar x4);
bvAddC carry r3 (bvVar r3) (bvVar rax);
bvAdc r31 (bvVar r31) (bvVar rdx) carry;
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (*   redmask = *[uint64 *] &crypto_sign_ed25519_amd64_51_REDMASK51 *)
      (*   r01 = (r01.r0) << 13 *)
      (*   r0 &= redmask *)
bvConcatShl r01 r0 (bvVar r01) (bvVar r0) (fromNat 13);
      (*    *)
      (*   r11 = (r11.r1) << 13 *)
      (*   r1 &= redmask *)
      (*   r1 += r01 *)
bvConcatShl r11 r1 (bvVar r11) (bvVar r1) (fromNat 13);
bvAdd r1 (bvVar r1) (bvVar r01);
      (*    *)
      (*   r21 = (r21.r2) << 13 *)
      (*   r2 &= redmask *)
      (*   r2 += r11 *)
bvConcatShl r21 r2 (bvVar r21) (bvVar r2) (fromNat 13);
bvAdd r2 (bvVar r2) (bvVar r11);
      (*    *)
      (*   r31 = (r31.r3) << 13 *)
      (*   r3 &= redmask *)
      (*   r3 += r21 *)
bvConcatShl r31 r3 (bvVar r31) (bvVar r3) (fromNat 13);
bvAdd r3 (bvVar r3) (bvVar r21);
      (*    *)
      (*   r41 = (r41.r4) << 13 *)
      (*   r4 &= redmask *)
      (*   r4 += r31 *)
bvConcatShl r41 r4 (bvVar r41) (bvVar r4) (fromNat 13);
bvAdd r4 (bvVar r4) (bvVar r31);
      (*   r41 = r41 * 19 *)
bvMul r41 (bvVar r41) (bvConst (fromPosZ 19%Z));
      (*   r0 += r41 *)
bvAdd r0 (bvVar r0) (bvVar r41);
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (*   t = r0 *)
      (*   (uint64) t >>= 51 *)
      (*   t += r1 *)
      (*   r0 &= redmask *)
bvAssign t (bvVar r0);
bvSplit t tmp (bvVar t) (fromNat 51);
bvAdd t (bvVar t) (bvVar r1);
bvAssign r0 (bvVar tmp);
      (*    *)
      (*   r1 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t += r2 *)
      (*   r1 &= redmask *)
bvAssign r1 (bvVar t);
bvSplit t tmp (bvVar t) (fromNat 51);
bvAdd t (bvVar t) (bvVar r2);
bvAssign r1 (bvVar tmp);
      (*    *)
      (*   r2 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t += r3 *)
      (*   r2 &= redmask *)
bvAssign r2 (bvVar t);
bvSplit t tmp (bvVar t) (fromNat 51);
bvAdd t (bvVar t) (bvVar r3);
bvAssign r2 (bvVar tmp);
      (*    *)
      (*   r3 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t += r4 *)
      (*   r3 &= redmask *)
bvAssign r3 (bvVar t);
bvSplit t tmp (bvVar t) (fromNat 51);
bvAdd t (bvVar t) (bvVar r4);
bvAssign r3 (bvVar tmp);
      (*    *)
      (*   r4 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t *= 19 *)
      (*   r0 += t *)
      (*   r4 &= redmask *)
bvAssign r4 (bvVar t);
bvSplit t tmp (bvVar t) (fromNat 51);
bvMul t (bvVar t) (bvConst (fromPosZ 19%Z));
bvAdd r0 (bvVar r0) (bvVar t);
bvAssign r4 (bvVar tmp);
      (*   #END MACRO  *)
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (* *[uint64 *](rp + 0) = r0 *)
bvAssign z0 (bvVar r0);
      (* *[uint64 *](rp + 8) = r1 *)
bvAssign z1 (bvVar r1);
      (* *[uint64 *](rp + 16) = r2 *)
bvAssign z2 (bvVar r2);
      (* *[uint64 *](rp + 24) = r3 *)
bvAssign z3 (bvVar r3);
      (* *[uint64 *](rp + 32) = r4 *)
bvAssign z4 (bvVar r4)
      (*   *)
      (*  *)
      (* c1 =c1_stack *)
      (* c2 =c2_stack *)
      (* c3 =c3_stack *)
      (* c4 =c4_stack *)
      (* c5 =c5_stack *)
      (* c6 =c6_stack *)
      (* c7 =c7_stack *)
      (*  *)
      (* leave *)
] .

Definition fe25519_sq_inputs : VS.t :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
VSLemmas.OP.P.of_list [:: x0; x1; x2; x3; x4].

Definition fe25519_sq_pre : bexp :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
bvrands
  [::
     (bvrvar x0) <r (bvposz (2^54)%Z);
     (bvrvar x1) <r (bvposz (2^54)%Z);
     (bvrvar x2) <r (bvposz (2^54)%Z);
     (bvrvar x3) <r (bvposz (2^54)%Z);
     (bvrvar x4) <r (bvposz (2^54)%Z)
  ].

Definition radix51 := @limbs 51.

Definition fe25519_sq_post : bexp :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
let            z0 :=   5 in
let            z1 :=   6 in
let            z2 :=   7 in
let            z3 :=   8 in
let            z4 :=   9 in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
bvands2
  [::
     bveEqMod
     (bvesq (radix51 [::bvevar x0; bvevar x1; bvevar x2; bvevar x3; bvevar x4]))
     (radix51 [::bvevar z0; bvevar z1; bvevar z2; bvevar z3; bvevar z4])
     (bvconst n25519)
  ]
  [::
     (bvrvar z0) <=r (bvposz (2^51+2^15)%Z);
     (bvrvar z1) <=r (bvposz (2^51+2^15)%Z);
     (bvrvar z2) <=r (bvposz (2^51+2^15)%Z);
     (bvrvar z3) <=r (bvposz (2^51+2^15)%Z);
     (bvrvar z4) <=r (bvposz (2^51+2^15)%Z)
  ].

Definition fe25519_sq_spec :=
  {| spre := fe25519_sq_pre;
     sprog := fe25519_sq;
     spost := fe25519_sq_post |}.

Lemma valid_fe25519_sq : valid_bvspec (fe25519_sq_inputs, fe25519_sq_spec).
Proof.
  time "valid_fe25519_sq" verify_bvspec.
Qed.

Close Scope bvdsl_scope.
Close Scope N_scope.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.CCC.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.
From Categories Require Import Basic_Cons.Terminal.
From Categories Require Import PreSheaf.PreSheaf.

Section Terminal.
  Context (C : Category).

  (** The terminal element of the category of presheaves. *)
  Program Definition PSh_Term_PreSheaf : Functor (C^op) Type_Cat :=
    {|
      FO := fun _ => unit
    |}.

  Local Hint Resolve NatTrans_eq_simplify : core.
  Local Hint Extern 1 =>
  match goal with
    [|- ?A = ?B] => try destruct A; try destruct B; trivial; fail
  end : core.

  (** The functor that maps to the unit type in coq is the terminal object
      of presheaves. *)
  Program Instance PSh_Terminal : (𝟙_ (PShCat C))%object :=
    {
      terminal := PSh_Term_PreSheaf;
      t_morph := fun _ => {|Trans := fun _ _ => tt|}
    }.

End Terminal.


Require Import List. Import ListNotations.
Require Import sha.general_lemmas.
Require Import sha.ByteBitRelations.
Require Import sha.HMAC_spec_concat.
Require Import sha.HMAC_spec_pad.

(*SHA256-specific files*)
Require Import sha.sha_padding_lemmas. (*for pad.*)
Require Import sha.ShaInstantiation.

Lemma sha_splitandpad_fpad : forall (l m : Blist),
                  length l = b ->
                  InBlocks 8 m ->
                  sha_splitandpad (l ++ m) = l ++ HMAC_Concat.app_fpad fpad m.
Proof.
  intros l m len len_m.
  unfold HMAC_Concat.app_fpad.
  unfold sha_splitandpad. unfold fpad.
  unfold pad. unfold fpad_inner.

  rewrite -> bitsToBytes_app.
  repeat rewrite -> bytesToBits_app.
  repeat rewrite -> bits_bytes_bits_id.
  rewrite <- app_assoc.
  rewrite -> sublist.Zlength_app.
  repeat f_equal.

  * apply bitsToBytes_len. apply len.
  * apply bitsToBytes_len. apply len.
  * apply bitsToBytes_len. apply len.
  * apply len_m.
  * apply block_8. apply len.
  * apply block_8. apply len.
Qed.

Theorem HMAC_concat_pad_sap_instantiated
        h (HH: forall x y, length x = c -> length y = b -> length (h x y)  = c)
        iv (IV: length iv = c) (op ip : Blist) (IL: length ip = b) (OL: length op = b)
        : forall (k m : Blist), length k = b ->
  sha.HMAC_spec_pad.HMAC c p B h iv sha_splitandpad op ip k m =
  HMAC_Concat.HMAC c p B h iv sha_splitandpad_inc fpad op ip k m.
Proof. intros.
  apply HMAC_Concat.HMAC_concat_pad; trivial.
  exists 32%nat. reflexivity.
  apply sha_splitandpad_app.
  apply sha_splitandpad_fpad.
  apply sha_splitandpad_inc_InBlocks.
Qed.

Theorem HMAC_concat_pad_explicit : forall (k m : Blist) (op ip : Blist),
                            length k = b ->
                            length ip = b ->
                            length op = b ->
  sha.HMAC_spec_pad.HMAC c p B sha_h sha_iv sha_splitandpad op ip k m =
  HMAC_Concat.HMAC c p B sha_h sha_iv sha_splitandpad_inc fpad op ip k m.
Proof.
  intros k m op ip len_k len_ip len_op.
  apply HMAC_concat_pad_sap_instantiated; trivial.
    apply sha_h_length.
Qed.


Require Import SepLogicTC.Heap.

Open Scope heap_scope.

(* Define a simple language that models heap operations: *)
Inductive cmd : Set -> Type :=
  | Return {S : Set} (r : S) : cmd S
  | Bind {Res Res' : Set}
         (c1 : cmd Res')
         (c2 : Res' -> cmd Res) : cmd Res
  | Read (S : Set) (p : nat) : cmd S
  | Write (p : nat) {S : Set} (v : S) : cmd unit
  | Alloc {S : Set} (v : S) : cmd nat
  | Free (S : Set) (p : nat) : cmd unit.

Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2))
                           (right associativity, at level 80) : hoare_scope.
Notation "c1 ;; c2" := (Bind c1 (fun _ => c2))
                       (right associativity, at level 80) : hoare_scope.

Reserved Notation "{{ P }} c {{ r , Q }}" (at level 90, c at next level).

(* Fairly standard definition of Hoare triples, loosely based on Chapter 14 of
   "Formal Reasoning About Programs" by Adam Chlipala, 2015-2017:
   (see also: https://github.com/achlipala/frap/blob/master/SeparationLogic.v)
*)
Inductive hoare_triple : forall {res : Set},
  hass -> cmd res -> (res -> hass) -> Prop :=
  | HtReturn : forall {res : Set} {v : res},
               {{emp}} (Return v) {{r, <[ r = v ]>}}
  | HtBind : forall P {res' res} (c1 : cmd res') (c2 : res' -> cmd res) Q R,
             {{P}} c1 {{r, Q r}} ->
             (forall s, {{Q s}} (c2 s) {{r, R r}}) ->
             {{P}} (x <- c1; c2 x) {{r, R r}}
  | HtRead : forall {S : Set} a P,
             {{exist v, [[a |-> v]] * P v}} (Read S a) {{r, [[a |-> r]] * P r}}
  | HtWrite : forall {S : Set} a (w : S),
              {{exist (v:S), [[a |-> v]]}} (Write a w) {{_, [[a |-> w]]}}
  | HtAlloc : forall {S : Set} (v : S),
              {{emp}} (Alloc v) {{p, <[p <> 0]> * [[p |-> v]]}}
  | HtFree : forall {S : Set} p,
             {{exist (v:S), [[p |-> v]]}} (Free S p) {{_, emp}}
  | HtConsequence : forall {res} (c : cmd res) P Q
                                               (P' : hass) (Q' : _ -> hass),
                    {{P}} c {{r, Q r}} ->
                    P' ==> P ->
                    (forall r, Q r ==> Q' r) ->
                    {{ P' }} c {{r, Q' r}}
  | HtFrame : forall {res} (c : cmd res) P Q R,
              {{P}} c {{r , Q r}} ->
              {{P * R}} c {{r , Q r * R}}

where "{{ P }} c {{ r , Q }}" := (hoare_triple P c (fun r => Q))
                                 : hoare_scope.

Lemma hoare_equiv_left' {res : Set} : forall P Q (R : res -> hass) c,
  P === Q -> hoare_triple Q c R -> hoare_triple P c R.
Proof with auto.
  intuition.
  apply hass_equiv_imply in H.
  apply (HtConsequence c Q R P R H0) in H...
  intro r; apply hass_imply_taut.
Qed.

Lemma hoare_equiv_left {res : Set} : forall P Q (R : res -> hass) c,
  P === Q -> (hoare_triple Q c R <-> hoare_triple P c R).
Proof with auto.
  intuition; eapply hoare_equiv_left'.
  + exact H...
  + auto.
  + apply hass_equiv_symm in H. exact H.
  + auto.
Qed.

Lemma hoare_equiv_right' {res : Set} : forall P (Q R : res -> hass) c,
  (forall r, Q r === R r) -> hoare_triple P c Q -> hoare_triple P c R.
Proof with auto.
  intuition.
  apply (HtConsequence c P Q P R) in H0...
  apply hass_imply_taut...
  intro r; specialize H with r; apply hass_equiv_imply...
Qed.

Lemma hoare_equiv_right {res : Set} : forall P (Q R : res -> hass) c,
  (forall r, Q r === R r) -> (hoare_triple P c Q <-> hoare_triple P c R).
Proof with auto.
  intuition; eapply hoare_equiv_right'.
  + exact H.
  + auto.
  + intro r. apply hass_equiv_symm...
  + auto.
Qed.

Lemma hoare_frame_left {res : Set} : forall P (Q : res -> hass) R c,
  hoare_triple P c Q -> hoare_triple (R*P) c (fun r => R*(Q r)).
Proof with auto.
  intuition.
  eapply hoare_equiv_left'. exact (sep_comm R P).

  assert(forall r, (fun x => R * Q x) r === (fun x => (Q x) * R) r).
    intro r. apply sep_comm.
  eapply hoare_equiv_right' with (Q0 := fun x => (Q x) * R).
  + intro r. simpl. apply sep_comm.
  + apply HtFrame. apply H.
Qed.

Lemma hoare_cancel_empty_left {res : Set} : forall P (Q : res -> hass) c,
  hoare_triple (emp*P) c (fun r => emp*(Q r)) -> hoare_triple P c Q.
Proof.
  intuition.
  pose proof (sep_empty_neutral_left P).
  apply hass_equiv_symm in H0. apply (hoare_equiv_left' _ _ Q c H0).
  assert(forall r, emp * (Q r) === Q r).
    intro r. apply sep_empty_neutral_left...
  eapply hoare_equiv_right'.
    intro r. exact (H1 r).
  exact H.
Qed.

Lemma hoare_cancel_empty_left_pre {res : Set} : forall P (Q : res -> hass) c,
  hoare_triple (emp*P) c (fun r => (Q r)) -> hoare_triple P c Q.
Proof.
  intuition.
  pose proof (sep_empty_neutral_left P).
  apply hass_equiv_symm in H0. apply (hoare_equiv_left' _ _ Q c H0).
  exact H.
Qed.

Lemma hoare_cancel_empty_right {res : Set} : forall P (Q : res -> hass) c,
  hoare_triple (P*emp) c (fun r => (Q r)*emp) -> hoare_triple P c Q.
Proof.
  intuition.
  pose proof (sep_empty_neutral_right P).
  apply hass_equiv_symm in H0. apply (hoare_equiv_left' _ _ Q c H0).
  assert(forall r, (Q r)*emp === Q r).
    intro r. apply sep_empty_neutral_right...
  eapply hoare_equiv_right'.
    intro r. exact (H1 r).
  exact H.
Qed.

Lemma hoare_cancel_empty_right_pre {res : Set} : forall P (Q : res -> hass) c,
  hoare_triple (P*emp) c (fun r => (Q r)) -> hoare_triple P c Q.
Proof.
  intuition.
  pose proof (sep_empty_neutral_right P).
  apply hass_equiv_symm in H0. apply (hoare_equiv_left' _ _ Q c H0).
  exact H.
Qed.

Lemma hoare_return {res : Set} : forall (P : hass) (v : res),
  hoare_triple P (Return v) (fun r => P * <[r = v]>).
Proof with auto.
  intuition.
  apply hoare_cancel_empty_right_pre.
  apply hoare_frame_left.
  apply HtReturn.
Qed.

Open Scope hoare_scope.

Lemma hoare_read : forall {S : Set} p v,
  {{[[p |-> v]]}} (Read S p) {{r, [[p |-> v]] * <[r = v]>}}.
Proof with auto.
  intuition.
  eapply HtConsequence with (P := exist w, [[p |-> w]] * <[w = v]>).
  + apply HtRead.
  + unfold ex, imply, sep. intuition.
    exists v, h, empty. intuition...
    - apply disj_empty_neutral_right.
    - rewrite union_empty_neutral_right...
    - unfold pure...
  + unfold imply, sep.
    firstorder; subst.
    exists x, empty; firstorder.
Qed.

Lemma hoare_read_frame_right : forall {S : Set} p (v : S) P,
  {{[[p |-> v]] * P}} (Read S p) {{r, [[p |-> v]] * <[r = v]> * P}}.
Proof with auto.
  intuition.
  eapply HtFrame.
  apply hoare_read.
Qed.

Lemma hoare_read_frame_left' : forall {S : Set} p (v : S) P,
  {{P * [[p |-> v]]}} (Read S p) {{r, P * ([[p |-> v]] * <[r = v]>)}}.
Proof with auto.
  intuition.
  eapply hoare_frame_left.
  apply hoare_read.
Qed.

Lemma hoare_read_frame_left : forall {S : Set} p (v : S) P,
  {{P * [[p |-> v]]}} (Read S p) {{r, P * [[p |-> v]] * <[r = v]>}}.
Proof with auto.
  intuition.
  eapply HtConsequence with (Q := fun r => P * ([[p |-> v]] * <[r = v]>)).
  + apply hoare_read_frame_left'.
  + apply hass_imply_taut.
  + intro r.
    unfold imply, sep.
    firstorder; subst.
    exists (union x x1), empty; firstorder.
    - inversion H0.
    - repeat rewrite union_empty_neutral_right...
    - exists x, x1; firstorder.
      * destruct (x1 n) eqn:?...
        assert(union x1 empty n = None) by firstorder.
        unfold union in H4; rewrite Heqo in H4...
      * apply H3. exists x0. unfold union. rewrite H0...
Qed.

Ltac hoare_false_pre_subgoal tac :=
   eapply HtConsequence ;
   (apply HtFrame; apply tac) ||
   (apply hass_ex_falso) ||
   (intuition; apply hass_ex_falso_framed_left).

Lemma hoare_false_pre {S : Set} : forall (c : cmd S) (Q : S -> hass),
  {{<[False]>}} c {{r, Q r}}.
Proof with auto.
  intros c Q. induction c.
  + hoare_false_pre_subgoal (@HtReturn S).
  + apply HtBind with (Q := fun _ => <[False]>).
    - apply IHc.
    - intro; apply H.
  + hoare_false_pre_subgoal (@HtRead S).
  + hoare_false_pre_subgoal (@HtWrite S).
  + hoare_false_pre_subgoal (@HtAlloc S).
  + hoare_false_pre_subgoal (@HtFree S).
  Unshelve. exact Q.
Qed.

Lemma hoare_false_pre' {res : Set} : forall (c : cmd res) P Q,
  P ==> <[False]> -> {{P}} c {{r, Q r}}.
Proof with auto.
  intros.
  eapply HtConsequence.
  + apply hoare_false_pre.
  + exact H.
  + intro r. apply hass_imply_taut.
Qed.

Close Scope hoare_scope.
Close Scope heap_scope.


(***************************************************************************
* Basic properties of target language                                      *
* William J. Bowman, Phillip Mates & James T. Perconti                     *
***************************************************************************)

Require Import LibWfenv Target_Definitions Core_Infrastructure.

(* ********************************************************************** *)

(* Regularity of t_wft *)

Lemma t_wft_implies_ok : forall D t, t_wft D t -> ok D.
Proof.
  induction 1; auto.
  pick_fresh X. assert (ok (D & X ~ star)); auto.
Qed.

Lemma t_wft_implies_t_type : forall D t, t_wft D t -> t_type t.
Proof. induction 1; eauto. Qed.
Hint Resolve t_wft_implies_ok t_wft_implies_t_type.

(* Weakening for t_wft *)

Lemma t_wft_weaken_generalized : forall G T E F,
  t_wft (E & G) T -> ok (E & F & G) ->
  t_wft (E & F & G) T.
Proof.
  intros. gen_eq K: (E & G). gen E F G.
  induction H; intros; subst; eauto.
  apply* t_wft_var. apply* binds_weaken.
  apply_fresh* t_wft_arrow as Y. apply_ih_bind* H0. apply_ih_bind* H2.
Qed.

Lemma t_wft_weaken : forall T E F,
  t_wft E T -> ok (E & F) -> t_wft (E & F) T.
Proof.
  intros. rewrite <- (concat_empty_r (E & F)).
  apply t_wft_weaken_generalized; rewrite* concat_empty_r.
Qed.

Lemma wfenv_t_wft_weaken : forall D X G,
  wfenv (t_wft D) G -> ok (D & X ~ star) -> wfenv (t_wft (D & X ~ star)) G.
Proof.
  intros. apply* (wfenv_implies (t_wft D)). intros. apply* t_wft_weaken.
Qed.

(* t_wft and free variables *)

Lemma t_wft_fv_tt : forall t D X,
  t_wft D t -> X \in fv_tt t -> X \in dom D.
Proof.
  intros D t X wft. gen X.
  induction wft; simpl; intros; auto.
  rewrite in_singleton in H1. subst. apply* get_some_inv.
  false. apply* in_empty_elim.
  rewrite in_union in H. intuition.
  pick_fresh Y. assert (X \in dom (D & Y ~ star)).
    rewrite in_union in H3. destruct H3.
    assert (fv_tt (open_tt_var t1 Y) = fv_tt t1 \u \{Y} \/ fv_tt (open_tt_var t1 Y) = fv_tt t1).
      apply open_tt_var_fv_tt.
    apply* H0. destruct H4; rewrite* H4. rewrite in_union. left*.
    assert (fv_tt (open_tt_var t2 Y) = fv_tt t2 \u \{Y} \/ fv_tt (open_tt_var t2 Y) = fv_tt t2).
      apply open_tt_var_fv_tt.
    apply* H2. destruct H4; rewrite* H4. rewrite in_union. left*.
    rewrite dom_push in H4. rewrite in_union in H4. destruct* H4.
      false. rewrite in_singleton in H4. subst*.
      apply Fr. repeat rewrite in_union. left. left. left. right. apply in_singleton_self.
Qed.

Lemma t_wft_fv_tt_inv : forall t D X,
  t_wft D t -> X \notin dom D -> X \notin fv_tt t.
Proof.
  intros. intro. apply (t_wft_fv_tt t D) in H1; intuition.
Qed.

(*    eapply get_some_inv. eapply binds_push_neq_inv with (x2 := Y); eauto. *)

(* Basic properties of subst_tt and open_tt *)

Lemma open_tt_rec_t_type_core : forall t j t' t'' i, i <> j ->
  open_tt_rec i t'' (open_tt_rec j t' t) = open_tt_rec j t' t ->
  open_tt_rec i t'' t = t.
Proof.
  induction t; intros; simpl in *; inversion H0; f_equal*.
  case_if*. apply EqNat.beq_nat_true in H1. subst.
  case_if*. apply EqNat.beq_nat_true in H1. false.
  simpl in *. case_if*. apply EqNat.beq_nat_false in H3. false.
Qed.

Lemma open_tt_rec_t_type : forall t t' n, t_type t ->
  open_tt_rec n t' t = t.
Proof.
  intros; gen t' n; induction H; intros; simpl in *; f_equal; auto;
  subst; pick_fresh X;
  apply open_tt_rec_t_type_core with (j := 0) (t' := t_typ_fvar X); auto.
Qed.

Lemma open_tt_rec_t_almost_type : forall t t' t'' i,
  t_type (open_tt t t') -> open_tt_rec (S i) t'' t = t.
Proof.
  intros. apply* (open_tt_rec_t_type_core t 0 t'). apply* open_tt_rec_t_type.
Qed.

Lemma subst_tt_open_tt_rec : forall t t' n d, wfenv t_type d ->
  subst_tt d (open_tt_rec n t' t) =
  open_tt_rec n (subst_tt d t') (subst_tt d t).
Proof.
  induction t; intros; auto; simpl; try f_equal; auto.
  case_if*. cases* (get v d).
  rewrite* open_tt_rec_t_type. apply* (wfenv_binds t_type d v).
Qed.

Lemma subst_tt_open_tt : forall t t' d, wfenv t_type d ->
  subst_tt d (open_tt t t') =
  open_tt (subst_tt d t) (subst_tt d t').
Proof.
  intros. apply* subst_tt_open_tt_rec.
Qed.

Lemma subst_tt_open_tt_var : forall t X d, X # d -> wfenv t_type d ->
  (open_tt_var (subst_tt d t) X) = (subst_tt d (open_tt_var t X)).
Proof.
  intros. simpl. rewrite* subst_tt_open_tt. simpl.
  apply get_none in H. rewrite* H.
Qed.

Lemma subst_tt_intro_rec : forall X t t' n,
  X \notin fv_tt t -> t_type t' ->
  open_tt_rec n t' t = subst_tt (X ~ t') (open_tt_rec n (t_typ_fvar X) t).
Proof.
  intros X t. gen X. induction t; intros; auto; simpl in *; try f_equal; auto.
  cases_if*. simpl. rewrite get_single. cases_if*.
  rewrite get_single. cases_if*. false. apply* notin_same.
Qed.

Lemma subst_tt_intro : forall X t t',
  X \notin fv_tt t -> t_type t' ->
  open_tt t t' = subst_tt (X ~ t') (open_tt_var t X).
Proof.
  intros. apply* subst_tt_intro_rec.
Qed.

Lemma t_open_tt_rec_open_tt_rec : forall t i j t1 t2,
  i <> j -> t_type t1 -> t_type t2 ->
  open_tt_rec i t1 (open_tt_rec j t2 t) = open_tt_rec j t2 (open_tt_rec i t1 t).
Proof.
  induction t; intros; simpl; auto; try solve [f_equal*].
  cases_if*.
    cases_if*.
      apply EqNat.beq_nat_true in H2. apply EqNat.beq_nat_true in H3. false.
      simpl. rewrite H2. rewrite* open_tt_rec_t_type.
    cases_if*.
      simpl. rewrite H3. rewrite* open_tt_rec_t_type.
      simpl. rewrite H2. rewrite* H3.
Qed.

(* XXX: unused *)
Lemma subst_tt_preserves_t_type : forall d t,
  t_type t -> wfenv t_type d -> t_type (subst_tt d t).
Proof.
  induction 1; intros; simpl; auto.
  cases* (get x d). eapply wfenv_binds; eassumption.
  apply_fresh t_type_arrow as X;
  replace (t_typ_fvar X) with (subst_tt d (t_typ_fvar X));
  try rewrite <- subst_tt_open_tt; auto; simpl;
  case_eq (get X d); intros; try apply binds_fresh_inv in H4;
  try contradiction; auto.
Qed.

(* subst_tt preserves t_wft *)

Lemma subst_tt_preserves_t_wft_generalized : forall D D' t X t',
  X # (D & D') -> t_wft (D & D') t' -> t_wft (D & X ~ star & D') t ->
  t_wft (D & D') (subst_tt (X ~ t') t).
Proof.
  intros. gen_eq DXD' : (D & X ~ star & D'). gen D X D'.
  induction H1; intros; subst; simpl; auto.
  rewrite get_single. cases_if*.
    apply* t_wft_var. apply* binds_subst.
  apply_fresh t_wft_arrow as Y;
  rewrite* subst_tt_open_tt_var. apply_ih_bind* H0. apply* t_wft_weaken.
  apply wfenv_single. apply* t_wft_implies_t_type.
  apply_ih_bind* H2. apply* t_wft_weaken.
  apply wfenv_single. apply* t_wft_implies_t_type.
Qed.

Lemma subst_tt_preserves_t_wft : forall D t X t',
  X # D -> t_wft D t' -> t_wft (D & X ~ star) t ->
  t_wft D (subst_tt (X ~ t') t).
Proof.
  intros.
  rewrite <- (concat_empty_r D). rewrite <- (concat_empty_r D) in H0.
  rewrite <- (concat_empty_r (D & X ~ star)) in H1.
  apply* subst_tt_preserves_t_wft_generalized.
Qed.

Lemma t_wft_arrow_apply : forall D t1 t2 t,
  t_wft D (t_typ_arrow t1 t2) -> t_wft D t ->
  t_wft D (open_tt t2 t).
Proof.
  intros. inverts H.
  pick_fresh X. rewrite* (subst_tt_intro X). apply* subst_tt_preserves_t_wft.
Qed.

(* Regularity of t_typing *)

Theorem t_typing_implies_ok : forall D G m t,
  t_typing D G m t -> ok D.
Proof.
  apply (t_typing_mut (fun D G m t pf => ok D)
                      (fun D G u t pf => ok D)); auto.
  intros. pick_fresh x. pick_fresh X. assert (ok (D & X ~ star)); auto.
  apply* (H x X).
Qed.

Corollary t_value_typing_implies_ok : forall D G u t,
  t_value_typing D G u t -> ok D.
Proof. eauto using t_typing_implies_ok. Qed.

Theorem t_typing_implies_wfenv : forall D G m t,
  t_typing D G m t -> wfenv (t_wft D) G.
Proof.
  apply (t_typing_mut (fun D G m t pf => wfenv (t_wft D) G)
                      (fun D G u t pf => wfenv (t_wft D) G)); auto.
Qed.

Corollary t_value_typing_implies_wfenv : forall D G u t,
  t_value_typing D G u t -> wfenv (t_wft D) G.
Proof. eauto using t_typing_implies_wfenv. Qed.

Theorem t_typing_implies_t_term : forall D G m t,
  t_typing D G m t -> t_term m.
Proof.
  apply (t_typing_mut (fun D G m t pf => t_term m)
                      (fun D G u t pf => t_value u)); eauto.
  intros. apply_fresh* t_value_abs as X.
  pick_fresh x.
  assert (wfenv (t_wft (D & X ~ star)) (G & x ~ open_tt t1 (t_typ_fvar X))).
    eapply t_typing_implies_wfenv. apply* t.
  apply wfenv_push_inv in H0. destructs* H0.
Qed.

Theorem t_value_typing_implies_t_value : forall D G u t,
  t_value_typing D G u t -> t_value u.
Proof.
  apply (t_value_typing_mut (fun D G m t pf => t_term m)
                            (fun D G u t pf => t_value u)); eauto.
  intros. apply_fresh* t_value_abs as X.
  pick_fresh x.
  assert (wfenv (t_wft (D & X ~ star)) (G & x ~ open_tt t1 (t_typ_fvar X))).
    eapply t_typing_implies_wfenv. apply* t.
  apply wfenv_push_inv in H0. destructs* H0.
Qed.

Hint Resolve t_typing_implies_t_term t_value_typing_implies_t_value.

Theorem t_typing_implies_t_wft : forall D G m t,
  t_typing D G m t -> t_wft D t.
Proof.
  apply (t_typing_mut (fun D G m t pf => t_wft D t)
                      (fun D G u t pf => t_wft D t)); intros; auto.
  pick_fresh x. apply* (H0 x).
  pick_fresh x. apply* (H0 x).
  apply* t_wft_arrow_apply.
  apply* (wfenv_binds (t_wft D)).
  pick_fresh x. apply_fresh t_wft_arrow as X; try (apply* (H x X)).
    assert (wfenv (t_wft (D & X ~ star)) (G & x ~ open_tt_var t1 X)).
      apply* t_typing_implies_wfenv.
    apply wfenv_push_inv in H0. destructs* H0.
Qed.

Corollary t_value_typing_implies_t_wft : forall D G u t,
  t_value_typing D G u t -> t_wft D t.
Proof. eauto using t_typing_implies_t_wft. Qed.

(* weakening for t_typing *)

Lemma t_typing_weaken_delta_generalized : forall D D' D'' G m t,
  t_typing (D & D'') G m t -> ok (D & D' & D'') ->
  t_typing (D & D' & D'') G m t.
Proof.
  intros. gen_eq DD : (D & D''). gen D D' D''.
  apply (t_typing_mut
          (fun DD G m t pf =>
            forall D D' D'', ok (D & D' & D'') -> DD = D & D'' ->
            t_typing (D & D' & D'') G m t)
          (fun DD G u t pf =>
            forall D D' D'', ok (D & D' & D'') -> DD = D & D'' ->
            t_value_typing (D & D' & D'') G u t));
  intros; subst; auto using t_wft_weaken_generalized;
  try (pick_fresh x; apply_fresh t_value_typing_abs as X);
  eauto using t_wft_weaken_generalized, (wfenv_implies (t_wft (D0 & D''))).
  intros. apply_ih_bind* H0.
Qed.

Lemma t_value_typing_weaken_delta_generalized : forall D D' D'' G u t,
  t_value_typing (D & D'') G u t -> ok (D & D' & D'') ->
  t_value_typing (D & D' & D'') G u t.
Proof.
  intros. gen_eq DD : (D & D''). gen D D' D''.
  apply (t_value_typing_mut
          (fun DD G m t pf =>
            forall D D' D'', ok (D & D' & D'') -> DD = D & D'' ->
            t_typing (D & D' & D'') G m t)
          (fun DD G u t pf =>
            forall D D' D'', ok (D & D' & D'') -> DD = D & D'' ->
            t_value_typing (D & D' & D'') G u t));
  intros; subst; auto using t_wft_weaken_generalized;
  try (pick_fresh x; apply_fresh t_value_typing_abs as X);
  eauto using t_wft_weaken_generalized, (wfenv_implies (t_wft (D0 & D''))).
  intros. apply_ih_bind* H0.
Qed.

Lemma t_typing_weaken_delta : forall D D' G m t,
  t_typing D G m t -> ok (D & D') -> t_typing (D & D') G m t.
Proof.
  intros. rewrite <- (concat_empty_r (D & D')) in *.
  apply* t_typing_weaken_delta_generalized. rewrite* concat_empty_r.
Qed.

Lemma t_value_typing_weaken_delta : forall D D' G u t,
  t_value_typing D G u t -> ok (D & D') -> t_value_typing (D & D') G u t.
Proof.
  intros. rewrite <- (concat_empty_r (D & D')) in *.
  apply* t_value_typing_weaken_delta_generalized. rewrite* concat_empty_r.
Qed.

Lemma t_typing_weaken_generalized : forall D G G' G'' m t,
  t_typing D (G & G'') m t -> wfenv (t_wft D) (G & G' & G'') ->
  t_typing D (G & G' & G'') m t.
Proof.
  intros. gen_eq GG : (G & G''). gen G G' G''.
  apply (t_typing_mut
          (fun D GG m t pf =>
            forall G G' G'', wfenv (t_wft D) (G & G' & G'') -> GG = G & G'' ->
            t_typing D (G & G' & G'') m t)
          (fun D GG u t pf =>
            forall G G' G'', wfenv (t_wft D) (G & G' & G'') -> GG = G & G'' ->
            t_value_typing D (G & G' & G'') u t));
  intros; subst; eauto.
  apply_fresh* t_typing_let_fst as x. apply_ih_bind* H1.
    apply wfenv_push; auto.
    apply t_value_typing_implies_t_wft in t3. inverts* t3.
  apply_fresh* t_typing_let_snd as x. apply_ih_bind* H1.
    apply wfenv_push; auto.
    apply t_value_typing_implies_t_wft in t3. inverts* t3.
  apply* t_value_typing_var. apply* binds_weaken. eapply wfenv_ok. eauto.
  apply_fresh* t_value_typing_abs as X. intros. apply_ih_bind* H0.
    apply wfenv_push; auto.
    apply* (wfenv_implies (t_wft D0)). eauto using t_wft_weaken.
    eapply wfenv_push_inv. eapply t_typing_implies_wfenv. apply* (t0 x X).
Qed.

Lemma t_value_typing_weaken_generalized : forall D G G' G'' u t,
  t_value_typing D (G & G'') u t -> wfenv (t_wft D) (G & G' & G'') ->
  t_value_typing D (G & G' & G'') u t.
Proof.
  intros. gen_eq GG : (G & G''). gen G G' G''.
  apply (t_value_typing_mut
          (fun D GG m t pf =>
            forall G G' G'', wfenv (t_wft D) (G & G' & G'') -> GG = G & G'' ->
            t_typing D (G & G' & G'') m t)
          (fun D GG u t pf =>
            forall G G' G'', wfenv (t_wft D) (G & G' & G'') -> GG = G & G'' ->
            t_value_typing D (G & G' & G'') u t));
  intros; subst; eauto.
  apply_fresh* t_typing_let_fst as x. apply_ih_bind* H1.
    apply wfenv_push; auto.
    apply t_value_typing_implies_t_wft in t3. inverts* t3.
  apply_fresh* t_typing_let_snd as x. apply_ih_bind* H1.
    apply wfenv_push; auto.
    apply t_value_typing_implies_t_wft in t3. inverts* t3.
  apply* t_value_typing_var. apply* binds_weaken. eapply wfenv_ok. eauto.
  apply_fresh* t_value_typing_abs as X. intros. apply_ih_bind* H0.
    apply wfenv_push; auto.
    apply* (wfenv_implies (t_wft D0)). eauto using t_wft_weaken.
    eapply wfenv_push_inv. eapply t_typing_implies_wfenv. apply* (t0 x X).
Qed.

Lemma t_typing_weaken : forall D G G' m t,
  t_typing D G m t -> wfenv (t_wft D) (G & G') -> t_typing D (G & G') m t.
Proof.
  intros. rewrite <- (concat_empty_r (G & G')) in *.
  apply* t_typing_weaken_generalized. rewrite* concat_empty_r.
Qed.

Lemma t_value_typing_weaken : forall D G G' u t,
  t_value_typing D G u t -> wfenv (t_wft D) (G & G') ->
  t_value_typing D (G & G') u t.
Proof.
  intros. rewrite <- (concat_empty_r (G & G')) in *.
  apply* t_value_typing_weaken_generalized. rewrite* concat_empty_r.
Qed.

(* basic properties of subst_ee and open_ee *)

Lemma open_ee_rec_t_term_core_1 : forall m j m' i m'', i <> j ->
  open_ee_rec target i m'' (open_ee_rec target j m' m) =
  open_ee_rec target j m' m ->
  open_ee_rec target i m'' m = m.
Proof.
  induction m; intros; simpl in *; inverts H0; f_equal*.
  case_if*. case_if*; simpl in *; try case_if*.
  apply EqNat.beq_nat_true in H0. apply EqNat.beq_nat_true in H1. intuition.
Qed.

Lemma open_ee_rec_t_term_core_2 : forall m i m' j t k m'', i <> k ->
  open_ee_rec target i m' (open_te_rec j t (open_ee_rec target k m'' m)) =
                           open_te_rec j t (open_ee_rec target k m'' m) ->
  open_ee_rec target i m' m = m.
Proof.
  induction m; intros; simpl in *; inverts H0; f_equal*.
  case_if*. case_if*; simpl in *; try case_if*.
  apply EqNat.beq_nat_true in H0. apply EqNat.beq_nat_true in H1. intuition.
Qed.

Lemma open_ee_rec_t_term : forall m m' i,
  t_term m -> open_ee_rec target i m' m = m.
Proof.
  intros. gen m' i.
  eapply (t_term_mut (fun m pf => forall m' i, open_ee_rec target i m' m = m)
                     (fun m pf => forall m' i, open_ee_rec target i m' m = m));
  intros; simpl in *; f_equal; auto;
  pick_fresh x; try (apply* (open_ee_rec_t_term_core_1 m0 0); apply* (H1 x)).
  pick_fresh X. eapply open_ee_rec_t_term_core_2; try apply* (H0 x X). auto.
Qed.

Lemma plug_t_term_open_ee_rec : forall C m i m', t_term m ->
  open_ee_rec target i m' (plug C m) = plug (ctx_open_ee_rec target i m' C) m.
Proof.
  induction C; intros; simpl; f_equal; auto using open_ee_rec_t_term.
Qed.

(* basic properties of subst_te and open_te *)

Lemma open_te_rec_t_term_core_1 : forall m j m' i t,
  open_te_rec i t (open_ee_rec target j m' m) = open_ee_rec target j m' m ->
  open_te_rec i t m = m.
Proof.
  induction m; intros; simpl in *; inverts H; f_equal*.
  rewrite* H1. rewrite* H2.
Qed.

Lemma open_te_rec_t_term_core_2 : forall m i t j t' k m', i <> j ->
  open_te_rec i t (open_te_rec j t' (open_ee_rec target k m' m)) =
                   open_te_rec j t' (open_ee_rec target k m' m) ->
  open_te_rec i t m = m.
Proof.
  induction m; intros; simpl in *; inverts H0; f_equal*.
  apply* (open_tt_rec_t_type_core t (S j)).
  apply* (open_tt_rec_t_type_core t j).
Qed.

Lemma open_te_rec_t_term : forall m t i,
  t_term m -> open_te_rec i t m = m.
Proof.
  intros. gen t i.
  apply (t_term_mut (fun m pf => forall t i, open_te_rec i t m = m)
                    (fun m pf => forall t i, open_te_rec i t m = m));
  intros; simpl in *; f_equal; auto;
  pick_fresh x; try (apply* open_te_rec_t_term_core_1; apply* (H1 x)).
  apply* open_tt_rec_t_type.
  pick_fresh X. eapply open_tt_rec_t_almost_type. apply* (t0 X).
  pick_fresh X. eapply open_te_rec_t_term_core_2; try apply* (H0 x X). auto.
Qed.

Lemma plug_t_term_open_te_rec : forall C m i t, t_term m ->
  open_te_rec i t (plug C m) = plug (ctx_open_te_rec i t C) m.
Proof.
  induction C; intros; simpl; f_equal; auto using open_te_rec_t_term.
Qed.

(* commute open_ee_rec and open_te_rec with themselves and each other *)

Lemma t_open_ee_rec_open_ee_rec : forall m i j m1 m2,
  i <> j -> t_term m1 -> t_term m2 ->
  open_ee_rec target i m1 (open_ee_rec target j m2 m) =
  open_ee_rec target j m2 (open_ee_rec target i m1 m).
Proof.
  induction m; intros; simpl; auto; try solve [f_equal*].
  cases_if*.
    cases_if*.
      apply EqNat.beq_nat_true in H2. apply EqNat.beq_nat_true in H3. subst. false.
      simpl. rewrite H2. rewrite* open_ee_rec_t_term.
    cases_if*.
      simpl. rewrite H3. rewrite* open_ee_rec_t_term.
      simpl. repeat cases_if*.
Qed.

Lemma t_open_ee_rec_open_te_rec : forall m i j m1 t,
  t_term m1 ->
  open_ee_rec target i m1 (open_te_rec j t m) =
  open_te_rec j t (open_ee_rec target i m1 m).
Proof.
  induction m; intros; simpl; auto; f_equal*.
  cases_if*. rewrite* open_te_rec_t_term.
Qed.

(* same lemma but in reverse for convenience *)
Lemma t_open_te_rec_open_ee_rec : forall m i j m1 t,
  t_term m1 ->
  open_te_rec j t (open_ee_rec target i m1 m) =
  open_ee_rec target i m1 (open_te_rec j t m).
Proof.
  induction m; intros; simpl; auto; f_equal*.
  cases_if*. rewrite* open_te_rec_t_term.
Qed.

Lemma t_open_te_rec_open_te_rec : forall m i j t1 t2,
  i <> j -> t_type t1 -> t_type t2 ->
  open_te_rec i t1 (open_te_rec j t2 m) = open_te_rec j t2 (open_te_rec i t1 m).
Proof.
  induction m; intros; simpl; auto; f_equal; auto using t_open_tt_rec_open_tt_rec.
Qed.

(* regularity of t_context_typing *)

Theorem t_context_typing_implies_ok_hole : forall b C Dh Gh th D G t,
  t_context_typing b C Dh Gh th D G t -> ok Dh.
Proof.
  apply (t_context_typing_mut (fun b C Dh Gh th D G t pf => ok Dh)
                              (fun b C Dh Gh th D G t pf => ok Dh));
  intros; eauto;
  pick_fresh x; pick_fresh X; try apply* (H x X); apply* (H x).
Qed.

Theorem t_context_typing_implies_wfenv_hole : forall b C Dh Gh th D G t,
  t_context_typing b C Dh Gh th D G t -> wfenv (t_wft Dh) Gh.
Proof.
  apply (t_context_typing_mut
          (fun b C Dh Gh th D G t pf => wfenv (t_wft Dh) Gh)
          (fun b C Dh Gh th D G t pf => wfenv (t_wft Dh) Gh)); intros; eauto;
  pick_fresh x; pick_fresh X; try apply* (H x X); apply* (H x).
Qed.

Theorem t_context_typing_implies_t_wft_hole : forall b C Dh Gh th D G t,
  t_context_typing b C Dh Gh th D G t -> t_wft Dh th.
  apply (t_context_typing_mut (fun b C Dh Gh th D G t pf => t_wft Dh th)
                              (fun b C Dh Gh th D G t pf => t_wft Dh th));
  intros; eauto;
  pick_fresh x; pick_fresh X; try apply* (H x X); apply* (H x).
Qed.

Theorem t_context_typing_implies_ok : forall b C Dh Gh th D G t,
  t_context_typing b C Dh Gh th D G t -> ok D.
Proof.
  apply (t_context_typing_mut (fun b C Dh Gh th D G t pf => ok D)
                              (fun b C Dh Gh th D G t pf => ok D));
  intros; eauto; pick_fresh x; pick_fresh X; try apply* (H x).
  eapply ok_push_inv_ok. apply* (H x X).
Qed.

Theorem t_context_typing_implies_wfenv : forall b C Dh Gh th D G t,
  t_context_typing b C Dh Gh th D G t -> wfenv (t_wft D) G.
Proof.
  apply (t_context_typing_mut
          (fun b C Dh Gh th D G t pf => wfenv (t_wft D) G)
          (fun b C Dh Gh th D G t pf => wfenv (t_wft D) G)); intros; eauto;
  pick_fresh x; eapply wfenv_push_inv_wfenv; apply* (H x).
Qed.

Theorem t_context_typing_implies_t_wft : forall b C Dh Gh th D G t,
  t_context_typing b C Dh Gh th D G t -> t_wft D t.
Proof.
  apply (t_context_typing_mut (fun b C Dh Gh th D G t pf => t_wft D t)
                              (fun b C Dh Gh th D G t pf => t_wft D t));
  intros; eauto using t_typing_implies_t_wft;
  try apply* t_wft_weaken;
  try (pick_fresh x; apply* (H x)).
  pick_fresh x. eauto using t_typing_implies_t_wft, (t3 x).
  pick_fresh x. eauto using t_typing_implies_t_wft, (t3 x).
  inverts H. pick_fresh X. rewrite* (subst_tt_intro X).
    apply* subst_tt_preserves_t_wft.
  apply t_value_typing_implies_t_wft in t0. inverts t0.
    pick_fresh X. rewrite* (subst_tt_intro X).
    apply* subst_tt_preserves_t_wft.
  pick_fresh x. apply_fresh t_wft_arrow as X.
    eapply wfenv_binds. eapply t_context_typing_implies_wfenv.
      apply* (t x X). auto.
    apply* (H x X).
Qed.

Theorem t_context_typing_implies_t_context : forall b C Dh Gh th D G t,
  t_context_typing b C Dh Gh th D G t -> t_context b C.
Proof.
  eapply (t_context_typing_mut
           (fun b C Dh Gh th D G t pf => t_context b C)
           (fun b C Dh Gh th D G t pf => t_value_context b C)); intros; eauto.
  pick_fresh x. apply_fresh* t_value_context_abs as X.
  assert (IH : wfenv (t_wft (D & X ~ star)) (G & x ~ open_tt_var t1 X)).
    eapply t_context_typing_implies_wfenv. apply* (t x X).
  apply wfenv_push_inv in IH. destructs IH. apply* t_wft_implies_t_type.
Qed.

(* other properties of contexts *)

Theorem t_eval_context_implies_t_context : forall E,
 t_eval_context E -> t_context false E.
Proof. intros. inverts* H. Qed.

Theorem plug_preserves_t_term : forall b C m,
  t_context b C -> (if b then t_value m else t_term m) -> t_term (plug C m).
Proof.
  intros b C m.
  apply (t_context_mut (fun b C pf => (if b then t_value m else t_term m) ->
                          t_term (plug C m))
                       (fun b C pf => (if b then t_value m else t_term m) ->
                          t_value (plug C m)));
  intros; simpl; auto;
  try apply_fresh* t_term_let_fst as x; try apply_fresh* t_term_let_snd as x;
  try (pick_fresh x; apply_fresh* t_value_abs as X; intros);
  try rewrite* plug_t_term_open_ee_rec; try rewrite* plug_t_term_open_te_rec;
  case_if*.
Qed.

Theorem plug_preserves_t_typing : forall b C e D_e G_e t_e D G t,
  t_context_typing b C D_e G_e t_e D G t ->
  (if b then t_value_typing D_e G_e e t_e else t_typing D_e G_e e t_e) ->
  t_typing D G (plug C e) t.
Proof.
  intros b C e.
  apply (t_context_typing_mut
           (fun b C D_e G_e t_e D G t pf =>
             (if b then t_value_typing D_e G_e e t_e
                   else t_typing D_e G_e e t_e) ->
             t_typing D G (plug C e) t)
           (fun b C D_e G_e t_e D G t pf =>
             (if b then t_value_typing D_e G_e e t_e
                   else t_typing D_e G_e e t_e) ->
             t_value_typing D G (plug C e) t));
  intros; simpl; auto.
  apply* t_typing_weaken. apply* t_typing_weaken_delta. case_if*.
  case_if*.
  apply_fresh* t_typing_let_fst as x. rewrite* plug_t_term_open_ee_rec.
    case_if*.
  case_if*.
  apply_fresh* t_typing_let_snd as x. rewrite* plug_t_term_open_ee_rec.
    case_if*.
  case_if*.
  case_if*.
  apply* t_value_typing_weaken. apply* t_value_typing_weaken_delta.
  pick_fresh x. apply_fresh* t_value_typing_abs as X. intros.
    rewrite* plug_t_term_open_ee_rec; case_if*; rewrite* plug_t_term_open_te_rec.
Qed.


Require Export Iron.Language.SystemF2Effect.Step.Frame.

(********************************************************************)
(* Region identifier is not mentioned some FPriv frame. *)
Fixpoint NoPrivF (p : nat) (f : frame) {struct f} :=
 match f with
 | FLet t x               => True
 | FPriv None p1          => ~(p = p1)
 | FPriv (Some p1) p2     => ~(p = p1) /\ ~(p = p2)
 end.

Definition NoPrivFs (p : nat) (fs : stack)
 := Forall (NoPrivF p) fs.

Lemma noprivFs_head
 :  forall p fs f
 ,  NoPrivFs p (fs :> f)
 -> NoPrivF  p f.
Proof.
 intros. inverts H. eauto.
Qed.
Hint Resolve noprivFs_head.

Lemma noprivFs_tail
 :  forall p fs f
 ,  NoPrivFs p (fs :> f)
 -> NoPrivFs p fs.
Proof.
 intros. inverts H. eauto.
Qed.
Hint Resolve noprivFs_tail.

(********************************************************************)
(* Region identifier is not mentioned in the given stack frame. *)
Fixpoint FreshF (p : nat) (ff : frame) {struct ff} :=
 match ff with
 | FLet  t x           => FreshT p t /\ FreshX p x
 | FPriv None      p2  => ~(p = p2)
 | FPriv (Some p1) p2  => ~(p = p1)  /\ ~(p = p2)
 end.

(* Region identifier is not mentioned in the given stack.  *)
Definition FreshFs (p : nat) (fs : stack)
 := Forall (FreshF p) fs.
Hint Unfold FreshFs.

Lemma freshFs_head
 :  forall p f fs
 ,  FreshFs p (fs :> f)
 -> FreshFs p fs.
Proof. intros. inverts H. eauto. Qed.
Hint Resolve freshFs_head.

Lemma freshFs_tail
 :  forall p f fs
 ,  FreshFs p (fs :> f)
 -> FreshF  p f.
Proof. intros. inverts H. eauto. Qed.
Hint Resolve freshFs_tail.

Lemma freshFs_cons
 :  forall p f fs
 ,  FreshFs p fs -> FreshF p f
 -> FreshFs p (fs :> f).
Proof. snorm. Qed.
Hint Resolve freshFs_cons.

Lemma freshF_noprivF
 : forall p f
 , FreshF p f -> NoPrivF p f.
Proof.
 intros.
 destruct f.
 - snorm.
 - destruct o; snorm.
Qed.
Hint Resolve freshF_noprivF.

Lemma freshFs_noprivFs
 : forall  p fs
 , FreshFs p fs -> NoPrivFs p fs.
Proof.
 intros.
 induction fs.
 - unfold NoPrivFs. eauto.
 - unfold NoPrivFs. inverts H. firstorder.
Qed.
Hint Resolve freshFs_noprivFs.

(*********************************************************************)
(* Region identifier is not mentioned in the types of the free variables
   of the given stack frame. *)
Fixpoint   FreshFreeF (p : nat) (te : tyenv) (f : frame) {struct f} :=
 match f with
 | FLet t x       => FreshFreeX p (te :> t) x
 | FPriv _ _      => True
 end.

(* Region identifier is not mentioned in the types of the free variables
   of the given stack. *)
Definition FreshFreeFs (p : nat) (te : tyenv) (fs : stack)
 := Forall (FreshFreeF p te) fs.
Hint Unfold FreshFreeFs.

Lemma freshFreeF_nil
 :  forall p f
 ,  FreshF p f
 -> FreshFreeF p nil f.
Proof.
 intros.
 destruct f; snorm.
Qed.
Hint Resolve freshFreeF_nil.

Lemma freshFreeFs_nil
 :  forall p fs
 ,  FreshFs p fs
 -> FreshFreeFs p nil fs.
Proof.
 intros.
 induction fs; eauto.
 inverts H. rip.
Qed.
Hint Resolve freshFreeFs_nil.

Lemma freshFreeFs_tail
 :  forall p te fs f
 ,  FreshFreeFs p te (fs :> f)
 -> FreshFreeFs p te fs.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve freshFreeFs_tail.

(********************************************************************)
(* Region identifier is not mentioned in the types of the locations
   used in the given stack frame. *)
Fixpoint  FreshSuppF   (p : nat) (se : stenv) (f : frame) {struct f} :=
 match f with
 | FLet  t x      => FreshSuppX p se x
 | FPriv _ _      => True
 end.

(* Region identifier is not mentioned in the types of the locations
   used in the given stack. *)
Definition FreshSuppFs p2 se fs
 := Forall (FreshSuppF p2 se) fs.
Hint Unfold FreshSuppFs.

Lemma freshSuppFs_tail
 :  forall p te fs f
 ,  FreshSuppFs p te (fs :> f)
 -> FreshSuppFs p te fs.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve freshSuppFs_tail.

Lemma freshSuppFs_head
 :  forall p te fs f
 ,  FreshSuppFs p te (fs :> f)
 -> FreshSuppF  p te f.
Proof.
 intros.
 inverts H. auto.
Qed.
Hint Resolve freshSuppFs_head.

Lemma freshSuppF_mergeTE
 :  forall p1 p2 p3 te f
 ,  FreshSuppF p1 te f
 -> FreshSuppF p2 te f
 -> FreshSuppF p2 (mergeTE p3 p1 te) f.
Proof.
 intros.
 destruct f.
 - snorm.
   eapply freshSuppX_mergeTE; auto.
 - eauto.
Qed.

Lemma freshSuppFs_mergeTE
 :  forall p1 p2 p3 te fs
 ,  FreshSuppFs p1 te fs
 -> FreshSuppFs p2 te fs
 -> FreshSuppFs p2 (mergeTE p3 p1 te) fs.
Proof.
 intros.
 unfold FreshSuppFs in *.
 induction fs; auto.
 inverts H.
 inverts H0. rip.
 eapply Forall_cons; auto.
 eapply freshSuppF_mergeTE; auto.
Qed.


Require Import Coq.Arith.Arith.
Require Import Coq.Unicode.Utf8.
Require Import Hask.Control.Monad.
Require Import Hask.Control.Monad.Cont.
Require Import Hask.Control.Monad.State.
Require Import Hask.Control.Monad.Trans.Class.
Require Import Hask.Control.Monad.Trans.State.
Require Import Hask.Control.Monad.Trans.Either.
Require Import Hask.Data.Functor.Identity.
Require Import Pact.Data.Either.
Require Import Coq.Classes.RelationClasses.
Require Import FunctionalExtensionality.

From Hammer Require Export Tactics Hammer.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Generalizable All Variables.
Set Primitive Projections.

Notation "'∑' x .. y , p" := (sigT (fun x => .. (sigT (fun y => p%type)) ..))
  (at level 200, x binder, right associativity,
   format "'[' '∑'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Notation "( x ; y )" := (@existT _ _ x y).
Notation "( x ; y ; z )" := (x ; ( y ; z)).
Notation "( x ; y ; z ; t )" := (x ; ( y ; (z ; t))).
Notation "( x ; y ; z ; t ; u )" := (x ; ( y ; (z ; (t ; u)))).
Notation "( x ; y ; z ; t ; u ; v )" := (x ; ( y ; (z ; (t ; (u ; v))))).
Notation "x .π1" := (@projT1 _ _ x) (at level 3, format "x '.π1'").
Notation "x .π2" := (@projT2 _ _ x) (at level 3, format "x '.π2'").

Class Order W `{Monad W} := {
  wle : ∀ A, W A → W A → Prop ;
  trans :> ∀ A, Transitive (@wle A)
}.

Arguments Order W {_}.
Arguments wle {_ _ _} {_}.

Notation "x ≤ᵂ y" := (wle x y) (at level 80).

Class MonoSpec W `{Order W} := {
  bind_mono :
    ∀ A B (w w' : W A) (wf wf' : A → W B),
      w ≤ᵂ w' →
      (∀ x, wf x ≤ᵂ wf' x) →
      bind wf w ≤ᵂ bind wf' w'
}.

Definition observation (M W : Type → Type) :=
  ∀ A (c : M A), W A.

Class LaxMorphism {M W} `{Monad M} `{Order W} (θ : observation M W) := {
  θ_ret :
    ∀ A (x : A),
      θ _ (pure x) ≤ᵂ pure x ;
  θ_bind :
    ∀ A B c f,
      θ _ (bind (X:=A) (Y:=B) f c) ≤ᵂ bind (λ x, θ _ (f x)) (θ _ c)
}.

Class DijkstraMonad {W} `{Word : Order W} (D : ∀ A (w : W A), Type) := {
  retᴰ : ∀ A (x : A), D A (pure x) ;
  bindᴰ : ∀ A B w wf (c : D A w) (f : ∀ x, D B (wf x)), D B (bind wf w) ;
  subcompᴰ : ∀ A w w' (c : D A w) (h : w ≤ᵂ w'), D A w'
}.

Arguments retᴰ {_ _ _ _ _} [_].
Arguments bindᴰ {_ _ _ _ _} [_ _ _ _].
Arguments subcompᴰ {_ _ _ _ _} [_ _ _] _ {_}.

Class Morphism `{hM : Monad M} `{hN : Monad N} (f : ∀ A, M A → N A) := {
  morph_ret : ∀ A (x : A), f A (pure x) = pure x ;
  morph_bind :
    ∀ A B (c : M A) (k : A → M B),
      f _ (bind k c) = bind (λ x, f _ (k x)) (f _ c)
}.

Definition Wpure (a : Type) := (a → Prop) → Prop.

#[export]
Program Instance Wpure_Order : Order Wpure := {|
  wle := λ _ w₁ w₂, ∀ p, w₂ p → w₁ p
|}.

(*************************************************************************
 * Example
 *)

Ltac calculate :=
  cbv [
    Cont
    Cont_Applicative
    Cont_Functor
    Cont_Monad
    Cont_join
    Cont_map
    Datatypes.id
    EitherT_Applicative
    EitherT_Functor
    EitherT_Monad
    EitherT_MonadTrans
    EitherT_join
    EitherT_map
    EitherT_pure
    Either_Applicative
    Either_Functor
    Either_Monad
    Either_join
    Either_map
    Hask.Data.Either.Either_Applicative
    Hask.Data.Either.Either_Functor
    Hask.Data.Either.Either_Monad
    Hask.Data.Either.Either_join
    Hask.Data.Either.Either_map
    Identity_Applicative
    Identity_Functor
    Identity_Monad
    Prelude.apply
    Prelude.compose
    Prelude.flip
    State.get
    State.modify
    State.put
    StateT_Applicative
    StateT_Functor
    StateT_Monad
    StateT_MonadTrans
    StateT_join
    State_Applicative
    State_Functor
    State_Monad
    Tuple.curry
    Tuple.first
    bind
    comp
    fmap
    getT
    is_applicative
    is_functor
    join
    lift
    modifyT
    pure
    putT
  ] in *.

Module DijkstraSt.

Section DijkstraExample.

Variable s : Type.

Definition M := State s.
Definition W := StateT s (Cont Prop).

#[export]
Program Instance id_Functor : Functor id := {|
  fmap := λ _ _ f x, f x
|}.
#[export]
Program Instance id_Applicative : Applicative id := {|
  pure := λ _ x, x;
  ap := λ _ _ f x, f x
|}.
#[export]
Program Instance id_Monad : Monad id.

#[export]
Instance M_Functor : Functor M := State_Functor.
#[export]
Instance M_Applicative : Applicative M := State_Applicative.
#[export]
Instance M_Monad : Monad M := State_Monad.

#[export]
Program Instance W_Order : Order W := {|
  wle := λ _ w₁ w₂, ∀ p s, w₂ p s → w₁ p s
|}.

Definition θ : observation M W := λ _ c s p, p (c s).

#[export]
Program Instance θ_LaxMorphism : LaxMorphism θ.
Next Obligation.
  unfold θ in *.
  calculate; sauto.
Qed.

#[export]
Program Instance θ_Morphism : Morphism θ.
Next Obligation.
  unfold θ in *.
  calculate.
  extensionality s0.
  extensionality p.
  sauto.
Qed.

Definition ST (A : Type) (w : W A) := ∑ c : M A, θ c ≤ᵂ w.

#[export]
Program Instance ST_Dijkstra : DijkstraMonad ST := {|
  retᴰ := λ _ x, (pure[M] x; _);
  bindᴰ := λ A B w wf (c : ST w) (f : ∀ x, ST (wf x)),
    (bind (m:=M) (λ x, projT1 (f x)) (projT1 c); _);
  subcompᴰ := λ A w w' (c : ST w) (h : w ≤ᵂ w'), _
|}.
Next Obligation.
  unfold θ in *.
  calculate.
  destruct c; simpl in *.
  apply w0 in H.
  unfold θ in *.
  destruct (x p).
  destruct (f a);
  sauto.
Defined.
Next Obligation.
  sauto.
Defined.

Program Definition liftST0 `(f : M a) : ST (θ f) := (f; _).
Program Definition liftST1 `(f : a → M b) (x : a) : ST (θ (f x)) := (f x; _).

Definition getST := liftST0 State.get.
Definition putST := liftST1 State.put.

Definition modify' := liftST1 State.modify.

Definition modifyST `(f : s → s) := bindᴰ getST (λ x, putST (f x)).

End DijkstraExample.

Goal True.
  pose getST.
  pose putST.
  pose modify'.
  pose modifyST.
  unfold θ in *.
  calculate.

  auto.
Qed.

Definition algorithm : M nat nat :=
  n <- getT ;
  if n <? 10
  then
    putT (n + 1) ;;
    pure (n + 100)
  else pure 0.

Definition algorithmST := liftST0 algorithm.

Goal True.
  pose algorithmST.
  unfold θ, algorithm in s.
  calculate.

  auto.
Qed.

End DijkstraSt.

Module DijkstraSte.

Section DijkstraExample.

Variable s : Type.
Variable e : Type.

Definition M := StateT s (Either e).
Definition W := StateT s (EitherT e (Cont Prop)).

#[export]
Program Instance id_Functor : Functor id := {|
  fmap := λ _ _ f x, f x
|}.
#[export]
Program Instance id_Applicative : Applicative id := {|
  pure := λ _ x, x;
  ap := λ _ _ f x, f x
|}.
#[export]
Program Instance id_Monad : Monad id.

#[export]
Instance M_Functor : Functor M := StateT_Functor.
#[export]
Instance M_Applicative : Applicative M := StateT_Applicative.
#[export]
Instance M_Monad : Monad M := StateT_Monad.

#[export]
Program Instance W_Order : Order W := {|
  wle := λ _ w₁ w₂, ∀ p s, w₂ p s → w₁ p s
|}.

Definition θbot : observation M W := λ _ c s p,
  match c s with
  | inl _ => False
  | inr x => p (inr x)
  end.

#[export]
Program Instance θbot_LaxMorphism : LaxMorphism θbot.
Next Obligation.
  unfold θbot in *.
  calculate; sauto.
Qed.

#[export]
Program Instance θbot_Morphism : Morphism θbot.
Next Obligation.
  unfold θbot in *.
  calculate.
  extensionality s0.
  extensionality p.
  sauto.
Qed.

Definition θtop : observation M W := λ _ c s p,
  match c s with
  | inl _ => True
  | inr x => p (inr x)
  end.

#[export]
Program Instance θtop_LaxMorphism : LaxMorphism θtop.
Next Obligation.
  unfold θtop in *.
  calculate; sauto.
Qed.

#[export]
Program Instance θtop_Morphism : Morphism θtop.
Next Obligation.
  unfold θtop in *.
  calculate.
  extensionality s0.
  extensionality p.
  sauto.
Qed.

Definition STbot (A : Type) (w : W A) := ∑ c : M A, θbot c ≤ᵂ w.
Definition STtop (A : Type) (w : W A) := ∑ c : M A, θtop c ≤ᵂ w.

#[export]
Program Instance STbot_Dijkstra : DijkstraMonad STbot := {|
  retᴰ := λ _ x, (pure[M] x; _);
  bindᴰ := λ A B w wf (c : STbot w) (f : ∀ x, STbot (wf x)),
    (bind (m:=M) (λ x, projT1 (f x)) (projT1 c); _);
  subcompᴰ := λ A w w' (c : STbot w) (h : w ≤ᵂ w'), _
|}.
Next Obligation.
  unfold θbot in *.
  simpl in *.
  unfold Datatypes.id.
  destruct c; simpl in *.
  apply w0 in H.
  unfold θbot in *.
  destruct (x p).
  - calculate; sauto.
  - calculate.
    destruct p0.
    destruct (f a).
    unfold θbot in *.
    sauto.
Defined.
Next Obligation.
  sauto.
Defined.

#[export]
Program Instance STtop_Dijkstra : DijkstraMonad STtop := {|
  retᴰ := λ _ x, (pure[M] x; _);
  bindᴰ := λ A B w wf (c : STtop w) (f : ∀ x, STtop (wf x)),
    (bind (m:=M) (λ x, projT1 (f x)) (projT1 c); _);
  subcompᴰ := λ A w w' (c : STtop w) (h : w ≤ᵂ w'), _
|}.
Next Obligation.
  unfold θtop in *.
  simpl in *.
  unfold Datatypes.id.
  destruct c; simpl in *.
  apply w0 in H.
  unfold θtop in *.
  destruct (x p).
  - calculate; sauto.
  - calculate.
    destruct p0.
    destruct (f a).
    unfold θtop in *.
    sauto.
Defined.
Next Obligation.
  sauto.
Defined.

Program Definition liftSTbot0 `(f : M a) : STbot (θbot f) := (f; _).
Program Definition liftSTbot1 `(f : a → M b) (x : a) :
  STbot (θbot (f x)) := (f x; _).

Program Definition liftSTtop0 `(f : M a) : STtop (θtop f) := (f; _).
Program Definition liftSTtop1 `(f : a → M b) (x : a) :
  STtop (θtop (f x)) := (f x; _).

Definition getSTbot    := liftSTbot0 State.getT.
Definition putSTbot    := liftSTbot1 State.putT.
Definition modifySTbot := liftSTbot1 State.modifyT.

Definition getSTtop    := liftSTtop0 State.getT.
Definition putSTtop    := liftSTtop1 State.putT.
Definition modifySTtop := liftSTtop1 State.modifyT.

End DijkstraExample.

Goal True.
  pose getSTbot.
  pose putSTbot.
  pose modifySTbot.
  pose getSTtop.
  pose putSTtop.
  pose modifySTtop.
  unfold θbot, θtop in *.
  calculate.

  auto.
Qed.

Definition assert {s e : Type} (b : bool) (err : e) : M s e unit :=
  if b
  then
    pure tt
  else
    lift (inl err).

Arguments assert _ _ /.

Definition algorithm (x : nat) : M nat unit nat :=
  n <- getT ;
  assert (n <? 10) tt ;;
  putT (n + x) ;;
  assert (x =? 100) tt ;;
  r <- getT ;
  assert (Nat.even r) tt ;;
  pure (n + 100).

Definition algorithmST := liftSTbot1 algorithm.

Lemma if_fun {A B : Type} (b : bool) (P Q : A → B) (x : A) :
  (if b then λ x, P x else λ x, Q x) x = if b then P x else Q x.
Proof. sauto. Qed.

Lemma match_if {A B C : Type} (b : bool) (P Q : A + B) (F : A → C) (G : B → C) :
  match (if b then P else Q) with
  | inl x => F x
  | inr x => G x
  end =
  if b
  then
    match P with
    | inl x => F x
    | inr x => G x
    end
  else
    match Q with
    | inl x => F x
    | inr x => G x
    end.
Proof. sauto. Qed.

Lemma in_ST {A B C : Type} {P Q : W A B C} : forall H : P = Q,
  STbot P = STbot Q.
Proof. sauto. Qed.

Lemma in_STx {A B C D : Type} {P Q : D → W A B C} : forall H : P = Q,
  (∀ x : D, STbot (P x)) = (∀ x : D, STbot (Q x)).
Proof. sauto. Qed.

Ltac calc :=
  repeat
    (calculate;
     cbv [ θbot algorithm assert M_Functor M_Applicative M_Monad ] in *
    ).

Goal True.
  pose algorithmST.
  calc.
  unshelve erewrite (in_STx _) in s. {
    extensionality s0.
    extensionality p.
    extensionality x.
    repeat rewrite !if_fun, !match_if.
    reflexivity.
  }
  simpl in s.

  auto.
Qed.

End DijkstraSte.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ Aprime O /\ (wd_ A B /\ (wd_ A Aprime /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ col_ A C B))))))))))))) -> col_ O Cprime Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C G H O Aprime Bprime Cprime : Universe, ((wd_ O G /\ (wd_ O H /\ (wd_ O Aprime /\ (wd_ A Aprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ C H /\ (wd_ B H /\ (wd_ A H /\ (col_ G Aprime A /\ (col_ A Aprime H /\ (col_ Aprime A O /\ (col_ Cprime A B /\ (col_ Bprime A C /\ col_ Aprime B C))))))))))))))))))))) -> col_ G H O)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv1 (plus Zero lv0))).
Admitted.
QuickChick conj15eqsynthconj4.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult (plus lv0 (mult lv0 lv1)) lv2) (plus (mult lv1 (mult lv0 lv2)) (mult lv0 lv2))).
Admitted.
QuickChick conj15synthconj4.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Equalities Bool SetoidList RelationPairs.

Set Implicit Arguments.

(** * Keys and datas used in the future MMaps *)

Module KeyDecidableType(D:DecidableType).

 Local Open Scope signature_scope.
 Local Notation key := D.t.

 Definition eqk {elt} : relation (key*elt) := D.eq @@1.
 Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq.

 Hint Unfold eqk eqke.

 (** eqk, eqke are equalities *)

 Instance eqk_equiv {elt} : Equivalence (@eqk elt) := _.

 Instance eqke_equiv {elt} : Equivalence (@eqke elt) := _.

 (** eqke is stricter than eqk *)

 Instance eqke_eqk {elt} : subrelation (@eqke elt) (@eqk elt).
 Proof. firstorder. Qed.

 (** Alternative definitions of eqke and eqk *)

 Lemma eqke_def {elt} k k' (e e':elt) :
  eqke (k,e) (k',e') = (D.eq k k' /\ e = e').
 Proof. reflexivity. Defined.

 Lemma eqke_def' {elt} (p q:key*elt) :
  eqke p q = (D.eq (fst p) (fst q) /\ snd p = snd q).
 Proof. reflexivity. Defined.

 Lemma eqke_1 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> D.eq k k'.
 Proof. now destruct 1. Qed.

 Lemma eqke_2 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> e=e'.
 Proof. now destruct 1. Qed.

 Lemma eqk_def {elt} k k' (e e':elt) : eqk (k,e) (k',e') = D.eq k k'.
 Proof. reflexivity. Defined.

 Lemma eqk_def' {elt} (p q:key*elt) : eqk p q = D.eq (fst p) (fst q).
 Proof. reflexivity. Qed.

 Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'.
 Proof. trivial. Qed.

 Hint Resolve eqke_1 eqke_2 eqk_1.

 (* Additional facts *)

 Lemma InA_eqke_eqk {elt} p (m:list (key*elt)) :
   InA eqke p m -> InA eqk p m.
 Proof.
  induction 1; firstorder.
 Qed.
 Hint Resolve InA_eqke_eqk.

 Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) :
  InA eqk p m -> exists q, eqk p q /\ InA eqke q m.
 Proof.
  induction 1; firstorder.
 Qed.

 Lemma InA_eqk {elt} p q (m:list (key*elt)) :
   eqk p q -> InA eqk p m -> InA eqk q m.
 Proof.
  now intros <-.
 Qed.

 Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e).
 Definition In {elt} k m := exists e:elt, MapsTo k e m.

 Hint Unfold MapsTo In.

 (* Alternative formulations for [In k l] *)

 Lemma In_alt {elt} k (l:list (key*elt)) :
   In k l <-> exists e, InA eqk (k,e) l.
 Proof.
  unfold In, MapsTo.
  split; intros (e,H).
  - exists e; auto.
  - apply InA_eqk_eqke in H. destruct H as ((k',e'),(E,H)).
    compute in E. exists e'. now rewrite E.
 Qed.

 Lemma In_alt' {elt} (l:list (key*elt)) k e :
   In k l <-> InA eqk (k,e) l.
 Proof.
  rewrite In_alt. firstorder. eapply InA_eqk; eauto. now compute.
 Qed.

 Lemma In_alt2 {elt} k (l:list (key*elt)) :
   In k l <-> Exists (fun p => D.eq k (fst p)) l.
 Proof.
  unfold In, MapsTo.
  setoid_rewrite Exists_exists; setoid_rewrite InA_alt.
  firstorder.
  exists (snd x), x; auto.
 Qed.

 Lemma In_nil {elt} k : In k (@nil (key*elt)) <-> False.
 Proof.
  rewrite In_alt2; apply Exists_nil.
 Qed.

 Lemma In_cons {elt} k p (l:list (key*elt)) :
   In k (p::l) <-> D.eq k (fst p) \/ In k l.
 Proof.
  rewrite !In_alt2, Exists_cons; intuition.
 Qed.

 Instance MapsTo_compat {elt} :
   Proper (D.eq==>Logic.eq==>equivlistA eqke==>iff) (@MapsTo elt).
 Proof.
  intros x x' Hx e e' He l l' Hl. unfold MapsTo.
  rewrite Hx, He, Hl; intuition.
 Qed.

 Instance In_compat {elt} : Proper (D.eq==>equivlistA eqk==>iff) (@In elt).
 Proof.
  intros x x' Hx l l' Hl. rewrite !In_alt.
  setoid_rewrite Hl. setoid_rewrite Hx. intuition.
 Qed.

 Lemma MapsTo_eq {elt} (l:list (key*elt)) x y e :
   D.eq x y -> MapsTo x e l -> MapsTo y e l.
 Proof. now intros <-. Qed.

 Lemma In_eq {elt} (l:list (key*elt)) x y :
   D.eq x y -> In x l -> In y l.
 Proof. now intros <-. Qed.

 Lemma In_inv {elt} k k' e (l:list (key*elt)) :
   In k ((k',e) :: l) -> D.eq k k' \/ In k l.
 Proof.
  intros (e',H). red in H. rewrite InA_cons, eqke_def in H.
  intuition. right. now exists e'.
 Qed.

 Lemma In_inv_2 {elt} k k' e e' (l:list (key*elt)) :
   InA eqk (k, e) ((k', e') :: l) -> ~ D.eq k k' -> InA eqk (k, e) l.
 Proof.
  rewrite InA_cons, eqk_def. intuition.
 Qed.

 Lemma In_inv_3 {elt} x x' (l:list (key*elt)) :
   InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
 Proof.
  rewrite InA_cons. destruct 1 as [H|H]; trivial. destruct 1.
  eauto with *.
 Qed.

 Hint Extern 2 (eqke ?a ?b) => split.
 Hint Resolve InA_eqke_eqk.
 Hint Resolve In_inv_2 In_inv_3.

End KeyDecidableType.

(** * PairDecidableType

   From two decidable types, we can build a new DecidableType
   over their cartesian product. *)

Module PairDecidableType(D1 D2:DecidableType) <: DecidableType.

 Definition t := (D1.t * D2.t)%type.

 Definition eq := (D1.eq * D2.eq)%signature.

 Instance eq_equiv : Equivalence eq := _.

 Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq; simpl.
 destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
  compute; intuition.
 Defined.

End PairDecidableType.

(** Similarly for pairs of UsualDecidableType *)

Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
 Definition t := (D1.t * D2.t)%type.
 Definition eq := @eq t.
 Instance eq_equiv : Equivalence eq := _.
 Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
 Proof.
 intros (x1,x2) (y1,y2);
 destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
 unfold eq, D1.eq, D2.eq in *; simpl;
 (left; f_equal; auto; fail) ||
 (right; intros [=]; auto).
 Defined.

End PairUsualDecidableType.


Definition sig_rec_simple (A:Set) (P: A -> Prop) (B : Set) :
  (forall x, P x -> B) -> (sig P) -> B.
 intros   f x.
 case x; intros a Ha.
 eapply f ; eexact Ha.
Defined.


(*
Borrowed from https://github.com/QuickChick/QuickChick/blob/master/src/StringOT.v

Ordering code by Antal :)

*)

Require Import Coq.Structures.OrderedType.

Require Import Bool.

Module BoolOT <: OrderedType.

  Definition t := bool.

  Definition eq       := @Logic.eq       bool.
  Definition eq_refl  := @Logic.eq_refl  bool.
  Definition eq_sym   := @Logic.eq_sym   bool.
  Definition eq_trans := @Logic.eq_trans bool.
  Definition eq_dec   := bool_dec.

  Definition lt (b1 b2 : bool) : Prop := b1 = false /\ b2 = true.

  Theorem lt_trans : forall x y z : bool, lt x y -> lt y z -> lt x z.
  Proof. unfold lt; tauto. Qed.

  Theorem lt_not_eq : forall x y : bool, lt x y -> ~ eq x y.
  Proof. unfold lt, eq; intuition; congruence. Qed.

  Theorem compare : forall x y : bool, Compare lt eq x y.
  Proof.
    unfold lt, eq; repeat (let b := fresh in intros b; destruct b);
      [apply EQ | apply GT | apply LT | apply EQ]; auto.
  Qed.

End BoolOT.