(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Export memory_map values.
Require Import pointer_casts.

Local Open Scope ctype_scope.
Local Coercion Z.of_nat: nat >-> Z.

Section operations_definitions.
  Context `{Env K}.

  (** ** Operations on addresses *)
  Definition addr_compare_ok (Γ : env K) (m : mem K)
      (c : compop) (a1 a2 : addr K) : Prop :=
    index_alive' m (addr_index a1) ∧ index_alive' m (addr_index a2) ∧
    (addr_index a1 ≠ addr_index a2 →
      c = EqOp ∧ addr_strict Γ a1 ∧ addr_strict Γ a2).
  Definition addr_compare (Γ : env K) (c : compop) (a1 a2 : addr K) : bool :=
    bool_decide (addr_index a1 = addr_index a2 ∧
      Z_comp c (addr_object_offset Γ a1) (addr_object_offset Γ a2)).
  Definition addr_plus_ok (Γ : env K) (m : mem K)
      (j : Z) (a : addr K) : Prop :=
    index_alive' m (addr_index a) ∧
    (0 ≤ addr_byte a + j * ptr_size_of Γ (type_of a)
       ≤ size_of Γ (addr_type_base a) * ref_size (addr_ref_base a))%Z.
  Global Arguments addr_plus_ok _ _ _ !_ /.
  Definition addr_plus (Γ : env K) (j : Z) (a : addr K): addr K :=
    let 'Addr x r i τ σ σp := a
    in Addr x r (Z.to_nat (i + j * ptr_size_of Γ σp)) τ σ σp.
  Global Arguments addr_plus _ _ !_ /.
  Definition addr_minus (Γ : env K) (a1 a2 : addr K) : Z :=
    ((addr_byte a1 - addr_byte a2) `div` ptr_size_of Γ (type_of a1))%Z.
  Global Arguments addr_minus _ !_ !_ /.
  Definition addr_minus_ok (Γ : env K) (m : mem K) (a1 a2 : addr K) : Prop :=
    index_alive' m (addr_index a1) ∧
    addr_index a1 = addr_index a2 ∧
    freeze true <$> addr_ref_base a1 = freeze true <$> addr_ref_base a2 ∧
    int_typed (addr_minus Γ a1 a2) sptrT.
  Global Arguments addr_minus_ok _ _ !_ !_ /.
  Definition addr_cast_ok (Γ : env K) (m : mem K)
      (σp : ptr_type K) (a : addr K) : Prop :=
    index_alive' m (addr_index a) ∧
    addr_type_base a >*> σp ∧
    (ptr_size_of Γ σp | addr_byte a).
  Global Arguments addr_cast_ok _ _ _ !_ /.
  Definition addr_cast (σp : ptr_type K) (a : addr K) : addr K :=
    let 'Addr o r i τ σ _ := a in Addr o r i τ σ σp.
  Global Arguments addr_cast _ !_ /.

  (** ** Operations on pointers *)
  Definition ptr_alive' (m : mem K) (p : ptr K) : Prop :=
    match p with Ptr a => index_alive' m (addr_index a) | _ => True end.
  Definition ptr_compare_ok (Γ : env K)  (m : mem K)
      (c : compop) (p1 p2 : ptr K) : Prop :=
    match p1, p2, c with
    | Ptr a1, Ptr a2, _ => addr_compare_ok Γ m c a1 a2
    | FunPtr f1 _ _, FunPtr f2 _ _, EqOp => True
    | NULL _, NULL _, _ => True
    | NULL _, Ptr a2, EqOp => index_alive' m (addr_index a2)
    | NULL _, FunPtr _ _ _, EqOp => True
    | Ptr a1, NULL _, EqOp => index_alive' m (addr_index a1)
    | FunPtr _ _ _, NULL _, EqOp => True
    | _, _, _ => False
    end.
  Definition ptr_compare (Γ : env K) (c : compop) (p1 p2 : ptr K) : bool :=
    match p1, p2, c with
    | Ptr a1, Ptr a2, _ => addr_compare Γ c a1 a2
    | FunPtr f1 _ _, FunPtr f2 _ _, EqOp => bool_decide (f1 = f2)
    | NULL _, NULL _, (EqOp | LeOp) => true
    | NULL _, NULL _, LtOp => false
    | NULL _, (Ptr _ | FunPtr _ _ _), _ => false
    | (Ptr _ | FunPtr _ _ _), NULL _, _ => false
    | _, _, _ => false
    end.
  Definition ptr_plus_ok (Γ : env K) (m : mem K) (j : Z) (p : ptr K) :=
    match p with
    | NULL _ => j = 0 | Ptr a => addr_plus_ok Γ m j a | _ => False
    end.
  Global Arguments ptr_plus_ok _ _ _ !_ /.
  Definition ptr_plus (Γ : env K) (j : Z) (p : ptr K) : ptr K :=
    match p with Ptr a => Ptr (addr_plus Γ j a) | _ => p end.
  Global Arguments ptr_plus _ _ !_ /.
  Definition ptr_minus_ok (Γ : env K) (m : mem K) (p1 p2 : ptr K) : Prop :=
    match p1, p2 with
    | NULL _, NULL _ => True
    | Ptr a1, Ptr a2 => addr_minus_ok Γ m a1 a2
    | _, _ => False
    end.
  Global Arguments ptr_minus_ok _ _ !_ !_ /.
  Definition ptr_minus (Γ : env K) (p1 p2 : ptr K) : Z :=
    match p1, p2 with
    | NULL _, NULL _ => 0
    | Ptr a1, Ptr a2 => addr_minus Γ a1 a2
    | _, _ => 0
    end.
  Global Arguments ptr_minus _ !_ !_ /.
  Inductive ptr_cast_typed : ptr_type K → ptr_type K → Prop :=
    | TAny_to_TAny_cast_typed : ptr_cast_typed TAny TAny
    | TType_to_TType_cast_typed τ : ptr_cast_typed (TType τ) (TType τ)
    | TType_to_TAny_cast_typed τ : ptr_cast_typed (TType τ) TAny
    | TType_to_TChar_cast_typed τ : ptr_cast_typed (TType τ) ucharT
    | TAny_to_TType_cast_typed τ : ptr_cast_typed TAny (TType τ)
    | TChar_to_TType_cast_typed τ : ptr_cast_typed ucharT (TType τ)
    | TFun_to_TFun_cast_typed τs τ : ptr_cast_typed (τs ~> τ) (τs ~> τ).
  Definition ptr_cast_ok (Γ : env K) (m : mem K)
      (σp : ptr_type K) (p : ptr K) : Prop :=
    match p with Ptr a => addr_cast_ok Γ m σp a | _ => True end.
  Global Arguments ptr_cast_ok _ _ _ !_ /.
  Definition ptr_cast (σp : ptr_type K) (p : ptr K) : ptr K :=
    match p with
    | NULL _ => NULL σp | Ptr a => Ptr (addr_cast σp a) | _ => p
    end.
  Global Arguments ptr_cast _ !_ /.

  (** ** Operations on base values *)
  Definition base_val_branchable (m : mem K) (vb : base_val K) : Prop :=
    match vb with
    | VInt _ _ => True
    | VPtr p => ptr_alive' m p
    | _ => False
    end.
  Definition base_val_is_0 (vb : base_val K) : Prop :=
    match vb with
    | VInt _ x => x = 0
    | VPtr (NULL _) => True
    | _ => False
    end.
  Definition base_val_0 (τb : base_type K) : base_val K :=
    match τb with
    | voidT => VVoid | intT τi => VInt τi 0 | τ.* => VPtr (NULL τ)
    end%BT.
  Inductive base_unop_typed : unop → base_type K → base_type K → Prop :=
    | TInt_unop_typed op τi :
       base_unop_typed op (intT τi) (intT (int_unop_type_of op τi))
    | TPtr_NotOp_typed τ : base_unop_typed NotOp (τ.*) sintT.
  Definition base_unop_type_of (op : unop)
      (τb : base_type K) : option (base_type K) :=
    match τb, op with
    | intT τi, op => Some (intT (int_unop_type_of op τi))
    | τ.*, NotOp => Some sintT
    | _, _ => None
    end%BT.
  Definition base_val_unop_ok (m : mem K)
      (op : unop) (vb : base_val K) : Prop :=
    match vb, op with
    | VInt τi x, op => int_unop_ok op x τi
    | VPtr p, NotOp => ptr_alive' m p
    | _, _ => False
    end.
  Global Arguments base_val_unop_ok _ !_ !_ /.
  Definition base_val_unop (op : unop) (vb : base_val K) : base_val K :=
    match vb, op with
    | VInt τi x, op => VInt (int_unop_type_of op τi) (int_unop op x τi)
    | VPtr p, NotOp => VInt sintT (match p with Ptr _ => 0 | _ => 1 end)
    | _, _ => vb (* dummy *)
    end.
  Global Arguments base_val_unop !_ !_ /.

  Inductive base_binop_typed :
        binop → base_type K → base_type K → base_type K → Prop :=
    | TInt_binop_typed op τi1 τi2 :
       base_binop_typed op (intT τi1) (intT τi2)
         (intT (int_binop_type_of op τi1 τi2))
    | CompOp_TPtr_TPtr_typed c τp :
       base_binop_typed (CompOp c) (τp.*) (τp.*) sintT
    | PlusOp_TPtr_TInt_typed τ σ :
       base_binop_typed (ArithOp PlusOp) (TType τ.*) (intT σ) (TType τ.*)
    | PlusOp_VInt_TPtr_typed τ σ :
       base_binop_typed (ArithOp PlusOp) (intT σ) (TType τ.*) (TType τ.*)
    | MinusOp_TPtr_TInt_typed τ σi :
       base_binop_typed (ArithOp MinusOp) (TType τ.*) (intT σi) (TType τ.*)
    | MinusOp_TInt_TPtr_typed τ σi :
       base_binop_typed (ArithOp MinusOp) (intT σi) (TType τ.*) (TType τ.*)
    | MinusOp_TPtr_TPtr_typed τ  :
       base_binop_typed (ArithOp MinusOp) (TType τ.*) (TType τ.*) sptrT.
  Definition base_binop_type_of
      (op : binop) (τb1 τb2 : base_type K) : option (base_type K) :=
    match τb1, τb2, op with
    | intT τi1, intT τi2, op => Some (intT (int_binop_type_of op τi1 τi2))
    | τp1.*, τp2.*, CompOp _ => guard (τp1 = τp2); Some sintT
    | TType τ.*, intT σ, ArithOp (PlusOp | MinusOp) => Some (TType τ.*)
    | intT σ, TType τ.*, ArithOp (PlusOp | MinusOp) => Some (TType τ.*)
    | TType τ1.*, TType τ2.*, ArithOp MinusOp => guard (τ1 = τ2); Some sptrT
    | _, _, _ => None
    end%BT.
  Definition base_val_binop_ok (Γ : env K) (m : mem K)
      (op : binop) (vb1 vb2 : base_val K) : Prop :=
    match vb1, vb2, op with
    | VInt τi1 x1, VInt τi2 x2, op => int_binop_ok op x1 τi1 x2 τi2
    | VPtr p1, VPtr p2, CompOp c => ptr_compare_ok Γ m c p1 p2
    | VPtr p, VInt _ x, ArithOp PlusOp => ptr_plus_ok Γ m x p
    | VInt _ x, VPtr p, ArithOp PlusOp => ptr_plus_ok Γ m x p
    | VPtr p, VInt _ x, ArithOp MinusOp => ptr_plus_ok Γ m (-x) p
    | VInt _ x, VPtr p, ArithOp MinusOp => ptr_plus_ok Γ m (-x) p
    | VPtr p1, VPtr p2, ArithOp MinusOp => ptr_minus_ok Γ m p1 p2
    | _, _, _ => False
    end.
  Global Arguments base_val_binop_ok _ _ !_ !_ !_ /.
  Definition base_val_binop (Γ : env K)
      (op : binop) (v1 v2 : base_val K) : base_val K :=
    match v1, v2, op with
    | VInt τi1 x1, VInt τi2 x2, op =>
       VInt (int_binop_type_of op τi1 τi2) (int_binop op x1 τi1 x2 τi2)
    | VPtr p1, VPtr p2, CompOp c =>
       VInt sintT (if ptr_compare Γ c p1 p2 then 1 else 0)
    | VPtr p, VInt _ i, ArithOp PlusOp => VPtr (ptr_plus Γ i p)
    | VInt _ i, VPtr p, ArithOp PlusOp => VPtr (ptr_plus Γ i p)
    | VPtr p, VInt _ i, ArithOp MinusOp => VPtr (ptr_plus Γ (-i) p)
    | VInt _ i, VPtr p, ArithOp MinusOp => VPtr (ptr_plus Γ (-i) p)
    | VPtr p1, VPtr p2, ArithOp MinusOp => VInt sptrT (ptr_minus Γ p1 p2)
    | _, _, _ => v1 (* dummy *)
    end.
  Global Arguments base_val_binop _ !_ !_ !_ /.

  Inductive base_cast_typed : base_type K → base_type K → Prop :=
    | TVoid_cast_typed τb : base_cast_typed τb voidT
    | TInt_cast_typed τi1 τi2 : base_cast_typed (intT τi1) (intT τi2)
    | TPtr_to_TPtr_cast_typed τp1 τp2 :
       ptr_cast_typed τp1 τp2 → base_cast_typed (τp1.*) (τp2.*).
  Definition base_val_cast_ok (Γ : env K) (m : mem K)
      (τb : base_type K) (vb : base_val K) : Prop :=
    match vb, τb with
    | (VVoid | VInt _ _ | VByte _), voidT => True
    | VIndet τi, voidT => τi = ucharT
    | VPtr p, voidT => ptr_alive' m p
    | VInt _ x, intT τi => int_cast_ok τi x
    | VPtr p, τ.* => ptr_cast_ok Γ m τ p
    | VByte _, intT τi => τi = ucharT%IT
    | VIndet τi, intT τi' => τi = ucharT ∧ τi' = ucharT%IT
    | _, _ => False
    end%BT.
  Global Arguments base_val_cast_ok _ _ !_ !_ /.
  Definition base_val_cast (τb : base_type K)
      (vb : base_val K) : base_val K :=
    match vb, τb with
    | _, voidT => VVoid
    | VInt _ x, intT τi => VInt τi (int_cast τi x)
    | VPtr p, τ.* => VPtr (ptr_cast τ p)
    | _ , _ => vb
    end%BT.
  Global Arguments base_val_cast !_ !_ /.

  (** ** Operations on values *)
  Definition val_0 (Γ : env K) : type K → val K := type_iter
    (**i TBase     *) (λ τb, VBase (base_val_0 τb))
    (**i TArray    *) (λ τ n x, VArray τ (replicate n x))
    (**i TCompound *) (λ c t τs rec,
      match c with
      | Struct_kind => VStruct t (rec <$> τs)
      | Union_kind => VUnion t 0 (from_option rec (VUnionAll t []) (τs !! 0))
      end) Γ.

  Inductive unop_typed : unop → type K → type K → Prop :=
    | TBase_unop_typed op τb σb :
       base_unop_typed op τb σb → unop_typed op (baseT τb) (baseT σb).
  Definition unop_type_of (op : unop) (τ : type K) : option (type K) :=
    match τ with
    | baseT τb => σb ← base_unop_type_of op τb; Some (baseT σb) | _ => None
    end.
  Definition val_unop_ok (m : mem K) (op : unop) (v : val K) : Prop :=
    match v with VBase vb => base_val_unop_ok m op vb | _ => False end.
  Global Arguments val_unop_ok _ !_ !_ /.
  Definition val_unop (op : unop) (v : val K) : val K :=
    match v with VBase vb => VBase (base_val_unop op vb) | _ => v end.
  Global Arguments val_unop !_ !_ /.

  Inductive binop_typed : binop → type K → type K → type K → Prop :=
    | TBase_binop_typed op τb1 τb2 σb :
       base_binop_typed op τb1 τb2 σb →
       binop_typed op (baseT τb1) (baseT τb2) (baseT σb).
  Definition binop_type_of (op : binop) (τ1 τ2 : type K) : option (type K) :=
    match τ1, τ2 with
    | baseT τb1, baseT τb2 =>
       σb ← base_binop_type_of op τb1 τb2; Some (baseT σb)
    | _, _ => None
    end.
  Definition val_binop_ok (Γ : env K) (m : mem K)
      (op : binop) (v1 v2 : val K) : Prop :=
    match v1, v2 with
    | VBase vb1, VBase vb2 => base_val_binop_ok Γ m op vb1 vb2 | _, _ => False
    end.
  Global Arguments val_binop_ok _ _ !_ !_ !_ /.
  Definition val_binop (Γ : env K) (op : binop) (v1 v2 : val K) : val K :=
    match v1, v2 with
    | VBase vb1, VBase vb2 => VBase (base_val_binop Γ op vb1 vb2) | _, _ => v1
    end.
  Global Arguments val_binop _ !_ !_ !_ /.

  Inductive cast_typed : type K → type K → Prop :=
    | cast_typed_self τ : cast_typed τ τ
    | TBase_cast_typed τb1 τb2 :
       base_cast_typed τb1 τb2 → cast_typed (baseT τb1) (baseT τb2)
    | TBase_TVoid_cast_typed τ : cast_typed τ voidT.
  Definition val_cast_ok (Γ : env K) (m : mem K)
      (τp : ptr_type K) (v : val K) : Prop :=
    match v, τp with
    | VBase vb, TType (baseT τb) => base_val_cast_ok Γ m τb vb | _, _ => True
    end.
  Global Arguments val_cast_ok _ _ !_ !_ /.
  Definition val_cast (τp : ptr_type K) (v : val K) : val K :=
    match v, τp with
    | VBase vb, TType (baseT τb) => VBase (base_val_cast τb vb)
    | _, TType voidT => VBase VVoid | _ , _ => v
    end.
  Global Arguments val_cast !_ !_ /.
End operations_definitions.

Section operations.
Context `{EnvSpec K}.
Implicit Types Γ : env K.
Implicit Types Δ : memenv K.
Implicit Types τb σb : base_type K.
Implicit Types τp σp : ptr_type K.
Implicit Types τ σ : type K.
Implicit Types a : addr K.
Implicit Types vb : base_val K.
Implicit Types v : val K.
Implicit Types m : mem K.
Hint Immediate index_alive_1': core.
Hint Resolve index_alive_2': core.

Arguments addr_is_obj _ !_ /.
Arguments addr_ref _ _ _ !_ /.
Arguments addr_ref_byte _ _ _ !_ /.

(** ** Properties of operations on addresses *)
Lemma addr_compare_ok_weaken Γ1 Γ2 Δ1 m1 m2 c a1 a2 τp1 τp2 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ a1 : τp1 → (Γ1,Δ1) ⊢ a2 : τp2 →
  Γ1 ⊆ Γ2 → (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  addr_compare_ok Γ1 m1 c a1 a2 → Γ1 ⊆ Γ2 → addr_compare_ok Γ2 m2 c a1 a2.
Proof. unfold addr_compare_ok; intuition eauto using addr_strict_weaken. Qed.
Lemma addr_compare_ok_erase Γ m c a1 a2 :
  addr_compare_ok Γ (cmap_erase m) c a1 a2 = addr_compare_ok Γ m c a1 a2.
Proof. unfold addr_compare_ok; by rewrite !index_alive_erase'. Qed.
Lemma addr_compare_weaken Γ1 Γ2 Δ1 a1 a2 c τp1 τp2 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ a1 : τp1 → (Γ1,Δ1) ⊢ a2 : τp2 →
  Γ1 ⊆ Γ2 → addr_compare Γ1 c a1 a2 = addr_compare Γ2 c a1 a2.
Proof.
  unfold addr_compare; intros;
    by erewrite ?(addr_object_offset_weaken Γ1 Γ2) by eauto.
Qed.
Lemma addr_plus_typed Γ Δ m a σp j :
  ✓ Γ → (Γ,Δ) ⊢ a : σp → addr_plus_ok Γ m j a →
  (Γ,Δ) ⊢ addr_plus Γ j a : σp.
Proof.
  destruct 2 as [o r i τ σ σp]; intros (?&?&?);
    constructor; simpl in *; split_and ?; auto.
  { apply Nat2Z.inj_le. by rewrite Nat2Z.inj_mul, Z2Nat.id by done. }
  rewrite <-(Nat2Z.id (ptr_size_of Γ σp)) at 1.
  rewrite Z2Nat_divide by auto with zpos.
  apply Z.divide_add_r; [by apply Nat2Z_divide|by apply Z.divide_mul_r].
Qed.
Lemma addr_plus_ok_weaken Γ1 Γ2 Δ1 m1 m2 a σp j :
  ✓ Γ1 → (Γ1,Δ1) ⊢ a : σp → addr_plus_ok Γ1 m1 j a →
  Γ1 ⊆ Γ2 → (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  addr_plus_ok Γ2 m2 j a.
Proof.
  unfold addr_plus_ok; intros ?? (?&?&?) ??; simplify_type_equality'.
  erewrite <-addr_size_of_weaken, <-(size_of_weaken _ Γ2)
    by eauto using addr_typed_type_base_valid; eauto.
Qed.
Lemma addr_plus_ok_erase Γ m a j:
  addr_plus_ok Γ (cmap_erase m) j a = addr_plus_ok Γ m j a.
Proof. unfold addr_plus_ok. by rewrite !index_alive_erase'. Qed.
Lemma addr_plus_weaken Γ1 Γ2 Δ1 a σp j :
  ✓ Γ1 → (Γ1,Δ1) ⊢ a : σp → Γ1 ⊆ Γ2 → addr_plus Γ1 j a = addr_plus Γ2 j a.
Proof.
  intros ? Ha ?. assert (ptr_size_of Γ1 σp = ptr_size_of Γ2 σp)
    by eauto using addr_size_of_weaken.
  destruct Ha; simplify_type_equality'; congruence.
Qed.
Lemma addr_type_of_plus Γ a j : type_of (addr_plus Γ j a) = type_of a.
Proof. by destruct a. Qed.
Lemma addr_type_base_plus Γ a j :
  addr_type_base (addr_plus Γ j a) = addr_type_base a.
Proof. by destruct a. Qed.
Lemma addr_index_plus Γ a j : addr_index (addr_plus Γ j a) = addr_index a.
Proof. by destruct a. Qed.
Lemma addr_plus_0 Γ a : addr_plus Γ 0 a = a.
Proof. destruct a; simpl. by rewrite Z.mul_0_l, Z.add_0_r, Nat2Z.id. Qed.
Lemma addr_plus_plus Γ a j1 j2 :
  (0 ≤ addr_byte a + j2 * ptr_size_of Γ (type_of a))%Z →
  addr_plus Γ j1 (addr_plus Γ j2 a) = addr_plus Γ (j1 + j2) a.
Proof.
  intros. destruct a as [o r i σ σp]; do 2 f_equal'.
  by rewrite Z2Nat.id, (Z.add_comm j1), Z.mul_add_distr_r, Z.add_assoc.
Qed.
Lemma addr_plus_plus_nat Γ a (j1 j2 : nat) :
  addr_plus Γ j1 (addr_plus Γ j2 a) = addr_plus Γ(j1 + j2)%nat a.
Proof. rewrite Nat2Z.inj_add. apply addr_plus_plus; auto with zpos. Qed.
Lemma addr_is_obj_plus Γ a j : addr_is_obj (addr_plus Γ j a) ↔ addr_is_obj a.
Proof. by destruct a. Qed.
Lemma addr_ref_base_plus Γ a j :
  addr_ref_base (addr_plus Γ j a) = addr_ref_base a.
Proof. by destruct a. Qed.
Lemma addr_minus_typed Γ m a1 a2 :
  addr_minus_ok Γ m a1 a2 → int_typed (addr_minus Γ a1 a2) sptrT.
Proof. by intros (?&?&?&?). Qed.
Lemma addr_minus_weaken Γ1 Γ2 Δ1 a1 a2 σp1 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ a1 : σp1 →
  Γ1 ⊆ Γ2 → addr_minus Γ1 a1 a2 = addr_minus Γ2 a1 a2.
Proof.
  intros. unfold addr_minus; simplify_type_equality.
  by erewrite (addr_size_of_weaken Γ1 Γ2) by eauto.
Qed.
Lemma addr_minus_ok_weaken Γ1 Γ2 Δ1 m1 m2 a1 a2 σp1 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ a1 : σp1 → addr_minus_ok Γ1 m1 a1 a2 → Γ1 ⊆ Γ2 →
  (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  addr_minus_ok Γ2 m2 a1 a2.
Proof.
  intros ?? [??]; split; erewrite <-?(addr_minus_weaken Γ1 Γ2) by eauto; eauto.
Qed.
Lemma addr_minus_ok_erase Γ  m a1 a2 :
  addr_minus_ok Γ (cmap_erase m) a1 a2 = addr_minus_ok Γ m a1 a2.
Proof. unfold addr_minus_ok. by rewrite !index_alive_erase'. Qed.

Lemma addr_cast_typed Γ Δ m a σp τp :
  (Γ,Δ) ⊢ a : σp → addr_cast_ok Γ m τp a → (Γ,Δ) ⊢ addr_cast τp a : τp.
Proof. intros [] (?&?&?); constructor; eauto. Qed.
Lemma addr_cast_ok_weaken Γ1 Γ2 Δ1 m1 m2 a σp τp :
  ✓ Γ1 → (Γ1,Δ1) ⊢ a : σp →
  (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  addr_cast_ok Γ1 m1 τp a → Γ1 ⊆ Γ2 → addr_cast_ok Γ2 m2 τp a.
Proof.
  intros ??? (?&?&?) ?; repeat split; auto. destruct τp as [τ| |]; simpl; auto.
  by erewrite <-size_of_weaken
    by eauto using castable_type_valid, addr_typed_type_base_valid.
Qed.
Lemma addr_cast_ok_erase Γ m a τp :
  addr_cast_ok Γ (cmap_erase m) τp a = addr_cast_ok Γ m τp a.
Proof. unfold addr_cast_ok. by rewrite !index_alive_erase'. Qed.
Lemma addr_type_cast a σp : type_of (addr_cast σp a) = σp.
Proof. by destruct a. Qed.
Lemma addr_index_cast a σp : addr_index (addr_cast σp a) = addr_index a.
Proof. by destruct a. Qed.
Lemma addr_ref_cast Γ a σp : addr_ref Γ (addr_cast σp a) = addr_ref Γ a.
Proof. by destruct a. Qed.
Lemma addr_ref_byte_cast Γ a σp :
  addr_ref_byte Γ (addr_cast σp a) = addr_ref_byte Γ a.
Proof. by destruct a. Qed.
Lemma addr_cast_self Γ Δ a σp : (Γ,Δ) ⊢ a : σp → addr_cast σp a = a.
Proof. by destruct 1. Qed.
Lemma addr_is_obj_cast a σp :
  addr_is_obj (addr_cast σp a) ↔ σp = TType (addr_type_base a).
Proof. by destruct a. Qed.
Lemma addr_ref_plus_char_cast Γ Δ a σp j :
  ✓ Γ → (Γ,Δ) ⊢ a : σp → addr_is_obj a → j < ptr_size_of Γ σp →
  addr_ref Γ (addr_plus Γ j (addr_cast (TType ucharT) a)) = addr_ref Γ a.
Proof.
  destruct 2 as [o r i τ σ σp ?????]; intros ??; simplify_equality'; f_equal.
  rewrite size_of_char, Z.mul_1_r, Z2Nat.inj_add, !Nat2Z.id by auto with zpos.
  symmetry. apply Nat.div_unique with (i `mod` size_of Γ σ + j).
  { by rewrite (λ x y H, proj2 (Nat.mod_divide x y H))
      by eauto using size_of_ne_0, ref_typed_type_valid. }
  by rewrite Nat.add_assoc, <-Nat.div_mod
    by eauto using ref_typed_type_valid, size_of_ne_0.
Qed.
Lemma addr_ref_byte_plus_char_cast Γ Δ a σp j :
  ✓ Γ → (Γ,Δ) ⊢ a : σp → addr_is_obj a → j < ptr_size_of Γ σp →
  addr_ref_byte Γ (addr_plus Γ j (addr_cast (TType ucharT) a)) = j.
Proof.
  destruct 2 as [o r i τ σ σp]; intros; simplify_equality'.
  rewrite size_of_char, Z.mul_1_r, Z2Nat.inj_add, !Nat2Z.id by auto with zpos.
  rewrite <-Nat.add_mod_idemp_l, (λ y H, proj2 (Nat.mod_divide i y H)),
    Nat.add_0_l by eauto using ref_typed_type_valid, size_of_ne_0.
  by apply Nat.mod_small.
Qed.
Lemma addr_byte_lt_size_char_cast Γ Δ a σp j :
  ✓ Γ → (Γ,Δ) ⊢ a : σp → addr_is_obj a → j < ptr_size_of Γ σp →
  addr_byte a < size_of Γ (addr_type_base a) * ref_size (addr_ref_base a) →
  addr_byte (addr_plus Γ j (addr_cast (TType ucharT) a))
    < size_of Γ (addr_type_base a) * ref_size (addr_ref_base a).
Proof.
  destruct 2 as [o r i τ σ σp ????? Hi]; intros; simplify_equality'.
  rewrite size_of_char, Z.mul_1_r,Z2Nat.inj_add, !Nat2Z.id by auto with zpos.
  apply Nat.lt_le_trans with (i + size_of Γ σ); [lia|].
  destruct Hi as [? ->].
  rewrite <-Nat.mul_succ_l, Nat.mul_comm, <-Nat.mul_le_mono_pos_l,
    Nat.le_succ_l, (Nat.mul_lt_mono_pos_r (size_of Γ σ))
    by eauto using ref_typed_type_valid, size_of_pos; lia.
Qed.

(** ** Properties of operations on pointers *)
#[global] Instance ptr_alive_dec' m p : Decision (ptr_alive' m p).
Proof.
 refine
  match p with
  | Ptr a => decide (index_alive' m (addr_index a)) | _ => left _
  end; done.
Defined.
Lemma ptr_alive_weaken' m1 m2 p :
  ptr_alive' m1 p → (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  ptr_alive' m2 p.
Proof. destruct p; simpl; auto. Qed.
Lemma ptr_alive_1' m p : ptr_alive' m p → ptr_alive '{m} p.
Proof. destruct p; simpl; eauto. Qed.
Hint Resolve ptr_alive_1': core.
Lemma ptr_alive_erase' m p : ptr_alive' (cmap_erase m) p = ptr_alive' m p.
Proof. unfold ptr_alive'. by destruct p; rewrite ?index_alive_erase'. Qed.
#[global] Instance ptr_compare_ok_dec Γ m c p1 p2 :
  Decision (ptr_compare_ok Γ m c p1 p2).
Proof. destruct p1, p2, c; apply _. Defined.
#[global] Instance ptr_plus_ok_dec Γ m j p : Decision (ptr_plus_ok Γ m j p).
Proof. destruct p; simpl; apply _. Defined.
#[global] Instance ptr_minus_ok_dec Γ m p1 p2 : Decision (ptr_minus_ok Γ m p1 p2).
Proof. destruct p1, p2; apply _. Defined.
#[global] Instance ptr_cast_ok_dec Γ m σp p : Decision (ptr_cast_ok Γ m σp p).
Proof. destruct p; apply _. Defined.

#[global] Instance ptr_cast_typed_dec τp σp : Decision (ptr_cast_typed τp σp).
Proof.
 refine
  match τp, σp with
  | (TType _|TAny), TAny | TAny, TType _ => left _
  | TType τ1, TType τ2 => cast_if (decide (τ1 = τ2 ∨ τ2 = ucharT ∨ τ1 = ucharT))
  | τs1 ~> τ1, τs2 ~> τ2 => cast_if_and (decide (τs1 = τs2)) (decide (τ1 = τ2))
  | _, _ => right _
  end%BT;
  abstract first [by intuition; subst; constructor |by inversion 1; intuition].
Defined.

Lemma ptr_plus_typed Γ Δ m p σp j :
  ✓ Γ → (Γ,Δ) ⊢ p : σp → ptr_plus_ok Γ m j p →
  (Γ,Δ) ⊢ ptr_plus Γ j p : σp.
Proof. destruct 2; simpl; constructor; eauto using addr_plus_typed. Qed.
Lemma ptr_minus_typed Γ m p1 p2 :
  ptr_minus_ok Γ m p1 p2 → int_typed (ptr_minus Γ p1 p2) sptrT.
Proof.
  destruct p1,p2; simpl; eauto using addr_minus_typed, int_typed_small with lia.
Qed.
Lemma ptr_cast_typed' Γ Δ m p τp σp :
  (Γ,Δ) ⊢ p : τp → ptr_cast_typed τp σp → ✓{Γ} σp →
  ptr_cast_ok Γ m σp p → (Γ,Δ) ⊢ ptr_cast σp p : σp.
Proof.
  destruct 1; inversion 1; intros; simplify_equality';
    constructor; eauto using addr_cast_typed.
Qed.
Lemma ptr_cast_typed_self τp : ptr_cast_typed τp τp.
Proof. destruct τp; constructor. Qed.

Lemma ptr_compare_ok_weaken Γ1 Γ2 Δ1 m1 m2 c p1 p2 τp1 τp2 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ p1 : τp1 → (Γ1,Δ1) ⊢ p2 : τp2 →
  ptr_compare_ok Γ1 m1 c p1 p2 →
  Γ1 ⊆ Γ2 → (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  ptr_compare_ok Γ2 m2 c p1 p2.
Proof.
  destruct 2, 1; simpl; repeat case_match; eauto using addr_compare_ok_weaken.
Qed.
Lemma ptr_compare_ok_erase Γ m c p1 p2:
  ptr_compare_ok Γ (cmap_erase m) c p1 p2 = ptr_compare_ok Γ m c p1 p2.
Proof.
  unfold ptr_compare_ok.
  by destruct p1, p2; rewrite ?index_alive_erase', ?addr_compare_ok_erase.
Qed.
Lemma ptr_compare_weaken Γ1 Γ2 Δ1 c p1 p2 τp1 τp2 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ p1 : τp1 → (Γ1,Δ1) ⊢ p2 : τp2 →
  Γ1 ⊆ Γ2 → ptr_compare Γ1 c p1 p2 = ptr_compare Γ2 c p1 p2.
Proof. destruct 2, 1; simpl; intros; eauto 2 using addr_compare_weaken. Qed.
Lemma ptr_plus_ok_weaken Γ1 Γ2 Δ1 m1 m2 p τp j :
  ✓ Γ1 → (Γ1,Δ1) ⊢ p : τp → ptr_plus_ok Γ1 m1 j p →
  Γ1 ⊆ Γ2 → (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  ptr_plus_ok Γ2 m2 j p.
Proof. destruct 2; simpl; eauto using addr_plus_ok_weaken. Qed.
Lemma ptr_plus_ok_erase Γ m j p :
  ptr_plus_ok Γ (cmap_erase m) j p = ptr_plus_ok Γ m j p.
Proof. destruct p; simpl; auto using addr_plus_ok_erase. Qed.
Lemma ptr_plus_weaken Γ1 Γ2 Δ1 p τp j :
  ✓ Γ1 → (Γ1,Δ1) ⊢ p : τp → Γ1 ⊆ Γ2 → ptr_plus Γ1 j p = ptr_plus Γ2 j p.
Proof. destruct 2; simpl; eauto using addr_plus_weaken, f_equal. Qed.
Lemma ptr_minus_ok_weaken Γ1 Γ2 Δ1 m1 m2 p1 p2 τp1 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ p1 : τp1 → ptr_minus_ok Γ1 m1 p1 p2 → Γ1 ⊆ Γ2 →
  (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  ptr_minus_ok Γ2 m2 p1 p2.
Proof. destruct 2, p2; simpl; eauto using addr_minus_ok_weaken. Qed.
Lemma ptr_minus_ok_erase Γ m p1 p2 :
  ptr_minus_ok Γ (cmap_erase m) p1 p2 = ptr_minus_ok Γ m p1 p2.
Proof. destruct p1, p2; simpl; auto using addr_minus_ok_erase. Qed.
Lemma ptr_minus_weaken Γ1 Γ2 Δ1 p1 p2 τp1 τp2 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ p1 : τp1 → (Γ1,Δ1) ⊢ p2 : τp2 →
  Γ1 ⊆ Γ2 → ptr_minus Γ1 p1 p2 = ptr_minus Γ2 p1 p2.
Proof. destruct 2, 1; simpl; eauto using addr_minus_weaken. Qed.
Lemma ptr_cast_ok_weaken Γ1 Γ2 Δ1 m1 m2 p τp σp :
  ✓ Γ1 → (Γ1,Δ1) ⊢ p : τp → ptr_cast_ok Γ1 m1 σp p → Γ1 ⊆ Γ2 →
  (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  ptr_cast_ok Γ2 m2 σp p.
Proof. destruct 2; simpl; eauto using addr_cast_ok_weaken. Qed.
Lemma ptr_cast_ok_erase Γ m p τp :
  ptr_cast_ok Γ (cmap_erase m) τp p = ptr_cast_ok Γ m τp p.
Proof. destruct p; simpl; auto using addr_cast_ok_erase. Qed.
Lemma ptr_compare_ok_alive_l Γ m c p1 p2 :
  ptr_compare_ok Γ m c p1 p2 → ptr_alive '{m} p1.
Proof.
  destruct p1,p2,c; simpl; unfold addr_minus_ok, addr_compare_ok; naive_solver.
Qed.
Lemma ptr_compare_ok_alive_r Γ m c p1 p2 :
  ptr_compare_ok Γ m c p1 p2 → ptr_alive '{m} p2.
Proof.
  destruct p1 as [|[]|], p2 as [|[]|], c;
    csimpl; unfold addr_compare_ok; naive_solver.
Qed.
Lemma ptr_plus_ok_alive Γ m p j : ptr_plus_ok Γ m j p → ptr_alive '{m} p.
Proof. destruct p. done. intros [??]; simpl; eauto. done. Qed.
Lemma ptr_minus_ok_alive_l Γ m p1 p2 :
  ptr_minus_ok Γ m p1 p2 → ptr_alive '{m} p1.
Proof. destruct p1, p2; simpl; try done. intros [??]; eauto. Qed.
Lemma ptr_minus_ok_alive_r Γ m p1 p2 :
  ptr_minus_ok Γ m p1 p2 → ptr_alive '{m} p2.
Proof. destruct p1, p2; simpl; try done. intros (?&<-&?); eauto. Qed.
Lemma ptr_cast_ok_alive Γ m p σp : ptr_cast_ok Γ m σp p → ptr_alive '{m} p.
Proof. destruct p; simpl. done. intros [??]; eauto. done. Qed.

(** ** Properties of operations on base values *)
#[global] Instance base_val_branchable_dec m vb :
  Decision (base_val_branchable m vb).
Proof. destruct vb; apply _. Defined.
#[global] Instance base_val_is_0_dec vb : Decision (base_val_is_0 vb).
Proof.
 refine
  match vb with
  | VInt _ x => decide (x = 0) | VPtr (NULL _) => left _ | _ => right _
  end; abstract naive_solver.
Defined.
Lemma base_val_branchable_weaken m1 m2 vb :
  base_val_branchable m1 vb →
  (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  base_val_branchable m2 vb.
Proof. destruct vb; simpl; eauto using ptr_alive_weaken'. Qed.
Lemma base_val_branchable_erase m vb :
  base_val_branchable (cmap_erase m) vb = base_val_branchable m vb.
Proof. by destruct vb; simpl; rewrite ?ptr_alive_erase'. Qed.
Lemma base_val_is_0_branchable m vb :
  base_val_is_0 vb → base_val_branchable m vb.
Proof. by destruct vb as [| | |[]|]. Qed.

#[global] Instance base_val_unop_ok_dec m op vb :
  Decision (base_val_unop_ok m op vb).
Proof. destruct vb, op; try apply _. Defined.
#[global] Instance base_val_binop_ok_dec Γ m op vb1 vb2 :
  Decision (base_val_binop_ok Γ m op vb1 vb2).
Proof.
  destruct vb1, vb2, op as [|op| |]; try apply _; destruct op; apply _.
Defined.
#[global] Instance base_val_cast_ok_dec Γ m σb vb :
  Decision (base_val_cast_ok Γ m σb vb).
Proof. destruct vb, σb; simpl; apply _. Defined.

Lemma base_unop_typed_type_valid Γ op τb σb :
  base_unop_typed op τb σb → ✓{Γ} τb → ✓{Γ} σb.
Proof. destruct 1; constructor. Qed.
Lemma base_binop_typed_type_valid Γ op τb1 τb2 σb :
  base_binop_typed op τb1 τb2 σb → ✓{Γ} τb1 → ✓{Γ} τb2 → ✓{Γ} σb.
Proof. destruct 1; eauto using TInt_valid. Qed.
Lemma base_unop_type_of_sound op τb σb :
  base_unop_type_of op τb = Some σb → base_unop_typed op τb σb.
Proof. destruct τb, op; intros; simplify_option_eq; constructor. Qed.
Lemma base_unop_type_of_complete op τb σb :
  base_unop_typed op τb σb → base_unop_type_of op τb = Some σb.
Proof. by destruct 1; simplify_option_eq. Qed.
Lemma base_binop_type_of_sound op τb1 τb2 σb :
  base_binop_type_of op τb1 τb2 = Some σb → base_binop_typed op τb1 τb2 σb.
Proof.
  destruct τb1, τb2, op; intros;
    repeat (case_match || simplify_option_eq); constructor.
Qed.
Lemma base_binop_type_of_complete op τb1 τb2 σb :
  base_binop_typed op τb1 τb2 σb → base_binop_type_of op τb1 τb2 = Some σb.
Proof. by destruct 1; simplify_option_eq; repeat case_match. Qed.
#[global] Instance base_cast_typed_dec τb σb: Decision (base_cast_typed τb σb).
Proof.
 refine
  match τb, σb with
  | _, voidT | intT _, intT _ => left _
  | τp1.*, τp2.* => cast_if (decide (ptr_cast_typed τp1 τp2))
  | _, _ => right _
  end%BT; abstract first [by constructor|by inversion 1].
Defined.

Lemma base_val_0_typed Γ Δ τb : ✓{Γ} τb → (Γ,Δ) ⊢ base_val_0 τb : τb.
Proof.
  destruct 1; simpl; constructor. by apply int_typed_small. by constructor.
Qed.
Lemma base_val_unop_ok_weaken m1 m2 op vb :
  base_val_unop_ok m1 op vb →
  (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  base_val_unop_ok m2 op vb.
Proof. destruct vb, op; simpl; eauto using ptr_alive_weaken'. Qed.
Lemma base_val_unop_ok_erase m op vb :
  base_val_unop_ok (cmap_erase m) op vb = base_val_unop_ok m op vb.
Proof. destruct op, vb; simpl; auto using ptr_alive_erase'. Qed.
Lemma base_val_unop_typed Γ Δ m op vb τb σb :
  (Γ,Δ) ⊢ vb : τb → base_unop_typed op τb σb →
  base_val_unop_ok m op vb → (Γ,Δ) ⊢ base_val_unop op vb : σb.
Proof.
  unfold base_val_unop_ok, base_val_unop. intros Hvτb Hσ Hop.
  destruct Hσ; inversion Hvτb; simplify_equality'; try done.
  * typed_constructor. by apply int_unop_typed.
  * typed_constructor. by apply int_typed_small; case_match.
Qed.
Lemma base_val_binop_ok_weaken Γ1 Γ2 Δ1 m1 m2 op vb1 vb2 τb1 τb2 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ vb1 : τb1 → (Γ1,Δ1) ⊢ vb2 : τb2 →
  base_val_binop_ok Γ1 m1 op vb1 vb2 → Γ1 ⊆ Γ2 →
  (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  base_val_binop_ok Γ2 m2 op vb1 vb2.
Proof.
  destruct 2, 1, op as [|[]| |]; simpl; auto; eauto 2 using
    ptr_plus_ok_weaken, ptr_minus_ok_weaken, ptr_compare_ok_weaken.
Qed.
Lemma base_val_binop_ok_erase Γ m op vb1 vb2 :
  base_val_binop_ok Γ (cmap_erase m) op vb1 vb2
  = base_val_binop_ok Γ m op vb1 vb2.
Proof.
 destruct op as [|[]| |], vb1, vb2; simpl;
   auto using ptr_plus_ok_erase, ptr_compare_ok_erase, ptr_minus_ok_erase.
Qed.
Lemma base_val_binop_weaken Γ1 Γ2 Δ1 op vb1 vb2 τb1 τb2 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ vb1 : τb1 → (Γ1,Δ1) ⊢ vb2 : τb2 → Γ1 ⊆ Γ2 →
  base_val_binop Γ1 op vb1 vb2 = base_val_binop Γ2 op vb1 vb2.
Proof.
  destruct 2, 1, op as [|[]| |]; intros; f_equal';
    eauto 2 using ptr_plus_weaken, ptr_minus_weaken.
  by erewrite ptr_compare_weaken by eauto.
Qed.
Lemma base_val_binop_typed Γ Δ m op vb1 vb2 τb1 τb2 σb :
  ✓ Γ → (Γ,Δ) ⊢ vb1 : τb1 → (Γ,Δ) ⊢ vb2 : τb2 →
  base_binop_typed op τb1 τb2 σb → base_val_binop_ok Γ m op vb1 vb2 →
  (Γ,Δ) ⊢ base_val_binop Γ op vb1 vb2 : σb.
Proof.
  intros HΓ Hv1τb Hv2τb Hσ Hop. revert Hv1τb Hv2τb.
  unfold base_val_binop_ok, base_val_binop in *;
    destruct Hσ; inversion 1; inversion 1; simplify_equality'; try done.
  * typed_constructor. by apply int_binop_typed.
  * typed_constructor. by case_match; apply int_typed_small.
  * typed_constructor. eapply ptr_plus_typed; eauto.
  * typed_constructor. eapply ptr_plus_typed; eauto.
  * typed_constructor. eapply ptr_plus_typed; eauto.
  * typed_constructor. eapply ptr_plus_typed; eauto.
  * typed_constructor. eapply ptr_minus_typed; eauto.
Qed.
Lemma base_cast_typed_self τb : base_cast_typed τb τb.
Proof. destruct τb; constructor; auto using ptr_cast_typed_self. Qed.
Lemma base_val_cast_ok_weaken Γ1 Γ2 Δ1 m1 m2 vb τb σb :
  ✓ Γ1 → (Γ1,Δ1) ⊢ vb : τb → base_val_cast_ok Γ1 m1 σb vb →
  Γ1 ⊆ Γ2 → (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  base_val_cast_ok Γ2 m2 σb vb.
Proof.
  destruct 2, σb; simpl; eauto using ptr_cast_ok_weaken, ptr_alive_weaken'.
Qed.
Lemma base_val_cast_ok_erase Γ m vb τb :
  base_val_cast_ok Γ (cmap_erase m) τb vb = base_val_cast_ok Γ m τb vb.
Proof.
  destruct vb, τb; simpl; auto using ptr_cast_ok_erase, ptr_alive_erase'.
Qed.
Lemma base_val_cast_typed Γ Δ m vb τb σb :
  ✓ Γ → (Γ,Δ) ⊢ vb : τb → base_cast_typed τb σb → ✓{Γ} σb →
  base_val_cast_ok Γ m σb vb → (Γ,Δ) ⊢ base_val_cast σb vb : σb.
Proof.
  unfold base_val_cast_ok, base_val_cast. intros ? Hvτb Hcast Hσb Hok.
  revert Hvτb.
  destruct Hcast; inversion 1; simplify_equality'; try (done || by constructor).
  * intuition; simplify_equality. by typed_constructor.
  * typed_constructor. by apply int_cast_typed.
  * typed_constructor; eauto using ptr_cast_typed', TPtr_valid_inv.
Qed.
Lemma base_val_cast_ok_void Γ m vb :
  (Γ,'{m}) ⊢ vb : ucharT%BT → base_val_cast_ok Γ m voidT%BT vb.
Proof. by inversion 1. Qed.
Lemma base_val_cast_void vb : base_val_cast voidT vb = VVoid.
Proof. by destruct vb. Qed.

(** ** Properties of operations on values *)
Lemma val_0_base Γ τb : val_0 Γ τb = VBase (base_val_0 τb).
Proof. unfold val_0. by rewrite type_iter_base. Qed.
Lemma val_0_array Γ τ n :
  val_0 Γ (τ.[n]) = VArray τ (replicate n (val_0 Γ τ)).
Proof. unfold val_0. by rewrite type_iter_array. Qed.
Lemma val_0_compound Γ c t τs :
  ✓ Γ → Γ !! t = Some τs → val_0 Γ (compoundT{c} t) =
    match c with
    | Struct_kind => VStruct t (val_0 Γ <$> τs)
    | Union_kind => VUnion t 0 (from_option (val_0 Γ) (VUnionAll t []) (τs !! 0))
    end.
Proof.
  intros HΓ Ht. unfold val_0; erewrite (type_iter_compound (=)); try done.
  { by intros ????? ->. }
  clear t τs Ht. intros ?? [] ? τs ?? Hgo; f_equal'; [|by destruct Hgo].
  by apply Forall_fmap_ext.
Qed.
Lemma val_0_weaken Γ1 Γ2 τ :
  ✓ Γ1 → ✓{Γ1} τ → Γ1 ⊆ Γ2 → val_0 Γ1 τ = val_0 Γ2 τ.
Proof.
  intros. apply (type_iter_weaken (=)); try done; [by intros ????? ->|].
  intros ?? [] ? τs ?? Hgo; f_equal'; [|by destruct Hgo].
  by apply Forall_fmap_ext.
Qed.
Lemma val_0_typed Γ Δ τ : ✓ Γ → ✓{Γ} τ → (Γ,Δ) ⊢ val_0 Γ τ : τ.
Proof.
  intros HΓ. revert τ. refine (type_env_ind _ HΓ _ _ _ _).
  * intros τb. rewrite val_0_base.
    typed_constructor; auto using base_val_0_typed.
  * intros τ n ???. rewrite val_0_array.
    typed_constructor; auto using replicate_length, Forall_replicate.
  * intros [] t τs Ht _ IH ?; erewrite val_0_compound by eauto.
    { typed_constructor; eauto. elim IH; csimpl; auto. }
    by destruct IH; simplify_equality'; typed_constructor; eauto.
Qed.

#[global] Instance val_unop_ok_dec m op v : Decision (val_unop_ok m op v).
Proof. destruct v; try apply _. Defined.
#[global] Instance val_binop_ok_dec Γ m op v1 v2 :
  Decision (val_binop_ok Γ m op v1 v2).
Proof. destruct v1, v2; apply _. Defined.
#[global] Instance val_cast_ok_dec Γ m σp v : Decision (val_cast_ok Γ m σp v).
Proof. destruct v, σp as [[[]| |]| |]; apply _. Defined.

Lemma unop_typed_type_valid Γ op τ σ : unop_typed op τ σ → ✓{Γ} τ → ✓{Γ} σ.
Proof.
  destruct 1; eauto using TBase_valid,
    TBase_valid_inv, base_unop_typed_type_valid.
Qed.
Lemma binop_typed_type_valid Γ op τ1 τ2 σ :
  binop_typed op τ1 τ2 σ → ✓{Γ} (TType τ1) → ✓{Γ} (TType τ2) → ✓{Γ} σ.
Proof.
  destruct 1; do 2 inversion 1;
    eauto using TBase_valid, base_binop_typed_type_valid.
Qed.
Lemma cast_typed_type_valid Γ τ σ :
  cast_typed τ σ → ✓{Γ} τ → ✓{Γ} (TType σ) → ✓{Γ} σ.
Proof. destruct 1; eauto using TBase_ptr_valid_inv, TBase_valid. Qed.
Lemma unop_type_of_sound op τ σ :
  unop_type_of op τ = Some σ → unop_typed op τ σ.
Proof.
  destruct τ; intros; simplify_option_eq; constructor.
  auto using base_unop_type_of_sound.
Qed.
Lemma unop_type_of_complete op τ σ :
  unop_typed op τ σ → unop_type_of op τ = Some σ.
Proof.
  destruct 1; simplify_option_eq.
  by erewrite base_unop_type_of_complete by eauto.
Qed.
Lemma binop_type_of_sound op τ1 τ2 σ :
  binop_type_of op τ1 τ2 = Some σ → binop_typed op τ1 τ2 σ.
Proof.
  destruct τ1, τ2; intros; simplify_option_eq; constructor.
  by apply base_binop_type_of_sound.
Qed.
Lemma binop_type_of_complete op τ1 τ2 σ :
  binop_typed op τ1 τ2 σ → binop_type_of op τ1 τ2 = Some σ.
Proof.
  destruct 1; simplify_option_eq.
  by erewrite base_binop_type_of_complete by eauto.
Qed.
#[global] Instance cast_typed_dec τ σ : Decision (cast_typed τ σ).
Proof.
 refine
  match decide (τ = σ) with
  | left _ => left _
  | right Hτσ =>
    match τ, σ return τ ≠ σ → Decision (cast_typed τ σ) with
    | baseT τb, baseT σb => λ _, cast_if (decide (base_cast_typed τb σb))
    | _, baseT σb => λ _, cast_if (decide (σb = voidT%BT))
    | _, _ => λ _, right _
    end Hτσ
  end; abstract first
   [ by subst; constructor
   | by inversion 1; subst; eauto using base_cast_typed_self, TVoid_cast_typed].
Defined.
Lemma val_unop_ok_weaken m1 m2 op v :
  val_unop_ok m1 op v → (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  val_unop_ok m2 op v.
Proof. unfold val_unop_ok; destruct v; eauto using base_val_unop_ok_weaken. Qed.
Lemma val_unop_ok_erase m op v :
  val_unop_ok (cmap_erase m) op v = val_unop_ok m op v.
Proof.
  unfold val_unop_ok; destruct v; simpl; auto using base_val_unop_ok_erase.
Qed.
Lemma val_unop_typed Γ Δ m op v τ σ :
  (Γ,Δ) ⊢ v : τ → unop_typed op τ σ → val_unop_ok m op v →
  (Γ,Δ) ⊢ val_unop op v : σ.
Proof.
  intros Hvτ Hσ Hop. destruct Hσ; inversion Hvτ; simpl; simplify_equality;
    done || constructor; eauto using base_val_unop_typed.
Qed.
Lemma val_binop_ok_weaken Γ1 Γ2 Δ1 m1 m2 op v1 v2 τ1 τ2 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ v1 : τ1 → (Γ1,Δ1) ⊢ v2 : τ2 →
  val_binop_ok Γ1 m1 op v1 v2 → Γ1 ⊆ Γ2 →
  (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  val_binop_ok Γ2 m2 op v1 v2.
Proof.
  destruct 2, 1, op; simpl; try done; eauto 2 using base_val_binop_ok_weaken.
Qed.
Lemma val_binop_ok_erase Γ m op v1 v2 :
  val_binop_ok Γ (cmap_erase m) op v1 v2 = val_binop_ok Γ m op v1 v2.
Proof.
  unfold val_binop_ok; destruct v1,v2; simpl;auto using base_val_binop_ok_erase.
Qed.
Lemma val_binop_weaken Γ1 Γ2 Δ1 op v1 v2 τ1 τ2 :
  ✓ Γ1 → (Γ1,Δ1) ⊢ v1 : τ1 → (Γ1,Δ1) ⊢ v2 : τ2 → Γ1 ⊆ Γ2 →
  val_binop Γ1 op v1 v2 = val_binop Γ2 op v1 v2.
Proof.
  destruct 2, 1, op; intros; f_equal'; eauto 2 using base_val_binop_weaken.
Qed.
Lemma val_binop_typed Γ Δ m op v1 v2 τ1 τ2 σ :
  ✓ Γ → (Γ,Δ) ⊢ v1 : τ1 → (Γ,Δ) ⊢ v2 : τ2 →
  binop_typed op τ1 τ2 σ → val_binop_ok Γ m op v1 v2 →
  (Γ,Δ) ⊢ val_binop Γ op v1 v2 : σ.
Proof.
  intros ? Hv1τ Hv2τ Hσ Hop.
  destruct Hσ; inversion Hv1τ; inversion Hv2τ; simplify_equality';
    done || constructor; eauto using base_val_binop_typed.
Qed.
Lemma val_cast_ok_weaken Γ1 Γ2 Δ1 m1 m2 v τ σ :
  ✓ Γ1 → (Γ1,Δ1) ⊢ v : τ → val_cast_ok Γ1 m1 (TType σ) v →
  Γ1 ⊆ Γ2 → (∀ o, index_alive '{m1} o → index_alive '{m2} o) →
  val_cast_ok Γ2 m2 (TType σ) v.
Proof. destruct 2, σ; simpl; eauto using base_val_cast_ok_weaken. Qed.
Lemma val_cast_ok_erase Γ m v τp :
  val_cast_ok Γ (cmap_erase m) τp v = val_cast_ok Γ m τp v.
Proof. destruct v, τp as [[]| |]; simpl; auto using base_val_cast_ok_erase. Qed.
Lemma val_cast_typed Γ Δ m v τ σ :
  ✓ Γ → (Γ,Δ) ⊢ v : τ → cast_typed τ σ → ✓{Γ} σ →
  val_cast_ok Γ m (TType σ) v → (Γ,Δ) ⊢ val_cast (TType σ) v : σ.
Proof.
  intros ? Hvτ Hcast Hσ Hok.
  destruct Hcast; inversion Hσ; inversion Hvτ; simplify_equality';
    repeat typed_constructor;
    eauto using base_val_cast_typed, TVoid_cast_typed, base_cast_typed_self.
Qed.
End operations.


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 X1 X2 X3 D E F : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ A E /\ (wd_ A F /\ (wd_ B D /\ (wd_ B F /\ (wd_ C D /\ (wd_ C E /\ (wd_ A X3 /\ (wd_ B X2 /\ (wd_ C X1 /\ (col_ D B X2 /\ (col_ D C X1 /\ (col_ E A X3 /\ (col_ E C X1 /\ (col_ F A X3 /\ col_ F B X2))))))))))))))))) -> col_ A E F)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* 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                                                     *)

(** * subspaces.v *)
Section MAIN.
Set Implicit Arguments.
Unset Strict Implicit.
Require Export vecspaces_verybasic.
Require Export arb_intersections.
From Algebra Require Export Sub_module.
From Algebra Require Export Singleton.
Require Export algebra_omissions.

Variable F : field.
Variable V : vectorspace F.
Section Subspace_def.

(** %\tocdef{subspace}% *)
Definition subspace (F : field) (V : vectorspace F) := submodule V.

(** - Some finger-flexing first *)
Variable W : subspace V.
Definition inj_subspace : Hom (W:VECSP F) V.
apply
 (BUILD_HOM_MODULE (R:=F) (Mod:=W:VECSP F) (Mod':=V)
    (ff:=fun x : W => subtype_elt x)); auto with algebra.
Defined.
(* This injects the subspace into its "parent" space *)

Lemma inj_subspace_injective : injective inj_subspace.
red in |- *.
auto with algebra.
Qed.

Lemma mult_inherited :
 forall (c : F) (x : W), inj_subspace (c mX x) =' c mX inj_subspace x in _.
intros.
case inj_subspace.
intros.
simpl in |- *.
apply module_hom_prf.
Qed.
End Subspace_def.

Section subspace_awkward_utils.
(** - Officially, "a subspace is a subset that is itself a vectorspace..." We cannot
 have both W:(part_set V) and W:(subspace V). Therefore we need to define subspace-ness
 on the predicate-level as well. *)
(** %\tocdef{is\_subspace}% *)
Definition is_subspace (W : part_set V) : Prop :=
  in_part (zero V) W /\
  (forall x y : V, in_part x W -> in_part y W -> in_part (x +' y) W) /\
  (forall (c : F) (x : V), in_part x W -> in_part (c mX x) W).

Lemma is_subspace_comp :
 forall S S' : part_set V, S =' S' in _ -> is_subspace S -> is_subspace S'.
intros.
red in |- *.
red in H0.
inversion_clear H0.
inversion_clear H2.
split.
apply in_part_comp_r with S; auto with algebra.
split.
intros.
apply in_part_comp_r with S; auto with algebra.
apply H0; auto with algebra.
apply in_part_comp_r with S'; auto with algebra.
apply in_part_comp_r with S'; auto with algebra.
intros.
apply in_part_comp_r with S; auto with algebra.
apply H3; auto with algebra.
apply in_part_comp_r with S'; auto with algebra.
Qed.

(** - From the predicate, then, we may define (uniformly) a subspace having the
 part_set as a carrier *)
Definition subspace_construction :
  forall Ws : part_set V,
  is_subspace Ws -> sigT (fun W : subspace V => W =' Ws in part_set V).
unfold is_subspace in |- *.
intros Ws (H1, (H2, H3)).
cut (sigT (fun Wmod : submodule V => Wmod =' Ws in part_set V)).
intro.
inversion_clear X.
exists x.
assumption.
cut (sigT (fun Wgp : subgroup V => Wgp =' Ws in part_set V)).
intro.
inversion_clear X.
exists
 (Build_submodule
    (fun (a : F) (v : V) (Hyp : in_part v (x:part_set V)) =>
     in_part_comp_r (H3 a v (in_part_comp_r Hyp H)) (Sym H))).
simpl in |- *.
assumption.
cut (sigT (fun Wmon : submonoid V => Wmon =' Ws in part_set V)).
intro.
inversion X.
cut (forall v : V, (min one) mX v =' (min v) in _).
intro.
exists
 (Build_subgroup
    (fun (v : V) (Hyp : in_part v (x:part_set V)) =>
     in_part_comp_r
       (in_part_comp_l (H3 (min one) v (in_part_comp_r Hyp H)) (Sym (H0 v)))
       (Sym H))).
simpl in |- *.
assumption.
intro.
apply Trans with (min one mX v); auto with algebra.
cut (sigT (fun Wsgp : subsgroup V => Wsgp =' Ws in part_set V)).
intro.
inversion_clear X.
exists (Build_submonoid (in_part_comp_r H1 (Sym H))).
simpl in |- *.
assumption.
exists
 (Build_subsgroup
    (fun (x y : V) (Hx : in_part x Ws) (Hy : in_part y Ws) => H2 x y Hx Hy)).
simpl in |- *.
exact
 (fun x : V =>
  conj (fun Hx : in_part x Ws => Hx) (fun Hx : in_part x Ws => Hx)).
Defined.

Definition alt_Build_subspace (W : part_set V) (H : is_subspace W) :
  subspace V := let (w, _) := subspace_construction H in w.

Lemma alt_Build_subspace_OK :
 forall (W : part_set V) (HW : is_subspace W),
 W =' alt_Build_subspace HW in _.
intros.
unfold alt_Build_subspace in |- *.
case (subspace_construction HW).
auto with algebra.
Qed.

Lemma is_subspace_OK : forall W : subspace V, is_subspace W.
intro.
split; try split; auto with algebra.
Qed.

(** - %\intoc{\bf Theorem 1.3}% literally (more-or-less; now easy to prove): *)
Lemma subspace_alt_characterization :
 forall Ws : part_set V,
 in_part (zero V) Ws /\
 (forall x y : V, in_part x Ws -> in_part y Ws -> in_part (x +' y) Ws) /\
 (forall (c : F) (x : V), in_part x Ws -> in_part (c mX x) Ws) <->
 (exists W : subspace V, W =' Ws in part_set V).
split.
intros.
elim (subspace_construction H).
intros.
exists x; auto.
intro; inversion_clear H.
generalize (is_subspace_OK x).
intro H; red in H; split; try split; intuition;
 (apply in_part_comp_r with (x:part_set V); auto with algebra).
apply H; auto with algebra; (apply in_part_comp_r with Ws; auto with algebra).
apply H3; auto with algebra;
 (apply in_part_comp_r with Ws; auto with algebra).
Qed.

Definition Set_of_subspaces : part_set (part_set V).
apply (Build_Predicate (Pred_fun:=fun W => is_subspace W)).
red in |- *.
intros.
red in |- *; red in H.
inversion_clear H.
inversion_clear H2.
split; try split.
apply in_part_comp_r with x; auto with algebra.
intros; (apply in_part_comp_r with x; auto with algebra).
apply H; auto with algebra.
apply in_part_comp_r with y; auto with algebra.
apply in_part_comp_r with y; auto with algebra.
intros.
apply in_part_comp_r with x; auto with algebra.
apply H3; auto with algebra; (apply in_part_comp_r with y; auto with algebra).
Defined.

(** - %\intoc{\bf Theorem 1.4}% *)
Lemma Set_of_subspaces_closed_under_intersection :
 forall WS : part_set Set_of_subspaces,
 is_subspace (intersection (inject_subsets WS)).
red in |- *.
repeat split.
simpl in |- *.
intros; inversion_clear H.
destruct x.
rename subtype_elt into S.
simpl in H0.
destruct S.
simpl in H0, subtype_prf, subtype_prf0.
apply in_part_comp_r with subtype_elt.
red in subtype_prf0.
inversion_clear subtype_prf0.
auto.
auto with algebra.

simpl in |- *.
intros.
generalize dependent (H p H1); generalize dependent (H0 p H1).
inversion_clear H1.
destruct x0.
destruct subtype_elt.
simpl in H2.
intros; simpl in subtype_prf0.
red in subtype_prf0.
inversion_clear subtype_prf0.
inversion_clear H5.
apply in_part_comp_r with subtype_elt; auto with algebra.
apply H6; apply in_part_comp_r with p; auto with algebra.
intros.
simpl in |- *.
intros; simpl in H.
generalize dependent (H p H0).
inversion_clear H0.
destruct x0.
destruct subtype_elt.
simpl in H1, subtype_prf0.
red in subtype_prf0.
inversion_clear subtype_prf0.
inversion_clear H2.
intro; apply in_part_comp_r with subtype_elt; auto with algebra.
apply H4; apply in_part_comp_r with p; auto with algebra.
Qed.
End subspace_awkward_utils.

End MAIN.

Section Examples.
Variable F : field.
Variable V : vectorspace F.

Lemma singleton_zero_is_subspace : is_subspace (single (zero V)).
intros.
repeat split.
simpl in |- *.
apply Refl.
intros.
simpl in H, H0.
apply in_part_comp_l with ((zero V) +' (zero V)); simpl in |- *;
 auto with algebra.
intros.
simpl in H.
apply in_part_comp_l with (c mX (zero V)); simpl in |- *; auto with algebra.
Qed.

Definition triv_subspace : subspace V.
apply alt_Build_subspace with (single (zero V)).
apply singleton_zero_is_subspace.
Defined.

Definition full_subspace : subspace V.
apply alt_Build_subspace with (full V).
repeat split.
Defined.
End Examples.


Require Import robots.icreate.
(** printing × $\times$ #×# *)
(** printing :> $:$ #:># *)
(** printing ≡ $\equiv$ #≡# *)
(** printing [*] $*$ #*# *)
(** printing ∧ $\wedge$ #∧# *)
(** printing ∀ $\forall$ #∀# *)
(** printing → $\rightarrow$ #→# *)
(** printing ∃ $\exists$ #∃# *)
(** printing ≤ $\le$ #≤# *)
(** printing θ $\theta$ #θ# *)
(** printing eeev $\epsilon_v$ #∊ᵥ# *)
(** printing eeew $\epsilon_w$ #∊w# *)
(** printing tm $t_m$ #tm# *)
(** printing IR $\mathbb{R}$ #IR# *)
(** printing CR $\mathbb{R}$ #CR# *)
(** printing tr $t_r$ #tr# *)
(** printing θErrTurn $\theta ErrTurn$ #θErrTurn# *)
(** remove printing * *)
(** printing θErrTrans $\theta ErrTrans$ #θErrTrans# *)
(** printing polarθSign $polar \theta Sign$ #polarθSign# *)
(** printing idealθ $ideal \theta$ #idealθ# *)

(** printing ' $ $ #'# *)

Require Import canonical_names.

Require Import Vector.
Require Import CPS.
Require Import CPSUtils.

Require Import MathClasses.interfaces.canonical_names.
Require Import MCInstances.
Require Import CartCR.

Set Implicit Arguments.

Instance ProjectionFst_instance_sig
   (A : Type) (P: A → Prop):
    ProjectionFst (sig P) A := (@proj1_sig A P) .

Instance ProjectionFst_instance_sigT
   (A : Type) (P: A → Type):
    ProjectionFst (sigT P) A := (@projT1 A P) .

(**

* Overview

In this chapter (file), we explain how to use ROSCoq to program
an iRobot Create.
Our program receives requests to navigate to specific positions and
computes appropriate commands for the robot.
This programs forms will be a software agent in a distributed system
consisting of 3 agents, as shown in the figure:

##

The hardware agent represents the iRobot create hardware and its ROS drivers.
It was defined in the previous chapter.
The request to navigate comes from the external agent.

In the next chapter, we will prove upper bounds on how close the robot
will end up to the requested position.
To do this proof, we use the axiomatization of the hardware agent.

If you have an iRobot Create, you will
be able to run the program on the robot.
The Coq program can be extracted to Haskell and linked with a shim
that actually handles the sending and receiving of messages.

Coq guarantees that the program will behave as proved, unless
our axiomatization of the robot was incorrect.

Before getting into the details of the specification of the entire
distributed system in ROSCoq, let us first
look at the core of the navigation program.
*)

Section RobotProgam.

(** To move to the target position, the robot first turns towards it and then
moves forward. Because a robot may not be able to physical achieve
any arbitrary angular linear speed, we let the user specify the desired
speeds. By adjusting the duration of rotation and linear motion, we can
make the robot go anywhere.
The two variable respectively denote the user specified rotational(angular) and linear speed.*)

Context {rotspeed  : Qpos}.
Context  {linspeed  : Qpos}.

(**
To control the duration of rotation, the program inserts a delay between
the command to start turning and the command to stop turning.
The shim in Haskell can only support a finite resolution for the time requests.
The variable below is used to specify the resolution of the timer.
Formally, 1/[delRes] is the resolution of the timer.
The current Haskell shim is based on the
#threadDelay#
function of Haskell, whose resolution is 1 microseconds.
Hence delRes will be instantiated with 1000000.
However, we choose to make our program and proofs generic over that value.
*)

Context {delRes : Z⁺}.

(** The meaning of the 2 parameters below will be explained while explaining
the program. *)

Context { delEps  : Qpos}.
Context { delay  : Qpos}.
Definition R2QPrec : Qpos := simpleApproximateErr delRes delEps.

Close Scope Q_scope.

(** Here is the program. For a detailed explanation, please
refer to Section 4.2 of the
#ROSCoq paper#
*)

Definition robotPureProgam (target : Cart2D Q) : list (Q × Polar2D Q) :=
  let polarTarget : Polar2D CR := Cart2Polar target in
  let rotDuration : CR :=  ((| θ polarTarget |) * '(/ rotspeed)%Q) in
  let translDuration : CR :=  (rad polarTarget) * '(/ linspeed)%Q in
  [ (0,{|rad:= 0 ; θ := (polarθSign target) * rotspeed |})
      ; (tapprox rotDuration  delRes delEps , {|rad:= 0 ; θ := 0 |})
      ; ('delay , {|rad:=  'linspeed ; θ := 0 |})
      ; (tapprox translDuration delRes delEps , {|rad:= 0 ; θ := 0 |}) ].

(**

* Specifying the whole cyber-physical system system.

The above program sends 4 commands to the iRobot create
device driver. The behaviour of the robot on the receipt
of such commands is specified in the axiomatization of the robot.
To be able to prove that the robot will end up at a place
close to the position requested by the external agent,
we have to specify the whole cyber-physical system
that it is a part of, or at least its relevant parts.
For example, we have to specify the agents of the distributed system,
and the fact that the messages sent by the software agent are received
by the robot device driver.

** Topics

Like the Robot Operating System (ROS), ROSCoq uses a publish-subscribe
approach to communication between agents of a distributed system.
Agents can publish messages to named topics without knowing about who
are receiving them.
Similarly, agents can subsctibe to topics without knowing who is publishing them.
As explained in the previous chapter, the icreate driver
subscribes to a designated topic, and acts on the messages
specifying the linear and angular velocities for the robot.

To specify a Cyber-physical System (CpS) in ROSCoq, one
specifies a type denoting the collection of topics used for communication.
This type must be an instance of the [TopicClass] typeclass.

*)

Inductive Topic :=  VELOCITY | TARGETPOS.

(**
In this application, we use 2 topics. The [VELOCITY] topic is used
the software agent to send the linear and angular velocity commands
to the robot hardware agent.

The [TARGETPOS] topic is used by
the external agent (see Fig. in Sec. 1)
to send the cartesian coordinates of
the target position (relative to the
robot’s current position) to the software
agent.

*)

Scheme Equality for Topic.

(** [TopicClass] the type to have decidable equality*)

Global Instance tdeq : DecEq Topic.
constructor. exact Topic_eq_dec.
Defined.

(** The [TopicClass] also needs the payload type for eqch topic.*)

Definition topic2Type (t : Topic) : Type :=
match t with
| VELOCITY => Polar2D Q
| TARGETPOS => Cart2D Q
end.

Global Instance  rtopic : @TopicClass Topic _.
  constructor. exact topic2Type.
Defined.

(**
The type [Topic] will serve as an implicit parameter of the type [Message].
A message is just a dependent pair of a topic and its payload type.
Here is an example usage.
*)
Definition mkTargetMsg  (q: Cart2D Q) : Message :=
  mkImmMesg TARGETPOS q.

(**
** Collection of Agents.
To be able to holistically reason about a CpS, we have to specify the collection
of agents and the physical model of the cyber-physical system.
One has to then specify the behavior of each agent in a mutually independent way.
All of this is achieved by specifying an instance of [CPS].
We will see how to build one for our example.
First, we need a type to denote the collection of agents.
Each member of the type below denotes an agent (vertical downward arrow) in the message
sequence diagram near the top of this page.
Also, below they appear in the same order as they appear in the figure above.
*)

Inductive RosLoc :=  MOVABLEBASE | SWNODE |  EXTERNALCMD .

(**  Decidable equality is a requirement of the [CPS] typeclass *)
Scheme Equality for RosLoc.

Global Instance ldeq : DecEq RosLoc.
  constructor. exact RosLoc_eq_dec.
Defined.

(**
The typeclass [CPS] also needs a function that
specifies the list of topics subscribed and published by each agent.
A [TopicInfo] is a pair of lists. The first member is the list of subscribed
topics. The second member is the list of published topics.
This list cannot be changed at runtime.
When actually running  a software agent, the Haskell shim
uses the ROS (Robot Operating System) API to subscribe to each topic
in the first member of [TopicInfo].
The software agent will then be invoked on any ROS message received on
the subscribed topics.
 *)
Definition locTopics (rl : RosLoc) : TopicInfo :=
match rl with
| MOVABLEBASE => ((VELOCITY::nil), nil)
| SWNODE => ((TARGETPOS::nil), (VELOCITY::nil))
| EXTERNALCMD => (nil, (TARGETPOS::nil))
end.

(**
** Physical Model
Now that we have defined the the collection of agents, we have to
specify the behvior of each agent in a mutually independent way.
However, the behavior of hardware devices such as sensors and actuators
cannot be specified without modeling the evolution of the relevant physical
quantities (e.g. the ones they measure or influence).
The first argument of [CPS], which is implicit, a a type denoting
the physical model of the cyber-physical system.
As described in Sec. 2 of the
#ROSCoq paper#,
A physical model is a type that specifies how each relevant physical
quantities evolved over time, and the physical laws governing that evolution.
In this example, there is only one robot (iRobot Create), and the physical quantities
are the physical quantities relevant to that robot where specified in the type
[iCreate].
So that type will serve as our physical model.
If there were, say 2 robots, the physical model could be the type [iCreate * iCreate]
*)

Notation PhysicalModel := iCreate.

(**
** Semantics of Agents

Now we specify the behavior of each agent.
Recall from section 4 of the
#ROSCoq paper#
that each agent is specified as a relation between how the physical quantities
evolved over time and how the sequence of events at the agent.
In the above message sequence diagram, events are denoted by either a start
or an end of a slanted arrow. Such slanted arrows denote flight of messages.
*)

(**
Using the [Context] keyword, we assumed the type [Event] which denotes
the collection of all events.
We also assumed that the type [Event] is an instance of the [EventType] typeclass.
This typeclass enables us to use many functions events.
For example, we can use [eLoc] to get the location of an event.
For more details, please see the definition of the type [EventType] (just clicking it
should take it to its definition), or see Sec. 3 of the
#ROSCoq paper#
*)

(**
*** Hardware Agent
*)
Context {reacTime : QTime}.
(** It is more sensible to change the type to [QNonNeg]
    as the value certainly does not represent time.
    However, the coercion QT2Q does not work then *)
Context {motorPrec : Polar2D Q → Polar2D QTime}.

Hypothesis motorPrec0 : motorPrec {| rad :=0 ; θ :=0 |} ≡ {| rad :=0 ; θ :=0 |}.

Definition HwAgent : Device PhysicalModel := HwAgent VELOCITY eq_refl reacTime motorPrec.

(**
*** Software Agent
*)
Definition PureSwProgram: PureProcWDelay TARGETPOS VELOCITY:=
  robotPureProgam.

Definition SwProcess : Process Message (list Message):=
  mkPureProcess (delayedLift2Mesg (PureSwProgram)).

Context {procTime : QTime}.
Context {sendTimeAcc : Qpos}.
Require Export CoRN.model.metric2.Qmetric.

Definition ControllerNode : RosSwNode :=
  Build_RosSwNode (SwProcess) (procTime, sendTimeAcc).

(**
*** External Agent
*)
Context {target : Cart2D Q}.

Definition externalCmdSemantics
 : @NodeSemantics PhysicalModel Topic _ _:=
  λ Event edeq etype _ evs,
              isSendEvtOp (evs 0)
  ∧ (getSentPayloadOp TARGETPOS (evs 0) ≡ Some target)
              ∧ ∀ n : nat, (evs (S n)) ≡ None.

(**
*** The network model.
To specify a CPS, we need to specify its network model
In this example, we assume that the network reliably delivers messages.
*)

Context {expectedDelivDelay : Qpos}.
Context {delivDelayVar : Qpos}.

(* TODO : move the definition of locTopics to here *)
(* making this instance global is of no use because there are arguments in the context
which need to be instantiated *)
Instance lcon : @Connectivity Topic RosLoc.
constructor.
- exact locTopics.
- exact (λ _ _ t , ball delivDelayVar t (QposAsQ expectedDelivDelay)).
Defined.

Definition networkModel : NetworkModel RosLoc :=
fun Event  _ _ _ => @EOReliableDelivery  Topic Event RosLoc _ _ _ _ _ _.

(**
*** Putting it all together. *)

Definition locNode (rl : RosLoc) : NodeSemantics :=
match rl with
| MOVABLEBASE => DeviceSemantics (λ ts,  ts) HwAgent
| SWNODE => SwSemantics ControllerNode
| EXTERNALCMD  => externalCmdSemantics
end.

Global Instance icreateMoveToLoc : @CPS PhysicalModel Topic _ _ RosLoc ldeq _ :=
Build_CPS _ _ _ locNode networkModel.

End RobotProgam.


(* Monad comprehension calculus, by Ryan Wisnesky *********************************** *)

Require Import BinIntDef List Program.Equality.
Open Scope Z_scope.

Axiom functional_extensionality : forall {A B} (f g : A -> B),
  (forall x, f x = g x) -> f = g.

Axiom set_extensionality: forall {t} (P Q : t -> Prop),
  (forall x, P x <-> Q x) -> P = Q.

Axiom decidable_equality: forall {T:Type} (a b : T),
  {a = b} + {a <> b}.

Lemma equal_f : forall {A B : Type} {f g : A -> B},
  f = g -> forall x, f x = g x.
Proof.
  intros. case H. constructor.
Defined.

Fixpoint foldr {A B G} (f:G*(unit+(A*B))->B) (g:G) (l: list A) : B :=
 match l with
  | nil => f (g, inl tt)
  | cons a b => f (g, inr (a, foldr f g b))
end.

Definition foldr0 {A B} (f:(unit+(A*B))->B) (l: list A) : B :=
 foldr (fun x => f (snd x)) tt l.

Fixpoint insertAt {A} t G n {struct n} : list A :=
 match n with
   | O => t :: G
   | S n' => match G with
               | nil => t :: G
               | t' :: G' => t' :: insertAt t G' n'
             end
 end.

Definition listToSet {t} (a : list t) (e:t) : Prop := In e a.

CoInductive Stream A := {shd : A; stl : Stream A}.

Arguments shd [A].
Arguments stl [A].

CoInductive EqSt {A} (s1 s2: Stream A) : Prop := {
  eqhd : shd s1 = shd s2; eqtl : EqSt (stl s1) (stl s2) }.

Arguments eqhd [A].
Arguments eqtl [A].

Axiom stream_extensionality: forall {t1} (s1 s2 : Stream t1), EqSt s1 s2 -> s1 = s2.

Definition Cons {A} (n:A) s := {| shd := n; stl := s |}.

CoFixpoint unfoldr0 {A B} (f:B->(A*B)) (l: B) : Stream A :=
  Cons (fst (f l)) (unfoldr0 f (snd (f l))).

Definition unfoldr {A B G} (f:(G*B)->(A*B)) (g:G) (l: B) : Stream A :=
  @unfoldr0 A (G*B) (fun x => (fst (f x), (fst x, snd (f x)))) (g, l).

Section stream_eq_coind.
  Variable A : Type.
  Variable R : Stream A -> Stream A -> Prop.

  Hypothesis Cons_case_hd : forall {s1 s2}, R s1 s2 -> shd s1 = shd s2.
  Hypothesis Cons_case_tl : forall {s1 s2}, R s1 s2 -> R (stl s1) (stl s2).

  Theorem stream_eq_coind : forall s1 s2, R s1 s2 -> EqSt s1 s2.
    cofix o; destruct s1; destruct s2; intro.
    generalize (Cons_case_hd H); intro Heq; simpl in Heq; rewrite Heq.
    subst. constructor. simpl. auto.
    apply o.
    apply (Cons_case_tl H).
  Qed.

End stream_eq_coind.

(* Structural (co-)recursion: Syntax and Semantics ****************************************** *)

Inductive Ty : Type :=
 | INT  : Ty
 | VOID : Ty
 | UNIT : Ty
 | PROD : Ty -> Ty -> Ty
 | SUM  : Ty -> Ty -> Ty
 | FN   : Ty -> Ty -> Ty
 | LIST   : Ty -> Ty
 | STREAM : Ty -> Ty
 | SET : Ty -> Ty.

Inductive Exp : Ty -> Ty -> Type :=
 | ID    : forall {t}, Exp t t
 | CONST : Z -> Exp UNIT INT
 | ADD : Exp (PROD INT INT) INT
 | MUL : Exp (PROD INT INT) INT
 | NEG : Exp INT INT
 | COMP  : forall {t1 t2 t3}, Exp t1 t2 -> Exp t2 t3 -> Exp t1 t3
 | INL   : forall {t1 t2}, Exp t1 (SUM t1 t2)
 | INR   : forall {t1 t2}, Exp t2 (SUM t1 t2)
 | PAIR  : forall {t1 t2 t3}, Exp t1 t2 -> Exp t1 t3 -> Exp t1 (PROD t2 t3)
 | FST   : forall {t1 t2}, Exp (PROD t1 t2) t1
 | SND   : forall {t1 t2}, Exp (PROD t1 t2) t2
 | TT    : forall {t}, Exp t UNIT
 | FF    : forall {t}, Exp VOID t
 | CASE  : forall {t1 t2 t3}, Exp t2 t1 -> Exp t3 t1 -> Exp (SUM t2 t3) t1
 | CURRY : forall {t1 t2 t3}, Exp (PROD t1 t2) t3 -> Exp t1 (FN t2 t3)
 | EVAL  : forall {t1 t2}, Exp (PROD (FN t1 t2) t1) t2
 | DIST  : forall {t1 t2 t3}, Exp (PROD t1 (SUM t2 t3)) (SUM (PROD t1 t2) (PROD t1 t3))
 | IN    : forall {t}, Exp ( (SUM UNIT (PROD t (LIST t)))) (LIST t)
 | OUT   : forall {t}, Exp ( (STREAM t)) (PROD t (STREAM t))
 | FOLD  : forall {t t' t''}, Exp (PROD t'' (SUM UNIT (PROD t t'))) t' -> Exp (PROD t'' (LIST t)) t'
 | UNFOLD: forall {t t'}, Exp t' (PROD t t') -> Exp t' (STREAM t)
 | MAP   : forall {t t'}, Exp t t' -> Exp (SET t) (SET t')
 | EMPTY : forall {t}, Exp UNIT (SET t)
 | SNG   : forall {t}, Exp t (SET t)
 | UNION : forall {t}, Exp (PROD (SET t) (SET t)) (SET t)
 | FLATTEN:forall {t}, Exp (SET (SET t)) (SET t)
 | TENSOR: forall {t t'}, Exp (PROD t (SET t')) (SET (PROD t t'))
 | EQ    : forall {t}, Exp (PROD t t) (SUM UNIT UNIT).

Fixpoint TyD t : Type := match t with
 | INT  => Z
 | VOID => Empty_set
 | UNIT => unit
 | PROD t1 t2 => TyD t1 * TyD t2
 | SUM  t1 t2 => TyD t1 + TyD t2
 | FN   t1 t2 => TyD t1 -> TyD t2
 | LIST   t => list (TyD t)
 | SET    t => TyD t -> Prop
 | STREAM t => Stream (TyD t)
end.

Fixpoint ExpD {t1 t2} (e: Exp t1 t2) : TyD t1 -> TyD t2 :=
 match e in Exp t1x t2x return TyD t1x -> TyD t2x with
 | ID  => fun x => x
 | CONST n => fun _ => n
 | ADD => fun x => Z.add (fst x) (snd x)
 | MUL => fun x => Z.mul (fst x) (snd x)
 | NEG => fun x => Z.opp x
 | COMP f g => fun x => ExpD g (ExpD f x)
 | INL => fun x => inl x
 | INR => fun x => inr x
 | PAIR f g => fun x => (ExpD f x, ExpD g x)
 | FST => fun x => fst x
 | SND => fun x => snd x
 | TT  => fun _ => tt
 | FF  => fun x => match x with end
 | CASE  f g => fun x => match x with inl a => ExpD f a | inr b => ExpD g b end
 | CURRY f => fun x y => ExpD f (x, y)
 | EVAL => fun x => fst x (snd x)
 | IN  => fun x => match x with inl _ => nil | inr y => cons (fst y) (snd y) end
 | OUT => fun x => (shd x, stl x)
 | FOLD f   => fun x => foldr   (ExpD f) (fst x) (snd x)
 | UNFOLD f => fun x => unfoldr0 (ExpD f) x
 | DIST  => fun x => match snd x with | inl a => inl (fst x, a) | inr b => inr (fst x,b ) end
 | MAP f => fun x z => exists y, x y /\ ExpD f y = z
 | EMPTY => fun _ z => False
 | SNG   => fun x z => z = x
 | UNION => fun x z => fst x z \/ snd x z
 | FLATTEN => fun x z => exists y, x y /\ y z
 | TENSOR => fun x z => fst z = fst x /\ snd x (snd z)
 | EQ => fun x => match decidable_equality (fst x) (snd x) with left _ => inl tt | right _ => inr tt end
 end.

(* Small helper definitions ****************************************************************** *)

Definition OPAIR {t1 t2 t3 t4} (e1 : Exp t1 t2) (e2 : Exp t3 t4)
 : Exp (PROD t1 t3) (PROD t2 t4) := PAIR (COMP FST e1) (COMP SND e2).

Definition OCASE {t1 t2 t3 t4} (e1 : Exp t1 t2) (e2 : Exp t3 t4)
 : Exp (SUM t1 t3) (SUM t2 t4) := CASE (COMP e1 INL) (COMP e2 INR).

Definition UNDIST {t1 t2 t3} : Exp (SUM (PROD t1 t2) (PROD t1 t3)) (PROD t1 (SUM t2 t3))
 :=  CASE (OPAIR ID INL) (OPAIR ID INR).

Definition NIL {G t} := COMP (COMP (@TT G) INL) (@IN t).

Definition CONS {G t} f (l: Exp G (LIST t)) := COMP (COMP (PAIR f l) INR) (@IN t).

Definition FOLD0  {t t'} (f: Exp (SUM UNIT (PROD t t')) t') : Exp (LIST t) t'
 := COMP (PAIR TT ID) (FOLD (COMP SND f)).

Definition PFOLD {t t' t''} (f: Exp (PROD t'' (SUM UNIT (PROD (PROD (LIST t) t) t'))) t') : Exp (PROD t'' (LIST t)) t'
 := COMP (FOLD  (PAIR (COMP SND (CASE NIL (COMP SND FST))) (COMP (OPAIR ID (OCASE TT (PAIR (PAIR (COMP SND FST) FST) (COMP SND SND)))) f))) SND.

Definition UNFOLD1 {t t' t''} (g: Exp (PROD t'' t') (PROD t t')) : Exp (PROD t'' t') (STREAM t)
 := (@UNFOLD t (PROD t'' t') (PAIR (COMP g FST) (PAIR FST (COMP g SND))) )%type.

Definition PUNFOLD0 {t t'} (f: Exp t' (PROD t (SUM t' (STREAM t)))) : Exp t' (STREAM t)
 := COMP INL (UNFOLD (CASE f (COMP OUT (OPAIR ID INR)))).

Definition PUNFOLD {t t' G} (f: Exp (PROD G t') (PROD t (SUM t' (STREAM t)))) : Exp (PROD G t') (STREAM t)
 := COMP INL (COMP UNDIST (UNFOLD1 (COMP DIST (CASE f (COMP SND (COMP OUT (OPAIR ID INR))))))).

Definition TRUE {t} : Exp t (SUM UNIT UNIT) := COMP TT INL.

Definition SWAP {A B} : Exp (PROD A B) (PROD B A) := PAIR SND FST.

Definition DISTHelpher {A B G} : Exp (PROD G (SUM UNIT (PROD A B))) (SUM UNIT (PROD A (PROD G B)))
 := COMP DIST (OCASE TT (PAIR (COMP SND FST) (PAIR FST (COMP SND SND)))).

Definition DISTHelpher' {A B G} : Exp (PROD G ((PROD A B))) ((PROD A (PROD G B))) :=
 PAIR (COMP SND FST) (PAIR FST (COMP SND SND)).

Definition WongHelper {A B C : Ty} :=
 @PAIR _ A _ (COMP (@FST _ B) (@FST _ C)) (PAIR (COMP FST SND) SND).

(* Equational theory ************************************************************************)

Inductive ExpEq : forall {t1 t2}, Exp t1 t2 -> Exp t1 t2 -> Prop :=
 | REFL : forall {t1 t2} (e: Exp t1 t2), ExpEq e e
 | SYM :  forall {t1 t2} (e1 e2: Exp t1 t2),
     ExpEq e1 e2 -> ExpEq e2 e1
 | TRANS : forall {t1 t2} (e1 e2 e3: Exp t1 t2),
     ExpEq e1 e2 -> ExpEq e2 e3 -> ExpEq e1 e3
 | UNITETA : forall {t} (e: Exp t UNIT), ExpEq e TT
 | VOIDETA : forall {t} (e: Exp VOID t), ExpEq e FF
 | FSTBETA : forall {t1 t2 t3} (e1: Exp t1 t2) (e2: Exp t1 t3),
     ExpEq (COMP (PAIR e1 e2) FST) e1
 | SNDBETA : forall {t1 t2 t3} (e1: Exp t1 t2) (e2: Exp t1 t3),
     ExpEq (COMP (PAIR e1 e2) SND) e2
 | PAIRETA : forall {t1 t2 t3} (e: Exp t1 (PROD t2 t3)),
     ExpEq (PAIR (COMP e FST) (COMP e SND)) e
 | INLBETA : forall {t1 t2 t3} (e1: Exp t1 t2) (e2: Exp t3 t2),
     ExpEq (COMP INL (CASE e1 e2)) e1
 | INRBETA : forall {t1 t2 t3} (e1: Exp t1 t2) (e2: Exp t3 t2),
     ExpEq (COMP INR (CASE e1 e2)) e2
 | CASEETA : forall {t1 t2 t3} (e: Exp (SUM t2 t3) t1),
     ExpEq (CASE (COMP INL e) (COMP INR e)) e
 | IDL : forall {t1 t2} (e: Exp t1 t2), ExpEq (COMP ID e) e
 | IDR : forall {t1 t2} (e: Exp t1 t2), ExpEq (COMP e ID) e
 | COMPASSOC : forall {t1 t2 t3 t4} (e1: Exp t1 t2) (e2: Exp t2 t3) (e3 : Exp t3 t4),
     ExpEq (COMP (COMP e1 e2) e3) (COMP e1 (COMP e2 e3))
 | FNBETA : forall {t1 t2 t3} (e: Exp (PROD t1 t2) t3),
     ExpEq (COMP (OPAIR (CURRY e) ID) EVAL) e
 | FNETA : forall {t1 t2 t3} (e: Exp t1 (FN t2 t3)),
     ExpEq (CURRY (COMP (OPAIR e ID) EVAL)) e

 | COMPCONG : forall {t1 t2 t3} (e1 e3: Exp t1 t2) (e2 e4: Exp t2 t3),
     ExpEq e1 e3 -> ExpEq e2 e4 -> ExpEq (COMP e1 e2) (COMP e3 e4)
 | CASECONG : forall {t1 t2 t3} (e1 e3: Exp t1 t3) (e2 e4: Exp t2 t3),
     ExpEq e1 e3 -> ExpEq e2 e4 -> ExpEq (CASE e1 e2) (CASE e3 e4)
 | PAIRCONG : forall {t1 t2 t3} (e1 e3: Exp t1 t2) (e2 e4: Exp t1 t3),
     ExpEq e1 e3 -> ExpEq e2 e4 -> ExpEq (PAIR e1 e2) (PAIR e3 e4)
 | CURRYCONG : forall {t1 t2 t3} (e1 e2: Exp (PROD t1 t2) t3),
     ExpEq e1 e2 -> ExpEq (CURRY e1) (CURRY e2)
 | FOLDCONG : forall {t1 t2 G} (e1 e2: Exp (PROD G (SUM UNIT (PROD t1 t2))) t2),
     ExpEq e1 e2 -> ExpEq (FOLD e1) (FOLD e2)

 | DIST1 : forall {t1 t2 t3}, ExpEq (COMP (@DIST t1 t2 t3) (CASE (COMP SND INL) (COMP SND INR))) SND
 | DIST2 : forall {t1 t2 t3}, ExpEq (COMP (@DIST t1 t2 t3) (CASE FST FST)) FST
 | DIST3 : forall {t1 t2 t3}, ExpEq (COMP (OPAIR ID INL) (@DIST t1 t2 t3)) INL
 | DIST4 : forall {t1 t2 t3}, ExpEq (COMP (OPAIR ID INR) (@DIST t1 t2 t3)) INR
 | DIST5 : forall {t1 t2 t3 t4 t5 t6} (f:Exp t1 t2) (g:Exp t3 t4) (h: Exp t5 t6),
    ExpEq (COMP (OPAIR f (CASE (COMP g INR) (COMP h INL))) DIST)
          (COMP DIST (CASE (COMP (OPAIR f g) INR) (COMP (OPAIR f h) INL)))

 | FOLDBETA : forall {t1 t2 G} (e: Exp (PROD G (SUM UNIT (PROD t1 t2))) t2),
     ExpEq (COMP (OPAIR ID IN) (FOLD e)) (COMP (PAIR FST (COMP DISTHelpher (OCASE TT (OPAIR ID (FOLD e))))) e)

 | FOLDETA : forall {t1 t2 G} (e: Exp (PROD G (SUM UNIT (PROD t1 t2))) t2) (h: Exp (PROD G (LIST t1)) t2),
     ExpEq (COMP (OPAIR ID IN) h) (COMP (PAIR FST (COMP DISTHelpher (OCASE TT (OPAIR ID h)))) e)
     -> ExpEq h (FOLD e)

 | UNFOLDCONG : forall {t1 t2} (e1 e2: Exp t2 (PROD t1 t2)),
     ExpEq e1 e2 -> ExpEq (UNFOLD e1) (UNFOLD e2)

 | UNFOLDBETA : forall {t1 t2} (e: Exp t2 (PROD t1 t2)),
     ExpEq (COMP (UNFOLD e) OUT) (COMP e ( (OPAIR ID (UNFOLD e))))

 | UNFOLDETA : forall {t1 t2} (e: Exp t2 (PROD t1 t2)) (h: Exp t2 (STREAM t1)),
     ExpEq (COMP h OUT) (COMP e ( (OPAIR ID h)))
     -> ExpEq h (UNFOLD e)

 | MAPID : forall {t}, ExpEq (@ID (SET t)) (MAP ID)
 | MAPCOMP : forall {t1 t2 t3} (f:Exp t1 t2) (g:Exp t2 t3),
     ExpEq (MAP (COMP f g)) (COMP (MAP f) (MAP g))

 | SNGBETA : forall {t1 t2} (f: Exp t1 t2),
     ExpEq (COMP SNG (MAP f)) (COMP f SNG)

 | MAPMAP : forall {t1 t2} (f: Exp t1 (SET t2)),
     ExpEq (COMP FLATTEN (MAP f))  (COMP (MAP (MAP f)) FLATTEN)

 | SNGETA : forall {t}, ExpEq (COMP SNG FLATTEN) (@ID (SET t))

 | FLATTENMAPSNG : forall {t}, ExpEq (COMP (MAP SNG) FLATTEN) (@ID (SET t))

 | FLATTENFLATTEN : forall {t}, ExpEq (COMP FLATTEN FLATTEN) (COMP (MAP FLATTEN) (@FLATTEN t))

 | MAPSNDTENSOR : forall {t1 t2}, ExpEq (COMP TENSOR (MAP SND)) (@SND t1 (SET t2))
 | TENSORIDSNG  : forall {t1 t2}, ExpEq (COMP (OPAIR ID SNG) TENSOR) (@SNG (PROD t1 t2))
 | TENSORIDFLATTEN : forall {t1 t2}, ExpEq (COMP (OPAIR (@ID t1) (@FLATTEN t2)) TENSOR)
    (COMP TENSOR (COMP (MAP TENSOR) FLATTEN))

 | MAPTENSOR : forall {t1 t2 t3 t4} (f:Exp t1 t2) (g:Exp t3 t4),
    ExpEq (COMP TENSOR (MAP (OPAIR f g))) (COMP (OPAIR f (MAP g)) TENSOR)

 | MAPWONG : forall {t1 t2 t3 : Ty}, ExpEq (COMP TENSOR  (MAP (@WongHelper t1 t2 t3 )))
    (COMP WongHelper  (COMP (OPAIR ID TENSOR) TENSOR))

 | UNIONASSOC : forall {t t'} (e f g : Exp t (SET t')),
    ExpEq (COMP (PAIR (COMP (PAIR e f) UNION) g) UNION)
    (COMP (PAIR e (COMP (PAIR f g) UNION)) UNION)

 | UNIONCOMM : forall {t t'} (e f : Exp t (SET t')),
    ExpEq (COMP (PAIR e f) UNION) (COMP (PAIR f e) UNION)

 | UNIONIDEM : forall {t t'} (f : Exp t (SET t')),
    ExpEq (COMP (PAIR f f) UNION) f

 | UNIONEMPTY : forall {t t'} (e f g : Exp t (SET t')),
    ExpEq (COMP (PAIR f (COMP TT EMPTY)) UNION) f

 | MAPCONG : forall {t t'} (e f: Exp t t'), ExpEq e f -> ExpEq (MAP e) (MAP f)

 | EQTRUE1 : forall {t t'} (e f: Exp t t'), ExpEq e f  -> ExpEq (COMP (PAIR e f) EQ) TRUE
 | EQTRUE2 : forall {t t'} (e f: Exp t t'), ExpEq (COMP (PAIR e f) EQ) TRUE -> ExpEq e f

 | EMPTYTENSOR : forall {G t t'} (f : Exp G t),
     ExpEq (COMP (PAIR f (COMP (@TT G) EMPTY)) (@TENSOR t t'))
           (COMP (@TT G) EMPTY )
 | EMPTYMAP : forall {t t'} (f : Exp t t'),
     ExpEq (COMP (COMP TT EMPTY) (MAP f)) (COMP (@TT t) (@EMPTY t'))

 | EMPTYFLATTEN : forall {t},
     ExpEq (COMP (COMP TT EMPTY) FLATTEN) (COMP (@TT t) (@EMPTY t)).

Theorem axiomsSound : forall t1 t2 (e1 e2: Exp t1 t2), ExpEq e1 e2 -> ExpD e1 = ExpD e2.
Proof.
intros; induction H; simpl in *; try apply functional_extensionality; try congruence; try auto; intros; fold TyD in *.
destruct (ExpD e x); auto.
contradiction.
destruct (ExpD e x); auto.
destruct x; auto.
destruct x; auto.
destruct x; congruence.
apply functional_extensionality; intros; congruence.
destruct x; destruct s; auto.
destruct x; destruct s; auto.
destruct x; auto.
destruct x; auto.
destruct x; destruct s; auto.
destruct x; destruct s; auto.

destruct x; simpl in *; induction l; simpl in *; [ apply ((equal_f IHExpEq) (t, inl tt)) |
 rewrite <- IHl in *; apply ((equal_f IHExpEq) ((t, inr (a, l)))) ].

apply stream_extensionality.  refine ((cofix F o := {|eqhd:= _; eqtl:= _|} ) x).
pose ((equal_f IHExpEq) (o)); simpl in *.
injection e0; auto.
pose ((equal_f IHExpEq) (o)); simpl in *;
injection e0; fold TyD in *; intros pf1 pf2; rewrite pf1; apply F.

 apply set_extensionality; intros z; intuition; eauto; repeat destruct H; subst; auto.
 apply set_extensionality; intros z; intuition; eauto; repeat destruct H; subst; auto; eauto.
 apply set_extensionality; intros z; intuition; eauto; repeat destruct H; subst; auto.

apply set_extensionality; intros z; intuition. repeat destruct H; subst. simpl in *.
eexists. eexists. eexists. split. eauto. reflexivity. simpl in *. eexists.
split. eauto. eauto.  repeat destruct H; subst. repeat destruct H0. subst; simpl in *.
eexists. eexists. eexists. split. eauto. eauto. auto.

apply set_extensionality; intros z; intuition; repeat destruct H; auto; eexists; eauto.
apply set_extensionality; intros z; intuition; repeat destruct H; subst; auto; subst; auto.
eexists. split. eexists. split. eauto. reflexivity. simpl. reflexivity.

apply set_extensionality. intros z. intuition. repeat destruct H.
exists ((fun z0 : TyD t => exists y1 : TyD t -> Prop, x1 y1 /\ y1 z0)).
split. exists x1. split; auto. exists x0. split; auto.
repeat destruct H. subst. repeat destruct H0. exists x0.
split. exists x1. split; auto. auto.

destruct x; simpl in *. apply set_extensionality. intros z. intuition.
repeat destruct H. subst; auto. exists (t,z). simpl. auto.

destruct x; simpl in *. apply set_extensionality. intros z. destruct z.
simpl.  intuition.  subst.  auto.  congruence. congruence.

destruct x; simpl in *. apply set_extensionality. intros z. destruct z.
simpl.  intuition.  subst. repeat destruct H1. destruct H.
exists ((fun z : TyD t1 * TyD t2 => fst z = t /\ x (snd z)) ).
simpl. split; auto. exists (t, x). simpl; split; auto.
repeat destruct H. subst. destruct H0. destruct x0; simpl in *. auto.
repeat destruct H. subst. destruct H0. destruct x0; simpl in *.
subst. exists P0. auto.

destruct x; simpl in *. apply set_extensionality. intros z. destruct z.
simpl.  intuition. repeat destruct H. congruence.
repeat destruct H. destruct x; simpl in *.
exists t6. split. auto. congruence. destruct H1. destruct H. subst.
exists (t,x). simpl; split; auto.

destruct x; simpl in *. apply set_extensionality. intros z. destruct z.
simpl. destruct p0; simpl. intuition. repeat destruct H.
destruct x. destruct p. simpl in *. congruence. repeat destruct H.
destruct x. destruct p. simpl in *. congruence. repeat destruct H.
destruct x. destruct p. simpl in *. congruence. subst.
exists (a,b,t4). simpl. intuition.

apply set_extensionality. intros z. intuition.
apply set_extensionality. intros z. intuition.
apply set_extensionality. intros z. intuition.
apply set_extensionality. intros z. intuition.
apply set_extensionality. intros z. intuition.
repeat destruct H0. subst. exists x0. split; auto. rewrite IHExpEq. auto.
repeat destruct H0. subst. exists x0. split; auto. rewrite IHExpEq. auto.

destruct (decidable_equality (ExpD e x) (ExpD f x)). auto. rewrite IHExpEq in n. contradiction.
pose (equal_f IHExpEq x). simpl in e0. clearbody e0. clear IHExpEq.
destruct (decidable_equality (ExpD e x) (ExpD f x)). auto. discriminate.

apply set_extensionality; intuition.
apply set_extensionality; intuition; repeat destruct H; intuition.
apply set_extensionality; intuition; repeat destruct H; intuition.
Qed.

(* Implementation of sets as lists  ************************************************************** *)
(* todo: upgrade to logical relation *)

Definition TENSOR_list {G t} : Exp (PROD G (LIST t)) (LIST (PROD G t))
 := FOLD (COMP DIST (CASE NIL (CONS (PAIR FST (COMP SND FST)) (COMP SND SND)))).

Definition EMPTY_list {t} : Exp UNIT (LIST t) := COMP (COMP TT INL) IN.

Definition SNG_list {t} : Exp t (LIST t) := COMP (COMP (PAIR ID (COMP TT EMPTY_list)) INR) IN.

Definition UNION_list {t} : Exp (PROD (LIST t) (LIST t)) (LIST t)
 := FOLD (COMP DIST (CASE FST (COMP SND (COMP INR IN)))).

Definition UNION_list2 {t} : Exp (PROD (LIST t) (LIST t)) (LIST t) := COMP SWAP UNION_list.

Definition TENSOR_list2 {G t} : Exp (PROD G (LIST t)) (LIST (PROD G t))
 := (FOLD (COMP DIST (CASE (COMP TT EMPTY_list) (COMP  (COMP ((PAIR (PAIR FST (COMP SND FST)) (COMP SND SND))) INR) IN)))).

Definition MAP_list  {t t'} (f: Exp t t') : Exp (LIST t) (LIST t')
 := FOLD0 (CASE EMPTY_list  (COMP (COMP (PAIR (COMP FST f) SND) INR) IN)).

Definition FLATTEN_list {t} : Exp (LIST (LIST t)) (LIST t) := FOLD0 (CASE EMPTY_list UNION_list2).

Lemma EMPTY_list_ok {t} : listToSet (ExpD (@EMPTY_list t) tt) = ExpD EMPTY tt.
Proof.
  reflexivity.
Qed.

Lemma SNG_list_ok {t} : forall l, listToSet (ExpD (@SNG_list t) l) = ExpD SNG l.
Proof.
 intros. apply set_extensionality. intros e. fold TyD in *.
 intuition. simpl in *. destruct H. auto. contradiction.
 simpl in *. left; auto.
Qed.

Lemma UNION_list_ok {t} : forall x y, listToSet (ExpD (@UNION_list t) (x,y)) = ExpD UNION (listToSet x, listToSet y).
Proof.
 intros. fold TyD in *. apply set_extensionality. intros e.
 intuition. simpl in *. induction y. simpl in *. auto.
 simpl in *. destruct H. subst. right. left. auto.
 simpl in *. pose (IHy H). destruct o. left. auto. right. right. auto.
 simpl in *. destruct H.  induction y. simpl in *. auto.
 simpl in *. right. assumption. induction y. simpl in *. elim H.
 simpl in *. destruct H. subst. left. auto.
 simpl in *. pose (IHy H). right. assumption.
Qed.

Lemma helper3 {t} x y : ExpD (COMP SWAP (@UNION_list t)) (x, y) = ExpD UNION_list (y, x).
Proof.
 fold TyD. intros. simpl. auto.
Qed.

Lemma UNION_list2_ok {t} x y : listToSet (ExpD (@UNION_list2 t) (x,y)) = ExpD UNION (listToSet x, listToSet y).
Proof.
 intros. fold TyD in *. unfold UNION_list2. rewrite helper3.
 rewrite UNION_list_ok.
 simpl. fold TyD. apply set_extensionality. intros e.
 intuition.
Qed.

Lemma TENSOR_list2_ok {t t'} x l : listToSet (ExpD (@TENSOR_list2 t t') (x, l)) = ExpD TENSOR (x, listToSet l).
Proof.
 intros. fold TyD in *. apply set_extensionality. intros e. destruct e; simpl.
 intuition. simpl in *. induction l. simpl in *. elim H.
 simpl in *. destruct H. assert (x = t0 /\ a = t1). split;  congruence. destruct H0. subst. auto.
 simpl in *. pose (IHl H). auto.
 simpl in *. induction l. simpl in *. auto.
 simpl in *. destruct H. assert (x = t0 /\ a = t1). split;  congruence. destruct H0.  auto.
 simpl in *. pose (IHl H). auto. subst.
 simpl in *. induction l. simpl in *. auto.
 simpl in *. destruct H1. subst. left; auto.
 pose (IHl H). auto.
Qed.

Lemma helper0 {t} : ExpD (@FLATTEN_list t) = @concat (TyD t).
Proof.
 apply functional_extensionality.
 intros x. induction x.
 simpl. auto. rewrite concat_cons.
 rewrite <- IHx. clear IHx.
 induction a. rewrite app_nil_l. simpl. auto.
 unfold FLATTEN_list in *. remember (FOLD0 (CASE EMPTY_list UNION_list2)).
 rewrite <- app_comm_cons. rewrite <- IHa. clear IHa.
 subst. simpl in *. auto.
Qed.

Lemma helper1 {t} a l : (@ExpD (LIST (LIST t)) (LIST t) (@FLATTEN_list t)
   (@cons (TyD (LIST t)) a l) = a ++ ExpD FLATTEN_list l).
Proof.
 rewrite helper0. simpl. auto.
Qed.

Lemma FLATTEN_list_ok {t} : forall l, listToSet (ExpD (@FLATTEN_list t ) l)
  = ExpD FLATTEN (listToSet (map listToSet l)).
Proof.
  intros. unfold listToSet. fold TyD.
  unfold ExpD. fold @ExpD. fold @TyD. apply set_extensionality. intros; intuition.

 Focus 2. repeat destruct H. pose (@in_map_iff _ _ (fun (a : list (TyD t)) (e : TyD t) => In e a) l x0).
 destruct i. pose (H1 H). destruct e. clear H H1. destruct H3. subst.
 clear H2. induction l. simpl in *. auto.
 destruct H1.  subst.
 rewrite helper1.  apply in_or_app.
 left; auto. rewrite helper1. apply in_or_app.
 right. apply IHl. auto.

 induction l. simpl in *.  contradiction.
 rewrite helper1 in H. apply in_app_or in H. destruct H.
 exists (listToSet a). split; auto. apply in_map. constructor. auto.
 destruct ( IHl H ). clear IHl. exists x0. destruct H0.
 split; auto. right. auto.
Qed.

Lemma MAP_list_ok {t t' e} : forall l, listToSet (ExpD (@MAP_list t t' e) l)
  = ExpD (MAP e) (listToSet l).
Proof.
 intros. apply set_extensionality; fold TyD. intros x.
 induction l; simpl in *; fold @TyD in *. intuition.
 destruct H. destruct H. contradiction. destruct IHl. subst. unfold listToSet in *.
 intuition. subst. exists a. split. left; auto. auto.
 destruct H1. destruct H0. subst. exists x0. split. right. auto. auto.
 destruct H1. destruct H1. subst. destruct H1. subst. left; auto.
 right. apply H0. exists x0. split; auto.
Qed.

(* tests *)
Eval compute in ExpD (@UNION_list INT) (cons 1 (cons 2 nil), cons 3 (cons 4 nil)).
Eval compute in ExpD (@TENSOR_list2 INT INT) (1, cons 3 (cons 4 nil)).
Eval compute in ExpD (@MAP_list INT INT NEG) (cons 3 (cons 4 nil)).
Eval compute in ExpD (@FLATTEN_list INT) (cons (cons 3 (cons 4 nil)) (cons (cons 1 (cons 2 nil)) nil)).
Eval compute in (ExpD (@TENSOR_list INT INT) (5, cons 1 (cons 2 nil)) ).
Eval compute in FOLD0 (CASE (CONST 0) ADD).
Eval compute in ExpD (@UNION_list2 INT) (cons 1 (cons 2 nil), cons 3 (cons 4 nil)).
Eval compute in ExpD (@TENSOR_list2 INT INT) (1, cons 3 (cons 4 nil)).
Eval compute in ExpD (@MAP_list INT INT NEG) (cons 3 (cons 4 nil)).
Eval compute in ExpD (@FLATTEN_list INT) (cons (cons 3 (cons 4 nil)) (cons (cons 1 (cons 2 nil)) nil)).

(* Lambda calculus form, using dependent de Bruijn indexes ************************************** *)

(* Preliminary: heterogenous lists *)
Section hlist.
 Variable A : Type.
 Variable B : A -> Type.

 Fixpoint hlist (l: list A) : Type := match l with
  | nil => unit
  | a :: b => hlist b * B a
 end.

 Variable elm : A.

 Fixpoint member (ls: list A) : Type :=
  match ls with
    | nil => Empty_set
    | x :: ls' => (x = elm) + member ls'
  end%type.

Definition HFirst ls : member (elm :: ls) := inl eq_refl.

Definition HNext x ls (pf:member ls) : member (x :: ls) := inr pf.

Fixpoint hget {ls : list A} : hlist ls -> member ls -> B elm :=
  match ls with
    | nil => fun {x} idx => match idx with end
    | _ :: ls' => fun {mls} idx => match idx with
                                  | inl pf => match pf with eq_refl => snd mls end
                                  | inr idx' => hget (fst mls) idx'
                                 end
  end.

Definition hhd {ls : list A} :=
   match ls as ls' return hlist ls' -> match ls' return Type with nil => unit | x :: _ => B x end with
     | nil => fun _ => tt
     | _ :: _ => fun x => snd x
   end.

 Definition htl {ls}  :=
   match ls as ls' return hlist ls' -> match ls' return Type with nil => unit | _ :: ls' => hlist ls' end with
     | nil => fun _ => tt
     | _ :: _ => fun x => fst x
   end.

Definition HNil : hlist nil := tt.

Definition HCons {x ls} (x' : B x) (ls' : hlist ls) : hlist (x :: ls) := (ls', x').

End hlist.

Arguments hlist [A B].
Arguments member [A].
Arguments HNil [A B].
Arguments HCons [A B x ls].
Arguments hhd [A B ls].
Arguments htl [A B ls].
Arguments hget [A B].
Arguments HFirst [A elm ls].
Arguments HNext [A elm x ls].

Inductive exp : list Ty -> Ty -> Type :=
| WEAKEN' : forall {G t} t', exp G t -> exp (t'::G) t
| EXCH' : forall {G t t' t''}, exp (t::t'::G) t'' -> exp (t'::t::G) t''
| SUBST' : forall {G t t'}, exp (t'::G) t -> exp G t' -> exp G t

| VAR'   : forall {G t} (pfN: @member Ty t G), exp G t

| CONST' : forall {G}, Z -> exp G INT
| ADD'   : forall {G}, exp G INT -> exp G INT -> exp G INT
| MUL'   : forall {G}, exp G INT -> exp G INT -> exp G INT
| NEG'   : forall {G}, exp G INT -> exp G INT

| INL'   : forall {G t1 t2}, exp G t1 -> exp G (SUM t1 t2)
| INR'   : forall {G t1 t2}, exp G t2 -> exp G (SUM t1 t2)
| FST'   : forall {G t1 t2}, exp G (PROD t1 t2) -> exp G t1
| SND'   : forall {G t1 t2}, exp G (PROD t1 t2) -> exp G t2

| TT'    : forall {G}, exp G UNIT
| FF'    : forall {G t}, exp G VOID -> exp G t

| PAIR'  : forall {G t1 t2}, exp G t1 -> exp G t2 -> exp G (PROD t1 t2)

| CASE'  : forall {G t1 t2 t3}, exp (t1 :: G) t3 -> exp (t2 :: G) t3 -> exp G (SUM t1 t2) -> exp G t3

| CURRY' : forall {G dom ran}, exp (dom :: G) ran -> exp G (FN dom ran)
| EVAL'  : forall {G dom ran}, exp G (FN dom ran) -> exp G dom -> exp G ran

| IN'     : forall {G t}, exp G (SUM UNIT (PROD t (LIST t))) -> exp G (LIST t)
| OUT'    : forall {G t}, exp G (STREAM t) -> exp G (PROD t (STREAM t))

| FOLD'  : forall {G t t'}, exp (SUM UNIT (PROD t t')::G) t' -> exp G (LIST t) -> exp G t'
| UNFOLD': forall {G t t'}, exp (t'::G) (PROD t t') -> exp G t' -> exp G (STREAM t)

| EQ' : forall {G t}, exp G t -> exp G t -> exp G (SUM UNIT UNIT)

| EMPTY' : forall {G t}, exp G (SET t)
| SNG' : forall {G t}, exp G t -> exp G (SET t)
| UNION' : forall {G t}, exp G (SET t) -> exp G (SET t) -> exp G (SET t)

| BIND' : forall {G t t'}, exp G (SET t) -> exp (t :: G) (SET t') -> exp G (SET t').

Fixpoint pfG G := match G with
| nil => UNIT
| a :: b => PROD (pfG b) a
end.

Fixpoint telescope {G t} : @member Ty t G -> Exp (pfG G) t :=
  match G  with
  | nil => fun pf => match pf with end
  | a :: b => fun pf => match pf with
      | inl pf' => match pf' with refl_equal => SND end
      | inr pf' => COMP FST (telescope pf')
    end
  end.

Definition pf : forall {G t}  (e0: exp G t), Exp (pfG G) t.
refine (fix pf {G t} (e0: exp G t) : Exp (pfG G) t :=
 match e0 in exp G' t' return Exp (pfG G') t' with
  | WEAKEN' _ e => COMP FST (pf e)
  | EXCH'   e => COMP (PAIR (PAIR (COMP FST FST) SND) (COMP FST SND)) (pf e)
  | SUBST'  e f => COMP (PAIR ID (pf f)) (pf e)
  | TT'    => TT
  | EMPTY' => COMP TT EMPTY
  | VAR' v => telescope v
  | NEG'    e => COMP (pf e) NEG
  | INL'    e => COMP (pf e) INL
  | INR'    e => COMP (pf e) INR
  | IN'     e => COMP (pf e) IN
  | OUT'    e => COMP (pf e) OUT
  | FST'    e => COMP (pf e) FST
  | SND'    e => COMP (pf e) SND
  | SNG'    e => COMP (pf e) SNG
  | CURRY'  e => CURRY (pf e)
  | CONST'  n => COMP TT (CONST n)
  | FF'     e => COMP (pf e) FF
  | ADD'    e f => COMP (PAIR (pf e) (pf f)) ADD
  | MUL'    e f => COMP (PAIR (pf e) (pf f)) MUL
  | PAIR'   e f => PAIR (pf e) (pf f)
  | EVAL'   e f => COMP (PAIR (pf e) (pf f)) EVAL
  | FOLD'   e f => COMP (PAIR ID (pf f)) (FOLD   (pf e))
  | UNFOLD' e f => COMP (PAIR ID (pf f)) (UNFOLD1 (pf e))
  | EQ'     e f => COMP (PAIR (pf e) (pf f)) EQ
  | UNION'  e f => COMP (PAIR (pf e) (pf f)) UNION
  | BIND'   e f => COMP (COMP (PAIR ID (pf e)) (COMP TENSOR (MAP (pf f)))) FLATTEN
  | CASE' l r e => COMP (COMP (PAIR ID (pf e)) DIST) (CASE (pf l) (pf r))
 end).
Defined.

(** Example: the closed term

  |- (\x:nat. 7 + (\y:nat. x * y)5 )3 : nat

in de Bruijn (point-full CAML) syntax *)
Definition pfEx1 : exp nil INT :=
EVAL' (CURRY' (ADD' (CONST' 7)
(EVAL' (CURRY' (MUL' (VAR' (HNext HFirst)) (VAR' HFirst))) (CONST' 5)))) (CONST' 3).

(* the point-free translation *)
Definition pfEx1Trans := pf pfEx1.
Compute pfEx1Trans.
Compute (ExpD pfEx1Trans tt).

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

Definition lift2 {G t' t s} (e : exp (s::G) t) : exp (s :: t' :: G) t.
 pose ( WEAKEN' t' e ). apply EXCH' in e0. assumption.
Defined.

Lemma monadlaw_assoc' {G t t' u} : forall (m: exp G (SET t'))
  (f: exp (t'::G) (SET t)) (g: exp (t::G) (SET u)),
  ExpD (pf (BIND' m (BIND' f (lift2 g)))) = ExpD (pf (BIND' (BIND' m f) g)) .
Proof.
  intros. simpl in *. fold TyD. apply functional_extensionality. intros env.
  apply set_extensionality; intros x. fold TyD in *. intuition.

  simpl in *. destruct H. destruct H. destruct H. destruct H.  destruct H.
  subst. destruct H0.  destruct H.  destruct H.
  destruct x1,x2; simpl in *. destruct H. destruct H. subst. simpl in *.
  exists ( (ExpD (pf g) (t0, t2))).
 intuition. exists (t0, t2). intuition. simpl.
 exists (ExpD (pf f) (t0, t1)). intuition. exists (t0,t1). intuition.

 simpl in *. destruct H. destruct H. destruct H. destruct H.  destruct H.
  subst. destruct H2.  destruct H.  destruct H.
  destruct x1,x2; simpl in *. destruct H. destruct H. subst. simpl in *.
  exists ( (fun z : TyD u =>
 exists y : TyD u -> Prop,
   (exists y0 : TyD (pfG G) * TyD t' * TyD t,
      (fst y0 = (t0, t3) /\ ExpD (pf f) (t0, t3) (snd y0)) /\
      ExpD (pf g) (fst (fst y0), snd y0) = y) /\
   y z)).
 intuition. exists (t0, t3). intuition.
 exists (ExpD (pf g) (t0, t1)). intuition. exists (t0,t3,t1). intuition.
Qed.

Lemma monadlaw_empty1 {G t t'} : forall (f: exp (t::G) (SET t')),
  ExpD (pf (BIND' EMPTY' f)) = ExpD (pf EMPTY').
Proof.
  intros. simpl. fold TyD. apply functional_extensionality. intros x.
  apply set_extensionality. intros e. intuition.
  repeat destruct H; auto.
Qed.

Lemma monadlaw_empty2 {G t t'} : forall (f: exp (t::G) (SET t')),
  ExpD (pf (BIND' f (@EMPTY' _ (SET t)) )) = ExpD (pf EMPTY').
Proof.
  intros. simpl. fold TyD. apply functional_extensionality. intros x.
  apply set_extensionality. intros e. intuition.
  repeat destruct H; auto.
  subst. auto.
Qed.

Lemma monadlaw_eta {G t} : forall (e: exp G (SET t)),
  ExpD (pf (BIND' e (SNG' (VAR' HFirst)))) = ExpD (pf e).
Proof.
  intros. simpl. fold TyD. apply functional_extensionality. intros g.
  apply set_extensionality. intros y. intuition.
  repeat destruct H; auto.
  subst. subst. auto. exists (fun z => ExpD (pf e) g z /\ z = y). fold TyD.
  split; auto. exists ((g,y)). split. auto. simpl. apply set_extensionality.
  intros z. split; intros. subst. auto. destruct H0. auto.
Qed.

Lemma monadlaw_beta {G t t'} : forall (e: exp G t) (f: exp (t::G) (SET t')),
  ExpD (pf (BIND' (SNG' e) f)) = ExpD (pf (SUBST' f e)).
Proof.
 intros. simpl. fold TyD. apply functional_extensionality. intros g.
  apply set_extensionality. intros y. intuition.
  repeat destruct H. subst. destruct x0; simpl in *. subst. auto.
 exists (ExpD (pf f) (g, ExpD (pf e) g)). intuition. simpl.
 exists ((g, ExpD (pf e) g)). intuition.
Qed.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf.

Require Import List. Import ListNotations.
Require Import Strings.String.

Definition irred e : Prop := forall b, ~(step e b).

Notation "Γ ⊢ E ⇒ A" := (Typing Γ E Inf A) (at level 45).
Notation "Γ ⊢ E ⇐ A" := (Typing Γ E Chk A) (at level 45).

Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0).
Notation "t ^^ u"       := (open_exp_wrt_exp t u) (at level 67).
Notation "e ^ x"        := (open_exp_wrt_exp e (e_var_f x)).

Notation "v ~-> A v'" := (TypedReduce v A v') (at level 68).

Notation "t ->* r" := (steps t r) (at level 68).
Notation "t ->** r" := (gsteps t r) (at level 68).

Lemma star_one:
forall a b, step a (Expr b) -> steps a (Expr b).
Proof.
eauto using steps.
Qed.

Lemma star_trans:
forall a b, steps a (Expr b) -> forall c, steps b (Expr c) -> steps a (Expr c).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Lemma gstar_one:
forall a b, gstep a (Expr b) -> gsteps a (Expr b).
Proof.
eauto using steps.
Qed.

Lemma gstar_trans:
forall a b, gsteps a (Expr b) -> forall c, gsteps b (Expr c) -> gsteps a (Expr c).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Hint Resolve star_one star_trans gstar_one gstar_trans : core.

(** [x # E] to be read x fresh from E captures the fact that
    x is unbound in E . *)

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.

Definition env := list (atom * exp).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  let E := gather_atoms_with (fun x : ctx => dom x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  constr:(A `union` B `union` C `union` D `union` F).

Lemma value_lc : forall v,
    value v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
  eapply lc_e_save.
  inverts* H.
Qed.

Lemma step_not_value: forall (v:exp),
    value v -> irred v.
Proof.
  introv.
  unfold irred.
  inductions v; introv H;
  inverts* H;
  unfold not;intros.
  - inverts* H.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    destruct E; unfold simpl_fill in H0; inverts* H0.
  - inverts* H.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    destruct E; unfold simpl_fill in H0; inverts* H0.
  - inverts* H.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    destruct E; unfold simpl_fill in H0; inverts* H0.
Qed.

Lemma multi_red_app : forall v t t',
    value v -> t ->* (Expr t') -> (e_app v t) ->* (Expr (e_app v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(simpl_wf (sappCtxR v)). eauto.
  forwards*: do_step H1 H.
Qed.

Lemma multi_red_app2 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->* (Expr t1') -> (e_app t1 t2) ->* (Expr (e_app t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  assert(simpl_wf (sappCtxL t2)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma multi_red_add : forall v t t',
    value v -> t ->* (Expr t') -> (e_add v t) ->* (Expr (e_add v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(simpl_wf (saddCtxR v)). eauto.
  forwards*: do_step H1 H.
Qed.

Lemma multi_red_add2 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->* (Expr t1') -> (e_add t1 t2) ->* (Expr (e_add t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  assert(simpl_wf (saddCtxL t2)). eauto.
  forwards*: do_step H0 H.
Qed.

Lemma multi_red_anno : forall A t t',
    not (value (e_anno t A)) ->
    t ->* (Expr t') -> (e_anno t A) ->* (Expr (e_anno t' A)).
Proof.
  introv nt Red.
  inductions Red; eauto.
  assert(step (e_anno e A) (Expr (e_anno e' A))). eauto.
  forwards*: IHRed.
  unfold not; intros.
  apply nt.
  inverts H1.
  inverts* H.
  destruct E; unfold simpl_fill in H1; inverts* H1.
  inverts* H2.
  inverts* H.
  destruct E; unfold simpl_fill in H1; inverts* H1.
  inverts* H2.
Qed.

Lemma gmulti_red_app : forall v t t',
    gvalue v -> t ->** (Expr t') -> (e_app v t) ->** (Expr (e_app v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(wellformed (appCtxR v)). eauto.
  forwards*: gdo_step H1 H.
Qed.

Lemma multi_blame_app : forall v t,
    gvalue v -> t ->** (Blame) -> (e_app v t) ->** (Blame).
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply gstep_nb.
  assert(wellformed (appCtxR v)). eauto.
  forwards*: gdo_step H0 H.
  simpl. forwards*: IHRed.
  apply gstep_b.
  assert(wellformed (appCtxR v)). eauto.
  forwards*: gblame_step H0 H.
Qed.

Lemma gmulti_red_app2 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->** (Expr t1') -> (e_app t1 t2) ->** (Expr (e_app t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  assert(wellformed (appCtxL t2)). eauto.
  forwards*: gdo_step H0 H.
Qed.

Lemma multi_blame_app2 : forall t1 t2 ,
    lc_exp t2 -> t1 ->** Blame -> (e_app t1 t2) ->** Blame.
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply gstep_nb.
  assert(wellformed (appCtxL t2)). eauto.
  forwards*: gdo_step H0 H.
  simpl. forwards*: IHRed.
  apply gstep_b.
  assert(wellformed (appCtxL t2)). eauto.
  forwards*: gblame_step H0 H.
Qed.

Lemma gmulti_red_anno : forall A t t',
    t ->** (Expr t') -> (e_anno t A) ->** (Expr (e_anno t' A)).
Proof.
  introv Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(wellformed (annoCtx A)). eauto.
  forwards*: gdo_step H1 H.
Qed.

Lemma multi_blame_anno : forall t A ,
    t ->** Blame -> (e_anno t A) ->** Blame.
Proof.
  introv Red.
  inductions Red; eauto.
  eapply gstep_nb.
  assert(wellformed (annoCtx A)). eauto.
  forwards*: gdo_step H0 H.
  simpl. forwards*: IHRed.
  apply gstep_b.
  assert(wellformed (annoCtx A)). eauto.
  forwards*: gblame_step H0 H.
Qed.