(** * Commutativity *)

From Coq Require Import
  Classes.Morphisms.
From DEZ Require Export
  Init.

(** ** Commutative Elements of a Form *)

Class IsCommElemsForm (A B : Type) (X : A -> A -> Prop)
  (s : B -> B -> A) (a b : B) : Prop :=
  comm_elems_form : X (s a b) (s b a).

(** ** Commutative Form *)

Class IsCommForm (A B : Type) (X : A -> A -> Prop)
  (s : B -> B -> A) : Prop :=
  comm_form (a b : B) : X (s a b) (s b a).

Section Context.

Context (A B : Type) (X : A -> A -> Prop)
  (s : B -> B -> A).

(** Commutative forms are forms with commutative elements. *)

#[export] Instance comm_form_is_comm_elems_form
  `{!IsCommForm X s} (a b : B) : IsCommElemsForm X s a b.
Proof. apply comm_form. Qed.

#[local] Instance comm_elems_form_is_comm_form
  `{!forall a b : B, IsCommElemsForm X s a b} : IsCommForm X s.
Proof. intros a b. apply comm_elems_form. Qed.

End Context.

(** ** Commutative Elements of a Binary Operation *)

Class IsCommElemsBinOp (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (x y : A) : Prop :=
  comm_elems_bin_op : X (k x y) (k y x).

(** ** Commutative Binary Operation *)

(** This has the same shape as [Z.mul_comm]. *)

Class IsCommBinOp (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) : Prop :=
  comm_bin_op (x y : A) : X (k x y) (k y x).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A).

(** Commutative binary operations
    are binary operations with commutative elements. *)

#[export] Instance comm_bin_op_is_comm_elems_bin_op
  `{!IsCommBinOp X k} (x y : A) : IsCommElemsBinOp X k x y.
Proof. apply comm_bin_op. Qed.

#[local] Instance comm_elems_bin_op_is_comm_bin_op
  `{!forall x y : A, IsCommElemsBinOp X k x y} : IsCommBinOp X k.
Proof. intros x y. apply comm_elems_bin_op. Qed.

End Context.

(** ** Coherent Unary Functions *)

Class IsCommUnFns (A B0 B1 C : Type) (X : C -> C -> Prop)
  (f : A -> B0) (g : A -> B1) (h : B1 -> C) (i : B0 -> C) : Prop :=
  comm_un_fns (x : A) : X (h (g x)) (i (f x)).

(** ** Commutative Unary Operations *)

Class IsCommUnOps (A : Type) (X : A -> A -> Prop)
  (f g : A -> A) : Prop :=
  comm_un_ops (x : A) : X (f (g x)) (g (f x)).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (f g : A -> A).

(** Commutativity of unary operations
    is a special case of their commutativity as unary functions. *)

#[export] Instance comm_un_ops_is_comm_un_fns
  `{!IsCommUnOps X f g} : IsCommUnFns X f g f g.
Proof. auto. Qed.

#[local] Instance comm_un_fns_is_comm_un_ops
  `{!IsCommUnFns X f g f g} : IsCommUnOps X f g.
Proof. auto. Qed.

End Context.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (f g : A -> A).

(** Commutative unary operations are commutative elements
    of the endofunction monoid. *)

#[export] Instance comm_un_ops_is_comm_elems_bin_op_compose
  `{!IsCommUnOps X f g} : IsCommElemsBinOp (pointwise_relation _ X) _o_ f g.
Proof. intros x. unfold compose. apply comm_un_ops. Qed.

#[local] Instance comm_elems_bin_op_compose_is_comm_un_ops
  `{!IsCommElemsBinOp (pointwise_relation _ X) _o_ f g} : IsCommUnOps X f g.
Proof.
  intros x.
  change (f (g x)) with ((f o g) x).
  change (g (f x)) with ((g o f) x).
  pose proof comm_elems_bin_op x as a.
  apply a.
Qed.

End Context.

(** ** Binary Functions Left-Commuting over Unary Functions *)

Class IsCommBinFnsL (A0 A1 B0 B1 C : Type) (X : C -> C -> Prop)
  (k : A0 -> A1 -> B1) (f : A0 -> B0)
  (m : B0 -> A1 -> C) (g : B1 -> C) : Prop :=
  comm_bin_fns_l (x : A0) (y : A1) : X (m (f x) y) (g (k x y)).

(** ** Binary Functions Right-Commuting over Unary Functions *)

Class IsCommBinFnsR (A0 A1 B0 B1 C : Type) (X : C -> C -> Prop)
  (k : A0 -> A1 -> B0) (f : A1 -> B1)
  (m : A0 -> B1 -> C) (g : B0 -> C) : Prop :=
  comm_bin_fns_r (x : A0) (y : A1) : X (m x (f y)) (g (k x y)).

Section Context.

Context (A0 A1 B0 B1 C : Type) (X : C -> C -> Prop)
  (k : A0 -> A1 -> B1) (f : A0 -> B0) (m : B0 -> A1 -> C) (g : B1 -> C).

(** Left-commutativity of binary functions over unary functions
    is a special case of the right-commutativity of their flipped versions. *)

#[local] Instance comm_bin_fns_l_is_comm_bin_fns_r_flip
  `{!IsCommBinFnsL X k f m g} : IsCommBinFnsR X (flip k) f (flip m) g.
Proof. intros y x. unfold flip in *. eauto. Qed.

#[local] Instance comm_bin_fns_r_flip_is_comm_bin_fns_l
  `{!IsCommBinFnsR X (flip k) f (flip m) g} : IsCommBinFnsL X k f m g.
Proof. intros x y. unfold flip in *. eauto. Qed.

End Context.

(** ** Right Action Left-Commuting over a Unary Function *)

Class IsCommActRL (A B : Type) (X : B -> B -> Prop)
  (ar : B -> A -> B) (f : B -> B) : Prop :=
  comm_act_r_l (a : B) (x : A) : X (ar (f a) x) (f (ar a x)).

Section Context.

Context (A B : Type) (X : B -> B -> Prop)
  (f : B -> B) (ar : B -> A -> B).

(** Left-commutativity of a right action over a unary function
    is a special case of its left-commutativity
    as a binary function over a unary function. *)

#[export] Instance comm_act_r_l_is_comm_bin_fns_l
  `{!IsCommActRL X ar f} : IsCommBinFnsL X ar f ar f.
Proof. auto. Qed.

#[local] Instance comm_bin_fns_l_is_comm_act_r_l
  `{!IsCommBinFnsL X ar f ar f} : IsCommActRL X ar f.
Proof. auto. Qed.

End Context.

(** ** Left Action Right-Commuting over a Unary Function *)

Class IsCommActLR (A B : Type) (X : B -> B -> Prop)
  (al : A -> B -> B) (f : B -> B) : Prop :=
  comm_act_l_r (x : A) (a : B) : X (al x (f a)) (f (al x a)).

Section Context.

Context (A B : Type) (X : B -> B -> Prop)
  (f : B -> B) (al : A -> B -> B).

(** Right-commutativity of a left action over a unary function
    is a special case of its right-commutativity
    as a binary function over a unary function. *)

#[export] Instance comm_act_l_r_is_comm_bin_fns_r
  `{!IsCommActLR X al f} : IsCommBinFnsR X al f al f.
Proof. auto. Qed.

#[local] Instance comm_bin_fns_r_is_comm_act_l_r
  `{!IsCommBinFnsR X al f al f} : IsCommActLR X al f.
Proof. auto. Qed.

End Context.

(** ** Binary Operation Left-Commuting over a Unary Operation *)

(** This has the same shape as [Z.mul_opp_l]. *)

Class IsCommL (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (f : A -> A) : Prop :=
  comm_l (x y : A) : X (k (f x) y) (f (k x y)).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (f : A -> A).

(** Left-commutativity of a binary operation over a unary operation
    is a special case of its left-commutativity
    as a binary function over a unary function. *)

#[export] Instance comm_l_is_comm_bin_fns_l
  `{!IsCommL X k f} : IsCommBinFnsL X k f k f.
Proof. auto. Qed.

#[local] Instance comm_bin_fns_l_is_comm_l
  `{!IsCommBinFnsL X k f k f} : IsCommL X k f.
Proof. auto. Qed.

(** Left-commutativity of a binary operation over a unary operation
    is a special case of the commutativity
    of its flipped partial application over the unary operation. *)

#[export] Instance comm_l_is_comm_un_ops_flip
  `{!IsCommL X k f} (x : A) : IsCommUnOps X (flip k x) f.
Proof. intros y. unfold flip. apply comm_l. Qed.

#[local] Instance comm_un_ops_flip_is_comm_l
  `{!forall x : A, IsCommUnOps X (flip k x) f} : IsCommL X k f.
Proof.
  intros x y.
  change (k x y) with (flip k y x).
  change (k (f x) y) with (flip k y (f x)).
  apply comm_un_ops.
Qed.

End Context.

(** ** Binary Operation Right-Commuting over a Unary Operation *)

(** This has the same shape as [Z.mul_opp_r]. *)

Class IsCommR (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (f : A -> A) : Prop :=
  comm_r (x y : A) : X (k x (f y)) (f (k x y)).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (f : A -> A).

(** Right-commutativity of a binary operation over a unary operation
    is a special case of its right-commutativity
    as a binary function over a unary function. *)

#[export] Instance comm_r_is_comm_bin_fns_r
  `{!IsCommR X k f} : IsCommBinFnsR X k f k f.
Proof. auto. Qed.

#[local] Instance comm_bin_fns_r_is_comm_r
  `{!IsCommBinFnsR X k f k f} : IsCommR X k f.
Proof. auto. Qed.

(** Right-commutativity of a binary operation over a unary operation
    is a special case of the commutativity
    of its partial application over the unary operation. *)

#[export] Instance comm_r_is_comm_un_ops
  `{!IsCommR X k f} (x : A) : IsCommUnOps X (k x) f.
Proof. intros y. apply comm_r. Qed.

#[local] Instance comm_un_ops_is_comm_r
  `{!forall x : A, IsCommUnOps X (k x) f} : IsCommR X k f.
Proof. intros x y. apply comm_un_ops. Qed.

End Context.

(** ** Commutative Binary Operation over a Unary Operation *)

Class IsComm (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (f : A -> A) : Prop := {
  comm_is_comm_l :> IsCommL X k f;
  comm_is_comm_r :> IsCommR X k f;
}.


Require Export Iron.Language.SystemF2Effect.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.SubstTT.Base.

(* If we lift at depth d, this creates an empty space and
   substituting into it doens't do anything. *)
Lemma substTT_liftTT
 :  forall d t1 t2
 ,  substTT d t2 (liftTT 1 d t1) = t1.
Proof.
 intros. gen d t2.
 induction t1; intros;
  first [ solve [snorm; try omega; nope]
        | solve [simpl; f_equal; norm]].
Qed.
Hint Rewrite substTT_liftTT : global.

(* Lifting after substitution,
   with the lifting at a lower index. *)
Lemma liftTT_substTT_1
 :  forall n n' t1 t2
 ,  liftTT 1 n (substTT (n + n') t2 t1)
 =  substTT (1 + n + n') (liftTT 1 n t2) (liftTT 1 n t1).
Proof.
 intros. gen n n' t2.
 induction t1; intros;
  try (solve [snorm; repeat f_equal; burn]).

 - Case "TVar".
   snorm; try omega.
   f_equal. omega.
   f_equal. omega.

 - Case "TForall".
   snorm.
   rewrite (IHt1 (S n) n').
   rewrite (liftTT_liftTT_11 0 n).
   f_equal.
Qed.

Lemma liftTT_substTT
 :  forall m n n' t1 t2
 ,  liftTT m n (substTT (n + n') t2 t1)
 =  substTT (m + n + n') (liftTT m n t2) (liftTT m n t1).
Proof.
 intros. gen n n'.
 induction m; intros; simpl.
 - burn.

 - rrwrite (S m = 1 + m).
   rewrite liftTT_plus.
   rewritess.
   rrwrite (m + n + n' = n + (m + n')) by omega.
   rewrite liftTT_substTT_1.
   burn.
Qed.
Hint Rewrite <- liftTT_substTT : global.

(* Lifting after substiution,
   with the lifting at a higher index *)
Lemma liftTT_substTT'
 :  forall n n' t1 t2
 ,  liftTT 1 (n + n') (substTT n t2 t1)
 =  substTT n (liftTT 1 (n + n') t2) (liftTT 1 (1 + n + n') t1).
Proof.
 intros. gen n n' t2.
 induction t1; intros;
  try (solve [simpl; f_equal; rewritess; norm]).

 - Case "TVar".
   repeat ( unfold liftTT; unfold substTT; fold liftTT; fold substTT
          ; try lift_cases
          ; try fbreak_nat_compare
          ; intros); try omega; burn.
   f_equal. omega.

 - Case "TForall".
   simpl. rewrite (IHt1 (S n) n').
   simpl. rewrite (liftTT_liftTT_11 0 (n + n')).
   burn.
Qed.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
From Coq Require Import Lia.
Import ListNotations.

Open Scope string_scope.

Definition total_map (A : Type) := string -> A.

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.
Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof.
  intros s. unfold eqb_string.
  destruct (string_dec s s) as [Hs_eq | Hs_not_eq].
  - reflexivity.
  - destruct Hs_not_eq. reflexivity.
Qed.
Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
   intros x y.
   unfold eqb_string.
   destruct (string_dec x y) as [Hs_eq | Hs_not_eq].
   - rewrite Hs_eq. split. reflexivity. reflexivity.
   - split.
     + intros contra. discriminate contra.
     + intros H. exfalso. apply Hs_not_eq. apply H.
Qed.
Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.
Theorem false_eqb_string : forall x y : string,
   x <> y -> eqb_string x y = false.
Proof.
  intros x y. rewrite eqb_string_false_iff.
  intros H. apply H. Qed.

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).
Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.
Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).
Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).
Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
  intros. unfold t_empty. easy.
Qed.
Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  intros. unfold t_update. rewrite <- eqb_string_refl. easy.
Qed.
Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
Proof.
  intros A m x1 x2 v Hneq. unfold t_update. rewrite false_eqb_string; easy.
Qed.
Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  intros A m x v1 v2. apply functional_extensionality. intros xarg.
  unfold t_update. destruct (eqb_string x xarg). - easy. - easy.
Qed.
Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
  intros x y. apply iff_reflect. rewrite eqb_string_true_iff. easy.
Qed.
Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
  intros. apply functional_extensionality. intros xarg.
  unfold t_update. destruct (eqb_stringP x xarg).
    + rewrite e. easy.
    + easy.
Qed.

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  intros A m v1 v2 x1 x2 Hneq. apply functional_extensionality. intros xarg.
  unfold t_update. destruct (eqb_stringP x1 xarg).
  - rewrite <- e. destruct (eqb_stringP x2 x1).
    + unfold not in Hneq. apply Hneq in e0. destruct e0.
    + easy.
  - easy.
Qed.

Definition State := (total_map nat).

(* Given part of exam, look below for answers. *)

Inductive AExp1 : Type :=
  | AN (n : nat)
  | AX (x : string)
  | AAdd (e1 e2 : AExp1)
  | AAss (x : string) (e : AExp1)
.

Inductive OS1 : AExp1 -> State -> nat -> State -> Prop :=
  | OS1_Num (n : nat) (s : State)
    : OS1 (AN n) s n s
  | OS1_Var (x : string) (s : State) (n : nat)
                         (H : (s x) = n)
    : OS1 (AX x) s n s
  | OS1_Asgn (x : string) (e : AExp1) (n : nat) (s s' : State)
                          (H : OS1 e s n s')
    : OS1 (AAss x e) s 1 (t_update s' x n)
  | OS1_Add (e1 e2 : AExp1) (s s1 s2 : State) (n n1 n2 : nat)
            (H1: OS1 e1 s n1 s1) (H2: OS1 e2 s1 n2 s2)
            (HAdd : n = (n1 + n2))
    : OS1 (AAdd e1 e2) s n s2
.

(* Question 1 *)

Definition Z := nat.
Definition Var := string.

Inductive AExp : Type :=
  | A_N (n : Z)
  | A_V (x : Var)
  | A_Add (e1 e2 : AExp)
  | A_Ass (x : Var) (e : AExp)
  | A_Fail
  | A_Otherwise (e1 e2 : AExp)
.

Inductive Return : Type :=
  | Good (z : Z) (s : State)
  | Abort
.

Inductive OS : AExp -> State -> Return -> Prop :=
  | OS_Num (n : Z) (s : State)
    : OS (A_N n) s (Good n s)
  | OS_Var (x : Var) (s : State) (n : Z)
                         (H : (s x) = n)
    : OS (A_V x) s (Good n s)
  | OS_Asgn (x : Var) (e : AExp) (n : Z) (s s' : State)
                          (H : OS e s (Good n s'))
    : OS (A_Ass x e) s (Good 1 (t_update s' x n))
  | OS_Add (e1 e2 : AExp) (s s1 s2 : State) (n n1 n2 : Z)
            (H1: OS e1 s (Good n1 s1)) (H2: OS e2 s1 (Good n2 s2))
            (HAdd : n = (n1 + n2))
    : OS (A_Add e1 e2) s (Good n s2)
  | OS_Fail (s : State)
    : OS A_Fail s Abort
  | OS_OtherwiseSafe (e1 e2 : AExp) (s s' : State) (n : Z)
            (H : OS e1 s (Good n s'))
    : OS (A_Otherwise e1 e2) s (Good n s')
  | OS_OtherwiseAbrt (e1 e2 : AExp) (s : State) (r : Return)
            (H1 : OS e1 s Abort) (H2 : OS e2 s r)
    : OS (A_Otherwise e1 e2) s r
  | OS_AddLeftAbrt (e1 e2 : AExp) (s : State)
            (H : OS e1 s Abort)
    : OS (A_Add e1 e2) s Abort
  | OS_AddRightAbrt (e1 e2 : AExp) (s s' : State) (n : Z)
            (H : OS e1 s (Good n s'))
            (H : OS e2 s' Abort)
    : OS (A_Add e1 e2) s Abort
  | OS_AsgnAbrt (x : Var) (e1 : AExp) (s : State)
            (H : OS e1 s Abort)
    : OS (A_Ass x e1) s Abort
.

(* Question 2 *)

Definition q2_exp := A_Add (A_Ass "b" (A_Otherwise
                                       (A_Ass "a" (A_Add (A_N 3) A_Fail))
                                       (A_V "a")))
                           (A_V "b").

Definition q2_state : State := ("a" !-> 3 ; "b" !-> 8 ; _ !-> 0).

Definition q2 := exists z s, OS q2_exp q2_state (Good z s).

Theorem q2_answer : q2.
Proof. unfold q2. unfold q2_exp. unfold q2_state.
  exists 4. eexists.
  eapply OS_Add.
  - eapply OS_Asgn. eapply OS_OtherwiseAbrt.
    + eapply OS_AsgnAbrt. eapply OS_AddRightAbrt.
      * constructor.
      * apply OS_Fail.
    + apply OS_Var. easy.
  - apply OS_Var. easy.
  - constructor.
Qed.


Require Import VST.msl.base.
Require Import VST.msl.sepalg.
Require Import VST.msl.sepalg_generators.

Section SepAlgPack.

  Variable A : Type.
  Variable JA : Join A.

  Inductive Tree : Type :=
  | Leaf: A -> Tree
  | Node: list (prod Tree nat) -> Tree.

  Definition Forest : Type := list (prod Tree nat).

  Inductive flattenR : Tree -> list A -> Prop :=
  | leafR : forall a, flattenR (Leaf a) (a :: nil)
  | nodeR : forall f l, flattenRForest f l -> flattenR (Node f) l
  with flattenRForest : list (prod Tree nat) -> list A -> Prop :=
  | forestR_nil: flattenRForest nil nil
  | forestR_cons: forall t n l0 f l, flattenR t l0 -> flattenRForest f l -> flattenRForest ((t, n) :: f) (l0 ++ l).

  Inductive decreaseLH : list (prod Tree nat) -> nat -> Prop :=
  | decreaseL_nil: forall n, decreaseLH nil n
  | decreaseL_cons: forall t n0 n l, n > n0 -> decreaseLH l n0 -> decreaseLH ((t, n0) :: l) n.

  Inductive decreaseL : list (prod Tree nat) -> Prop := decrease_intro: forall n f, decreaseLH f n -> decreaseL f.

  Inductive decreaseTree : Tree -> Prop :=
  | leafD : forall a, decreaseTree (Leaf a)
  | nodeD : forall f, decreaseL f -> Forall decreaseTree (fst (split f)) -> decreaseTree (Node f).

  Definition decreaseForest : Forest -> Prop := fun f => Forall decreaseTree (fst (split f)).

  Fixpoint iter_joinable (l : list A) (u : A) (j : A) : Prop :=
    match l with
      | nil => u = j
      | x :: l' => exists j', iter_joinable l' u j' /\ join x j' j
    end.

  Definition Legal (f : Forest) (u : A) : Prop := decreaseForest f /\ exists l j, flattenRForest f l /\ iter_joinable l u j.

  Lemma Legal_nil: forall u, Legal nil u.
  Proof.
    intros.
    split.
    + constructor.
    + exists nil, u.
      split.
      - constructor.
      - simpl; auto.
  Defined.

  Record PackNode := mkNodeOfSA {
                         f : Forest;
                         u : A;
                         legal : Legal f u
                       }.

  Definition mergeR (F1 F2 F: Forest) := forall T, In T F <-> (In T F1 \/ In T F2).

  Inductive join_Pack: PackNode -> PackNode -> PackNode -> Prop :=
  | join_Pack_constr: forall fx fy fz u lx ly lz,
     mergeR fx fy fz ->
     join_Pack (mkNodeOfSA fx u lx) (mkNodeOfSA fy u ly) (mkNodeOfSA fz u lz).

  Definition core_Pack (x: PackNode) : PackNode :=
    match x with
    | mkNodeOfSA f u legal => mkNodeOfSA nil u (Legal_nil u)
    end.

  Instance Join_Pack: Join PackNode := join_Pack.

  Instance Perm_Pack: Perm_alg PackNode.
  Proof.
    constructor.

    (* join_eq *)
    intros.
    unfold join, Join_Pack in *.
    destruct x, y, z, z'.
    inversion H; clear H;
    inversion H0; clear H0.
    subst; subst u3.
    f_equal.
  Abort.
End SepAlgPack.


Require Import Arith.

Set Implicit Arguments.

Fixpoint ack n :=
  match n with
    | 0 => S
    | S n' =>
      let fix f m :=
        match m with
          | 0 => ack n' 1
          | S m' => ack n' (f m')
        end
        in f
  end.

Fixpoint fin n : Set :=
  match n with
    | 0 => Empty_set
    | S n' => (unit + fin n')%type
  end.

Inductive prim_rec : nat -> Set :=
| pr_proj : forall n, fin n -> prim_rec n
| pr_succ : prim_rec 1
| pr_const : forall n, nat -> prim_rec n
| pr_compose :
  forall m n, (fin n -> prim_rec m) -> prim_rec n -> prim_rec m
| pr_primrec :
  forall n, prim_rec n -> prim_rec (S (S n)) -> prim_rec (S n).

Notation F0 := (inl _ tt).
Notation FS x := (inr _ x).

Definition hd n (ns : fin (S n) -> nat) := ns F0.
Definition tl n (ns : fin (S n) -> nat) := fun i => ns (FS i).

Notation "[ x , y ]" := (fun i => match i with inl _ => x | inr i' => y i' end).

Fixpoint eval n (f : prim_rec n) : (fin n -> nat) -> nat :=
  match f with
    | pr_proj n i => fun ns => ns i
    | pr_succ => fun ns => S (ns F0)
    | pr_const n k => fun _ => k
    | pr_compose m n fs g => fun ns => eval g (fun i => eval (fs i) ns)
    | pr_primrec n f g => fun ns =>
      let fix h m :=
        match m with
          | 0 => eval f (tl ns)
          | S m' => eval g [m', [h m', tl ns]]
        end
        in h (ns F0)
  end.


Require Export Arith.EqNat.

Require Import Arith.EqNat.

Example test_beq_natlist1 : (beq_nat 2 2 = true).
Proof.


C02W82DBHV2R:~ i847419$ coqtop
Welcome to Coq 8.8.0 (April 2018)

Coq < Require Import Classical.

Coq < Theorem exp015 : (forall P Q : Prop, ((P -> Q) /\ ~Q) -> ~P).
1 subgoal

  ============================
  forall P Q : Prop, (P -> Q) /\ ~ Q -> ~ P

exp015 < intros.
1 subgoal

  P, Q : Prop
  H : (P -> Q) /\ ~ Q
  ============================
  ~ P

exp015 < destruct H.
1 subgoal

  P, Q : Prop
  H : P -> Q
  H0 : ~ Q
  ============================
  ~ P

exp015 < tauto.
No more subgoals.

exp015 < Qed.
exp015 is defined


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_betweennotequal_1 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable axiom_nocollapse_2 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).
Variable lemma_localextension_3 : (forall A B Q : Universe, (exists X : Universe, ((A <> B /\ B <> Q) -> (betS_ A B X /\ cong_ B X B Q)))).
Variable lemma_congruencesymmetric_4 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable cn_congruencetransitive_5 : (forall B C D E P Q : Universe, ((cong_ P Q B C /\ cong_ P Q D E) -> cong_ B C D E)).
Variable axiom_5_line_6 : (forall A B C D E F G H : Universe, ((betS_ A B C /\ (betS_ E F G /\ (cong_ B C F G /\ (cong_ A D E H /\ (cong_ B D F H /\ cong_ A B E F))))) -> cong_ D C H G)).

Theorem lemma_betweennesspreserved_7 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (cong_ B C Xb Xc /\ betS_ A B C))) -> betS_ Xa Xb Xc)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import List.

Inductive Ty : Set :=
| Nat : Ty
| Arr : Ty -> Ty -> Ty.

Notation "T ==> S" := (Arr T S) (at level 30, right associativity).

Inductive Term : Set :=
| v : nat -> Term
| f : nat -> Term
| succ : Term -> Term
| zero : Term
| natcase : Term -> Term -> Term -> Term
| lam : Ty -> Term -> Term
| app : Term -> Term -> Term.

Definition Ctx := list Ty.

Inductive Holds (G : Ctx) (t : Term) (ty : Ty) : Set :=
| holds : Holds G t ty.

Notation "G |= t @ ty" := (Holds G t ty) (at level 40, no associativity).

Check forall G t ty P, P (G |= t @ ty).

Variable Delta : nat -> Term.

CoInductive PreProof

CoInductive Deduction : Set -> Set :=
| ImpElim : forall G A B r s,
  Deduction ( G |= r @ A ==> B) -> Deduction ( G |= s @ A ) ->
  Deduction ( G |= app r s @ B )
| ImpIntro : forall G A B r, Deduction ( (A::G) |=  r @ B) ->
  Deduction ( G |= lam A r @ A ==> B )
| NatIntroS : forall G r, Deduction ( G |= r @ Nat ) -> Deduction ( G |= succ r @ Nat )
| NatIntroZ : forall G, Deduction ( G |= zero @ Nat )
| NatElim : forall G C r s t,
  Deduction ( G |= r @ Nat ) -> Deduction ( G |= s @ C ) -> Deduction ( (Nat::G) |= t @ C ) ->
  Deduction ( G |= natcase r s t @ C)
| DeltaRule : forall G C r s t, Deduction (G |= s @ C ) -> Deduction (G |= s @ C).


Require Import Coq.Lists.List.
Require Import coqutil.Z.Lia.
Require Import compiler.util.Common.
Require Import compiler.NameGen.

Definition listmax(l: list nat): nat := fold_right max 0 l.

Lemma listmax_spec: forall l v, In v l -> v <= listmax l.
Proof.
  induction l; intros.
  - simpl in H. contradiction.
  - simpl in *. destruct H.
    + subst. apply Nat.le_max_l.
    + pose proof (Nat.le_max_r a (listmax l)).
      specialize (IHl v H).
      eapply Nat.le_trans; eassumption.
Qed.

Local Open Scope Z_scope.

Definition listmaxZ(l: list Z): Z := fold_right Z.max 0 l.

Lemma listmaxZ_spec: forall l v, In v l -> v <= listmaxZ l.
Proof.
  induction l; intros.
  - simpl in H. contradiction.
  - simpl in *. destruct H.
    + subst. apply Z.le_max_l.
    + pose proof (Z.le_max_r a (listmaxZ l)).
      specialize (IHl v H).
      eapply Z.le_trans; eassumption.
Qed.

Unset Universe Minimization ToSet.

#[global] Instance ZNameGen: NameGen Z Z. refine ({|
  freshNameGenState := fun l => listmaxZ l + 1;
  genFresh s := (s, s + 1);
  allFreshVars s := fun x => (s <= x)
|}).
- abstract (intros; repeat autounfold with unf_basic_set_defs unf_derived_set_defs;
            inversion H; subst; clear H; intuition blia).
- abstract (intros; repeat autounfold with unf_basic_set_defs unf_derived_set_defs;
            apply listmaxZ_spec in H; blia).
Defined.


(** * Types: Type Systems *)

Require Import Coq.Arith.Arith.

Require Import SfLib.
Require Import Maps.
Require Import Imp.
Require Import Smallstep.

Hint Constructors multi.

(** Our next major topic is _type systems_ -- static program
    analyses that classify expressions according to the "shapes" of
    their results.  We'll begin with a typed version of a very simple
    language with just booleans and numbers, to introduce the basic
    ideas of types, typing rules, and the fundamental theorems about
    type systems: _type preservation_ and _progress_.  In the next
    chapter we'll move on to the _simply typed lambda-calculus_, which
    lives at the core of every modern functional programming
    language (including Coq). *)

(* ###################################################################### *)
(** * Typed Arithmetic Expressions *)

(** To motivate the discussion of type systems, let's begin as
    usual with an extremely simple toy language.  We want it to have
    the potential for programs going wrong because of runtime type
    errors, so we need something a tiny bit more complex than the
    language of constants and addition that we used in chapter
    [Smallstep]: a single kind of data (e.g., numbers) is too simple,
    but just two kinds (numbers and booleans) gives us enough material
    to tell an interesting story.

    The language definition is completely routine.  *)

(* ###################################################################### *)
(** ** Syntax *)

(** Informally:
    t ::= true
        | false
        | if t then t else t
        | 0
        | succ t
        | pred t
        | iszero t
    Formally:
*)

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tzero : tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tiszero : tm -> tm.

(** _Values_ are [true], [false], and numeric values... *)

Inductive bvalue : tm -> Prop :=
  | bv_true : bvalue ttrue
  | bv_false : bvalue tfalse.

Inductive nvalue : tm -> Prop :=
  | nv_zero : nvalue tzero
  | nv_succ : forall t, nvalue t -> nvalue (tsucc t).

Definition value (t:tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue.
Hint Unfold value.
Hint Unfold update.

(* ###################################################################### *)
(** ** Operational Semantics *)

(** Informally: *)
(**
                    ------------------------------                  (ST_IfTrue)
                    if true then t1 else t2 ==> t1

                   -------------------------------                 (ST_IfFalse)
                   if false then t1 else t2 ==> t2

                              t1 ==> t1'
                      -------------------------                         (ST_If)
                      if t1 then t2 else t3 ==>
                        if t1' then t2 else t3

                              t1 ==> t1'
                         --------------------                         (ST_Succ)
                         succ t1 ==> succ t1'

                             ------------                         (ST_PredZero)
                             pred 0 ==> 0

                           numeric value v1
                        ---------------------                     (ST_PredSucc)
                        pred (succ v1) ==> v1

                              t1 ==> t1'
                         --------------------                         (ST_Pred)
                         pred t1 ==> pred t1'

                          -----------------                     (ST_IszeroZero)
                          iszero 0 ==> true

                           numeric value v1
                      --------------------------                (ST_IszeroSucc)
                      iszero (succ v1) ==> false

                              t1 ==> t1'
                       ------------------------                     (ST_Iszero)
                       iszero t1 ==> iszero t1'
*)

(** Formally: *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)
  | ST_Succ : forall t1 t1',
      t1 ==> t1' ->
      (tsucc t1) ==> (tsucc t1')
  | ST_PredZero :
      (tpred tzero) ==> tzero
  | ST_PredSucc : forall t1,
      nvalue t1 ->
      (tpred (tsucc t1)) ==> t1
  | ST_Pred : forall t1 t1',
      t1 ==> t1' ->
      (tpred t1) ==> (tpred t1')
  | ST_IszeroZero :
      (tiszero tzero) ==> ttrue
  | ST_IszeroSucc : forall t1,
       nvalue t1 ->
      (tiszero (tsucc t1)) ==> tfalse
  | ST_Iszero : forall t1 t1',
      t1 ==> t1' ->
      (tiszero t1) ==> (tiszero t1')

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

(** Notice that the [step] relation doesn't care about whether
    expressions make global sense -- it just checks that the operation
    in the _next_ reduction step is being applied to the right kinds
    of operands.

    For example, the term [succ true] (i.e., [tsucc ttrue] in the
    formal syntax) cannot take a step, but the almost-as-obviously
    nonsensical term
       succ (if true then true else true)
    can take a step (once, before becoming stuck). *)

(* ###################################################################### *)
(** ** Normal Forms and Values *)

(** The first interesting thing to notice about the [step] relation in
    this language is that the strong progress theorem from the
    Smallstep chapter fails.  That is, there are terms that are normal
    forms (they can't take a step) but not values (because we have not
    included them in our definition of possible "results of
    evaluation").  Such terms are _stuck_. *)

Notation step_normal_form := (normal_form step).

Definition stuck (t:tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck.

(** **** Exercise: 2 stars (some_term_is_stuck)  *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  exists (tsucc (ttrue)). unfold stuck, normal_form, value. split.
    + unfold not; intros. destruct H. inversion H; subst. inversion H1.
    + unfold not; intros [H1 | H2].
        - inversion H1.
        - inversion H2; subst. inversion H0.
Qed.

(** However, although values and normal forms are not the same in this
    language, the set of values is included in the set of normal
    forms.  This is important because it shows we did not accidentally
    define things so that some value could still take a step. *)

(** **** Exercise: 3 stars, advanced (value_is_nf)  *)
(** (Hint: You will reach a point in this proof where you need to
    use an induction to reason about a term that is known to be a
    numeric value.  This induction can be performed either over the
    term itself or over the evidence that it is a numeric value.  The
    proof goes through in either case, but you will find that one way
    is quite a bit shorter than the other.  For the sake of the
    exercise, try to complete the proof both ways.) *)

Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  (* FILL IN HERE *) Admitted. (* maybedo: interesting question, come back and do this *)

(** [] *)

(** **** Exercise: 3 stars, optional (step_deterministic)  *)
(** Use [value_is_nf] to show that the [step] relation is also
    deterministic. *)

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
  (* FILL IN HERE *) Admitted. (* optional *)
(** [] *)

(* ###################################################################### *)
(** ** Typing *)

(** The next critical observation is that, although this
    language has stuck terms, they are all "nonsensical," mixing
    booleans and numbers in a way that we don't even _want_ to have a
    meaning.  We can easily exclude such ill-typed terms by defining a
    _typing relation_ that relates terms to the types (either numeric
    or boolean) of their final results.  *)

Inductive ty : Type :=
  | TBool : ty
  | TNat : ty.

(** In informal notation, the typing relation is often written
    [|- t \in T] and pronounced "[t] has type [T]."  The [|-] symbol is
    called a "turnstile".  Below, we're going to see richer typing
    relations where an additional "context" argument is written to the
    left of the turnstile.  Here, the context is always empty. *)
(**
                           ----------------                            (T_True)
                           |- true \in Bool

                          -----------------                           (T_False)
                          |- false \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------                (T_If)
                    |- if t1 then t2 else t3 \in T

                             ------------                              (T_Zero)
                             |- 0 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Succ)
                          |- succ t1 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Pred)
                          |- pred t1 \in Nat

                            |- t1 \in Nat
                        ---------------------                        (T_IsZero)
                        |- iszero t1 \in Bool
*)

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_True :
       |- ttrue \in TBool
  | T_False :
       |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T,
       |- t1 \in TBool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- tif t1 t2 t3 \in T
  | T_Zero :
       |- tzero \in TNat
  | T_Succ : forall t1,
       |- t1 \in TNat ->
       |- tsucc t1 \in TNat
  | T_Pred : forall t1,
       |- t1 \in TNat ->
       |- tpred t1 \in TNat
  | T_Iszero : forall t1,
       |- t1 \in TNat ->
       |- tiszero t1 \in TBool

where "'|-' t '\in' T" := (has_type t T).

Hint Constructors has_type.

(* ###################################################################### *)
(** *** Examples *)

(** It's important to realize that the typing relation is a
    _conservative_ (or _static_) approximation: it does not calculate
    the type of the normal form of a term. *)

Example has_type_1 :
  |- tif tfalse tzero (tsucc tzero) \in TNat.
Proof.
  apply T_If.
    - apply T_False.
    - apply T_Zero.
    - apply T_Succ.
       + apply T_Zero.
Qed.

(** (Since we've included all the constructors of the typing relation
    in the hint database, the [auto] tactic can actually find this
    proof automatically.) *)

Example has_type_not :
  ~ (|- tif tfalse tzero ttrue \in TBool).
Proof.
  intros Contra. solve by inversion 2.  Qed.

(** **** Exercise: 1 star, optional (succ_hastype_nat__hastype_nat)  *)
Example succ_hastype_nat__hastype_nat : forall t,
  |- tsucc t \in TNat ->
  |- t \in TNat.
Proof.
  (* FILL IN HERE *) Admitted. (* optional *)
(** [] *)

(* ###################################################################### *)
(** *** Canonical forms *)

(** The following two lemmas capture the basic property that defines
    the shape of well-typed values.  They say that the definition of value
    and the typing relation agree. *)

Lemma bool_canonical : forall t,
  |- t \in TBool -> value t -> bvalue t.
Proof.
  intros t HT HV.
  inversion HV; auto.

  induction H; inversion HT; auto.
Qed.

Lemma nat_canonical : forall t,
  |- t \in TNat -> value t -> nvalue t.
Proof.
  intros t HT HV.
  inversion HV.
  inversion H; subst; inversion HT.

  auto.
Qed.

(* ###################################################################### *)
(** ** Progress *)

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are values (i.e., not stuck). *)

Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t ==> t'.

(** **** Exercise: 3 stars (finish_progress)  *)
(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the informal proof fragment in the following
    exercise before starting -- this will save you a lot of time.) *)
Proof with auto.
  intros t T HT.
  induction HT...
  (* The cases that were obviously values, like T_True and
     T_False, were eliminated immediately by auto *)
  (* T_If *)
  - right. inversion IHHT1; clear IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    inversion H; subst; clear H.
      exists t2...
      exists t3...
    + (* t1 can take a step *)
      inversion H as [t1' H1].
      exists (tif t1' t2 t3)...
  (* succ *)
  - inversion IHHT.
      + left. unfold value; right. inversion H.
          * inversion H0; subst. solve by inversion. solve by inversion.
          * constructor. assumption.
      + right. inversion H; subst. exists (tsucc x). auto.
 (* pred *)
  - inversion IHHT.
      (* pred t where t is a value *)
      + right. inversion H; inversion H0; subst.
          * solve by inversion.
          * solve by inversion.
          * exists tzero. constructor.
          * exists t...
      (* pred t where t is an expression *)
      + right. inversion H. exists (tpred x)...
  (* izzero *)
  - inversion IHHT.
      + right. inversion H; inversion H0; subst.
          * solve by inversion.
          * solve by inversion.
          * exists ttrue. constructor.
          * exists tfalse. constructor. assumption.
      + right. inversion H. exists (tiszero x)...
Qed.

(** **** Exercise: 3 stars, advanced (finish_progress_informal)  *)
(** Complete the corresponding informal proof: *)

(** _Theorem_: If [|- t \in T], then either [t] is a value or else
    [t ==> t'] for some [t']. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].  By the IH, either [t1] is a value or else [t1] can step
        to some [t1'].

            - If [t1] is a value, then by the canonical forms lemmas
              and the fact that [|- t1 \in Bool] we have that [t1]
              is a [bvalue] -- i.e., it is either [true] or [false].
              If [t1 = true], then [t] steps to [t2] by [ST_IfTrue],
              while if [t1 = false], then [t] steps to [t3] by
              [ST_IfFalse].  Either way, [t] can step, which is what
              we wanted to show.

            - If [t1] itself can take a step, then, by [ST_If], so can
              [t].

      - (* FILL IN HERE *)
[] *)

(** This is more interesting than the strong progress theorem that we
    saw in the [Smallstep] chapter, where _all_ normal forms were
    values.  Here, a term can be stuck, but only if it is ill
    typed. *)

(** **** Exercise: 1 star (step_review)  *)  (* todo: check this *)
(** Quick review.  Answer _true_ or _false_.  In this language...
      - Every well-typed normal form is a value.
          true.

      - Every value is a normal form.
          true

      - The single-step evaluation relation is
        a partial function (i.e., it is deterministic).
          true

      - The single-step evaluation relation is a _total_ function.
          false. if the term [t] is illtyped there is no [t'] it can step to.
*)
(** [] *)

(* ###################################################################### *)
(** ** Type Preservation *)

(** The second critical property of typing is that, when a well-typed
    term takes a step, the result is also a well-typed term.

    This theorem is often called the _subject reduction_ property,
    because it tells us what happens when the "subject" of the typing
    relation is reduced.  This terminology comes from thinking of
    typing statements as sentences, where the term is the subject and
    the type is the predicate. *)

Theorem preservation : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.

(** **** Exercise: 2 stars (finish_preservation)  *)
(** Complete the formal proof of the [preservation] property.  (Again,
    make sure you understand the informal proof fragment in the
    following exercise first.) *)
Proof with auto.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try (solve by inversion).
    - (* T_If *) inversion HE; subst; clear HE.
      + (* ST_IFTrue *) assumption.
      + (* ST_IfFalse *) assumption.
      + (* ST_If *) apply T_If; try assumption.
        apply IHHT1; assumption.
    (* succ *)
    - inversion HE; subst ...
    (* pred *)
    - inversion HE; subst.
        + apply T_Zero.
        + inversion HT. assumption.
        + apply T_Pred. apply IHHT. assumption.
    (* zero *)
    - inversion HE; subst ...
Qed.

(** **** Exercise: 3 stars, advanced (finish_preservation_informal)  *)
(** Complete the following proof: *)

(** _Theorem_: If [|- t \in T] and [t ==> t'], then [|- t' \in T]. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].

        Inspecting the rules for the small-step reduction relation and
        remembering that [t] has the form [if ...], we see that the
        only ones that could have been used to prove [t ==> t'] are
        [ST_IfTrue], [ST_IfFalse], or [ST_If].

           - If the last rule was [ST_IfTrue], then [t' = t2].  But we
             know that [|- t2 \in T], so we are done.

           - If the last rule was [ST_IfFalse], then [t' = t3].  But we
             know that [|- t3 \in T], so we are done.

           - If the last rule was [ST_If], then [t' = if t1' then t2
             else t3], where [t1 ==> t1'].  We know [|- t1 \in Bool] so,
             by the IH, [|- t1' \in Bool].  The [T_If] rule then gives us
             [|- if t1' then t2 else t3 \in T], as required.

      - (* FILL IN HERE *)
[] *)

(** **** Exercise: 3 stars (preservation_alternate_proof)  *)
(** Now prove the same property again by induction on the
    _evaluation_ derivation instead of on the typing derivation.
    Begin by carefully reading and thinking about the first few
    lines of the above proof to make sure you understand what
    each one is doing.  The set-up for this proof is similar, but
    not exactly the same. *)

Theorem preservation' : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.
(*Proof with eauto.*)
Proof.
  intros t t' T HT HE. generalize dependent T. induction HE; intros.
    + inversion HT; subst. assumption.
    + inversion HT; subst. assumption.
    + inversion HT; subst. apply T_If.
        - apply IHHE. assumption.
        - assumption.
        - assumption.
    + inversion HT; subst. apply T_Succ. apply IHHE.  assumption.
    + inversion HT; subst. assumption.
    + inversion HT; subst. inversion H; subst.
        - apply T_Zero.
        - apply succ_hastype_nat__hastype_nat. assumption.
    + inversion HT; subst. apply T_Pred. apply IHHE. assumption.
    + inversion HT; subst. apply T_True.
    + inversion HT; subst. apply T_False.
    + inversion HT; subst. apply T_Iszero. apply IHHE in H0. assumption.
Qed.

(* ###################################################################### *)
(** ** Type Soundness *)

(** Putting progress and preservation together, we can see that a
    well-typed term can _never_ reach a stuck state.  *)

Definition multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Corollary soundness : forall t t' T,
  |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP.  apply (preservation x y T HT H).
  unfold stuck. split; auto.   Qed.

(* ###################################################################### *)
(** * Aside: the [normalize] Tactic *)

(** When experimenting with definitions of programming languages in
    Coq, we often want to see what a particular concrete term steps
    to -- i.e., we want to find proofs for goals of the form [t ==>*
    t'], where [t] is a completely concrete term and [t'] is unknown.
    These proofs are simple but repetitive to do by hand. Consider for
    example reducing an arithmetic expression using the small-step
    relation [astep]. *)

Notation " t '/' st '==>a*' t' " := (multi (astep st) t t')
                                    (at level 40, st at level 39).

Example astep_example1 :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  apply multi_step with (APlus (ANum 3) (ANum 12)).
    apply AS_Plus2.
      apply av_num.
      apply AS_Mult.
  apply multi_step with (ANum 15).
    apply AS_Plus.
  apply multi_refl.
Qed.

(** We repeatedly apply [multi_step] until we get to a normal
    form. The proofs for the intermediate steps are simple enough that
    [auto], with appropriate hints, can solve them. *)

Hint Constructors astep aval.
Example astep_example1' :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  eapply multi_step. auto. simpl.
  eapply multi_step. auto. simpl.
  apply multi_refl.
Qed.

(** The following custom [Tactic Notation] definition captures this
    pattern.  In addition, before each step, we print out the current
    goal, so that we can follow how the term is being evaluated. *)

Tactic Notation "print_goal" := match goal with |- ?x => idtac x end.
Tactic Notation "normalize" :=
   repeat (print_goal; eapply multi_step ;
             [ (eauto 10; fail) | (instantiate; simpl)]);
   apply multi_refl.

Example astep_example1'' :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  normalize.
  (* At this point in the proof script, the Coq response shows
     a trace of how the expression evaluated.

   (APlus (ANum 3) (AMult (ANum 3) (ANum 4)) / empty_state ==>a* ANum 15)
   (multi (astep empty_state) (APlus (ANum 3) (ANum 12)) (ANum 15))
   (multi (astep empty_state) (ANum 15) (ANum 15))
*)
Qed.

(** The [normalize] tactic also provides a simple way to calculate
    what the normal form of a term is, by proving a goal with an
    existential variable in it. *)

Print ex_intro.

Example astep_example1''' : exists e',
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* e'.
Proof.
  eapply ex_intro. normalize.

(* This time, the trace will be:

    (APlus (ANum 3) (AMult (ANum 3) (ANum 4)) / empty_state ==>a* ??)
    (multi (astep empty_state) (APlus (ANum 3) (ANum 12)) ??)
    (multi (astep empty_state) (ANum 15) ??)

   where ?? is the variable ``guessed'' by eapply.
*)
Qed.

(** **** Exercise: 1 star (normalize_ex)  *)
Theorem normalize_ex : exists e',
  (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) / empty_state
  ==>a* e'.
Proof.
  eapply ex_intro. normalize.
Qed.

(** [] *)

(** **** Exercise: 1 star, optional (normalize_ex')  *)
(** For comparison, prove it using [apply] instead of [eapply]. *)

Theorem normalize_ex' : exists e',
  (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) / empty_state
  ==>a* e'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** ** Additional Exercises *)

(** **** Exercise: 2 stars, recommended (subject_expansion)  *)
(** Having seen the subject reduction property, it is reasonable to
    wonder whether the opposity property -- subject _expansion_ --
    also holds.  That is, is it always the case that, if [t ==> t']
    and [|- t' \in T], then [|- t \in T]?  If so, prove it.  If
    not, give a counter-example.  (You do not need to prove your
    counter-example in Coq, but feel free to do so if you like.)

    Solution:

    false. Since:

        t1 = [if true then 1 else false]

     steps to

        t1' = [1]

     which is in Nat and is well typed, but t1 is not well typed.

[] *)

(* todo: check these. *)

(*

Theorem preservation : ∀t t' T,
  ⊢ t ∈ T →
  t ⇒ t' →
  ⊢ t' ∈ T.

Theorem progress : ∀t T,
  ⊢ t ∈ T →
  value t ∨ ∃t', t ⇒ t'.

*)

(** **** Exercise: 2 stars (variation1)  *)
(** Suppose, that we add this new rule to the typing relation:
      | T_SuccBool : forall t,
           |- t \in TBool ->
           |- tsucc t \in TBool
   Which of the following properties remain true in the presence of
   this rule?  For each one, write either "remains true" or
   else "becomes false." If a property becomes false, give a
   counterexample.
      - Determinism of [step]
                remains true.

      - Progress
               no. [t = tsucc false].
        by definition of [=>] t cannot step to another value.
        by by def of [value] t is not a value.

      - Preservation
               not true. ie  [t = tsucc ttrue].

[] *)

(** **** Exercise: 2 stars (variation2)  *)
(** Suppose, instead, that we add this new rule to the [step] relation:
      | ST_Funny1 : forall t2 t3,
           (tif ttrue t2 t3) ==> t3
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

      - Determinism of [step]
           No longer true. since (tif true t2 t3) can step to
           t3 by [ST_Funny1] and step to [t2] by [ST_IfTrue].

      - Progress
           remains true.

      - Preservation
           remains true.

[] *)

(** **** Exercise: 2 stars, optional (variation3)  *)
(** Suppose instead that we add this rule:
      | ST_Funny2 : forall t1 t2 t2' t3,
           t2 ==> t2' ->
           (tif t1 t2 t3) ==> (tif t1 t2' t3)
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[] *)

(** **** Exercise: 2 stars, optional (variation4)  *)
(** Suppose instead that we add this rule:
      | ST_Funny3 :
          (tpred tfalse) ==> (tpred (tpred tfalse))
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[] *)

(** **** Exercise: 2 stars, optional (variation5)  *)
(** Suppose instead that we add this rule:

      | T_Funny4 :
            |- tzero \in TBool
   ]]
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[] *)

(** **** Exercise: 2 stars, optional (variation6)  *)
(** Suppose instead that we add this rule:

      | T_Funny5 :
            |- tpred tzero \in TBool
   ]]
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[] *)

(** **** Exercise: 3 stars, optional (more_variations)  *)
(** Make up some exercises of your own along the same lines as
    the ones above.  Try to find ways of selectively breaking
    properties -- i.e., ways of changing the definitions that
    break just one of the properties and leave the others alone.
[] *)

(** **** Exercise: 1 star (remove_predzero)  *)
(** The evaluation rule [E_PredZero] is a bit counter-intuitive: we
    might feel that it makes more sense for the predecessor of zero to
    be undefined, rather than being defined to be zero.  Can we
    achieve this simply by removing the rule from the definition of
    [step]?  Would doing so create any problems elsewhere?

     No. Now given term [pred 0] we would not be able to
     step it into any other value under (=>), so it is a normal form.
     however it is not a value by definition of [nvalue]. Thus
     we have a term [pred 0] that is well typed but is also stuck.

[] *)

(** **** Exercise: 4 stars, advanced (prog_pres_bigstep)  *)
(** Suppose our evaluation relation is defined in the big-step style.
    What are the appropriate analogs of the progress and preservation
    properties?  (You do not need to prove them.)

(* FILL IN HERE *)
[] *)

(** $Date: 2016-03-07 17:05:52 -0500 (Mon, 07 Mar 2016) $ *)


Require Export Basics.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1 : forall b c : bool,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true". (* <----- here *)
    reflexivity.
  Case "b = false". (* <---- and here *)
    rewrite <- H.
    reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros.
  destruct c.
  Case "c = true".
    reflexivity.
  Case "c = false".
    rewrite <- H.
    destruct b.
    SCase "true and false".
      reflexivity.
      reflexivity.
Qed.

Theorem plus_0_r : forall n:nat, n + 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. reflexivity. Qed.

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. reflexivity. Qed.

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  intros. induction n as [| n'].
  Case "n = 0". simpl. reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  intros. induction n as [| n'].
  Case "S (0 + m)". simpl. reflexivity.
  Case "S (S n' + m)". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros. induction n as [| n'].
  Case "n = 0". simpl. rewrite -> plus_0_r. reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. rewrite -> plus_n_Sm. reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros. induction n as [| n'].
  Case "n = 0". simpl. reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

(** Consider the following function, which doubles its argument:  *)

Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

(** Use induction to prove this simple fact about double:  *)

Lemma double_plus : forall n, double n = n + n .
Proof.
  intros. induction n as [| n'].
  Case "n = 0". simpl. reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. rewrite -> plus_n_Sm. reflexivity.
Qed.

(** Destruct works with only two options, like boolean true/false.
    With induction you can choose which option to pick.  *)

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n).
    Case "Proof of assertion". reflexivity.
  rewrite -> H.
  reflexivity. Qed.

Theorem plus_rearrange_firsttry : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  (* We just need to swap (n + m) for (m + n)...
     it seems like plus_comm should do the trick! *)
  rewrite -> plus_comm.
  (* Doesn't work...Coq rewrote the wrong plus! *)
Abort.

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
    Case "Proof of assertion".
    rewrite -> plus_comm. reflexivity.
  rewrite -> H. reflexivity. Qed.

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros.
  rewrite -> plus_assoc.
  assert (H: n + m = m + n).
  Case "Proof of assertion". rewrite -> plus_comm. reflexivity.
  rewrite -> H. rewrite -> plus_assoc. reflexivity.
Qed.

Lemma mult_thing : forall m n : nat,
  n * S m = n + n * m.
Proof.
  intros. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. rewrite -> plus_swap. reflexivity.
Qed.

Theorem mult_comm : forall m n : nat,
 m * n = n * m.
Proof.
  intros. induction m as [| m'].
  Case "m = 0". simpl. rewrite -> mult_0_r. reflexivity.
  Case "m = S m'". simpl. rewrite -> IHm'. rewrite -> mult_thing. reflexivity.
Qed.


Fixpoint eqb (x y:nat) : bool :=
  match x with
  | 0 => match y with
         | 0 => true
         | S y' => false
         end
  | S x' => match y with
            | 0 => false
            | S y' => (eqb x' y')
            end
  end.
Notation " x =? y" := (eqb x y) (at level 70) : nat_scope.

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

(*
One good way to think about it is that list is a function
from Types to Inductive definitions; or, to put it another
way, list is a function from Types to Types.
For any particular type X, the type list X is an Inductively
defined set of lists whose elements are of type X.
*)

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.
Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.
Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.
Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.
Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.
Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros X l.
  induction l as [|n l' IHl'].
  - reflexivity.
  - simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n. induction l as [| t l' IHl'].
  -reflexivity.
  - simpl. rewrite -> IHl'. reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2. induction l1 as [| n l1' IHl1'].
  -reflexivity.
  -simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2. induction l1 as [| n l' IHl'].
  - rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IHl'.
    simpl. rewrite -> app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. rewrite -> rev_app_distr.
    simpl. rewrite -> IHl'. reflexivity.
Qed.

(* Polymorphic Pairs *)

Inductive prod (X Y : Type) : Type :=
  | pair (x : X) (y : Y).

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
  : list (X * Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x,y) :: (combine tx ty)
  end.

Fixpoint split {X Y : Type} (l : list (X*Y))
  : (list X)*(list Y) :=
  match l with
  | [] => ([], [])
  | (x,y) :: l' => ( x::fst(split l'), y::snd(split l') )
  end.

Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.

Arguments Some {X} _.

Arguments None {X}.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if n =? O then Some a else nth_error l' (pred n)
  end.
Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | a :: _ => Some a
  end.

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O        => true
  | S O      => false
  | S (S n') => evenb n'
  end.

Fixpoint oddb (n:nat) : bool :=
  match n with
  | O        => false
  | S O      => true
  | S (S n') => oddb n'
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Notation " x && y " := (andb x y).

Fixpoint gt (x:nat) (y:nat) : bool :=
  match x with
  | 0 => false
  | S x' => match y with
            | 0 => true
            | S y' => (gt x' y')
            end
  end.

Fixpoint filter {X:Type} (test : X->bool) (l:list X) :
  (list X) :=
  match l with
  | [] => []
  | h :: t => if test h then h :: (filter test t)
                        else filter test t
  end.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun x => (evenb x) && (gt x 7)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.
Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

Fixpoint partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                    : list X * list X :=
  match l with
  | [] => ([], [])
  | h :: t => if test h then (h :: fst(partition test t), snd(partition test t))
                        else (fst(partition test t), h :: snd(partition test t))
  end.

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y: Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

Lemma map_help : forall(X Y : Type) (f : X -> Y) (l : list X) (x : X),
  map f (l ++ [x]) = (map f l) ++ [f x].
Proof.
  intros X Y f l x. induction l as [| n l'].
  - reflexivity.
  - simpl.  rewrite -> IHl'. reflexivity.
Qed.

Theorem map_rev : forall(X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. rewrite -> map_help.
    simpl. rewrite -> IHl'. reflexivity.
Qed.

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) ++ (flat_map f t)
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

Fixpoint fold {X Y: Type} (f: X->Y->Y) (l: list X) (init: Y)
                         : Y :=
  match l with
  | nil => init
  | h :: t => f h (fold f t init)
  end.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
intros X l. induction l as [| n l' IHl'].
-reflexivity.
-simpl. rewrite <- IHl'. reflexivity.
Qed.

Fixpoint fold_map {X Y: Type} (f: X->Y) (l: list X)
                         : list Y :=
  match l with
  | nil => []
  | h :: t => (f h) :: (fold_map f t)
  end.

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z :=
  f (fst p) (snd p).

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
intros X Y Z f.
reflexivity.
Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
intros X Y Z f p. destruct p as [p1 p2].
reflexivity.
Qed.

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Definition cnat := forall X : Type, (X -> X) -> X -> X.

Definition one : cnat :=
  fun (X : Type) (f : X->X) (x : X) => f x.

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition three : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f (f x)).

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

Definition succ (n : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (n X f x).

Example succ_1 : succ zero = one.
Proof.
reflexivity.
Qed.

Example succ_2 : succ one = two.
Proof. reflexivity. Qed.

Example succ_3 : succ two = three.
Proof. reflexivity. Qed.

Definition plus (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => m X f (n X f x).

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.

Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

Definition mult (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => (m X (n X f) x).

Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.

Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.

Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

Definition exp (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => (m (X->X) (fun y => (fun z => (n X y z))) f) x.

Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.

Example exp_2 : exp three zero = one.
Proof. reflexivity. Qed.

Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.


Require Import BigO.Notation.
Require Import BigO.Util.DecField.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.orders.
Require Import MathClasses.interfaces.vectorspace.

(**
 Facts about the compositions of functions and how they interact with our
 notations.
 *)

Section Composition.
  Context `{@SemiNormedSpace
              K V
              Ke Kle Kzero Knegate Kabs Vnorm Ke Kplus Kmult Kzero Kone Knegate Krecip
              Ve Vop Vunit Vnegate smkv
           }.
  Context `{!FullPseudoSemiRingOrder Kle Klt}.
  Context `{forall x y : K, Decision (x = y)}.

  (**
   Trying to avoid "increasing" and "decreasing", which don't correspond to
   these definitions.
   *)
  Definition shrinks (f : V -> V) : Prop := ∀ x : V, ∥f x∥ ≤ ∥x∥.
  Definition grows (f : V -> V) : Prop := ∀ x : V, ∥x∥ ≤ ∥f x∥.
  Definition strictly_shrinks (f : V -> V) : Prop := ∀ x : V, ∥f x∥ < ∥x∥.
  Definition strictly_grows (f : V -> V) : Prop := ∀ x : V, ∥x∥ < ∥f x∥.

  (**
   Composition is compatible with Big O when the outer function is decreasing.
   *)
  Lemma big_O_comp_dec : ∀ f g h : (V → V),
      f ∈ O(h) -> g ∈ O(h) -> shrinks f -> f ∘ g ∈ O(h).
    intros f g h f_O_h g_O_h f_shrinks.

    destruct f_O_h as [k_f [zero_lt_k_f [n0_f [zero_lt_n0_f f_O_h]]]].
    destruct g_O_h as [k_g [zero_lt_k_g [n0_g [zero_lt_n0_g g_O_h]]]].
    unfold shrinks in f_shrinks.

    unfold big_O.
    unfold compose.
    exists k_g; split; try assumption.
    exists n0_g; split; try assumption.
    intros n n0_g_le_n.

    transitivity (∥ g n ∥).
     - now rewrite f_shrinks.
     - now apply g_O_h.
  Qed.

  (**
   Composition is compatible with Big Ω when the outer function is increasing.
   *)
  Lemma big_Omega_comp_inc : ∀ f g h : (V → V),
      f ∈ Ω(h) -> g ∈ Ω(h) -> grows f -> f ∘ g ∈ Ω(h).
    intros f g h f_Ω_h g_Ω_h f_grows.

    destruct f_Ω_h as [k_f [zero_lt_k_f [n0_f [zero_lt_n0_f f_Ω_h]]]].
    destruct g_Ω_h as [k_g [zero_lt_k_g [n0_g [zero_lt_n0_g g_Ω_h]]]].
    unfold grows in f_grows.

    unfold big_Omega.
    unfold compose.
    exists k_g; split; try assumption.
    exists n0_g; split; try assumption.
    intros n n0_g_le_n.

    transitivity (∥ g n ∥).
     - now apply g_Ω_h.
     - now rewrite f_grows.
  Qed.

  (**
   Composition is compatible with little O when the outer function is decreasing.
   *)
  Lemma little_o_comp_dec : ∀ f g h : (V → V),
      f ∈ o(h) -> g ∈ o(h) -> shrinks f -> f ∘ g ∈ o(h).
    intros f g h f_o_h g_o_h f_shrinks.

    unfold little_o.
    unfold compose.
    intros k zero_lt_k.

    destruct (f_o_h k) as [n0_f [zero_lt_n0_f f_o_h']]; try assumption.
    destruct (g_o_h k) as [n0_g [zero_lt_n0_g g_o_h']]; try assumption.
    unfold shrinks in f_shrinks.

    exists (n0_f + n0_g).
    split; try (now apply semirings.pos_plus_compat).
    intros n n_ge_n0.

    assert (n0_f ≤ ∥ n ∥) by (now apply (plus_le n0_f n0_g)).
    assert (n0_g ≤ ∥ n ∥).
    {
      apply (plus_le n0_g n0_f (∥ n ∥)); try assumption.
      now rewrite commutativity.
    }

    transitivity (∥ g n ∥).
     - now rewrite f_shrinks.
     - now apply g_o_h'.
  Qed.

  (**
   Composition is compatible with little ω when the outer function is
   increasing.
   *)
  Lemma little_omega_comp_inc : ∀ f g h : (V → V),
      f ∈ ω(h) -> g ∈ ω(h) -> grows f -> f ∘ g ∈ ω(h).
    intros f g h f_ω_h g_ω_h f_grows.

    unfold little_omega.
    unfold compose.
    intros k zero_lt_k.

    destruct (f_ω_h k) as [n0_f [zero_lt_n0_f f_ω_h']]; try assumption.
    destruct (g_ω_h k) as [n0_g [zero_lt_n0_g g_ω_h']]; try assumption.
    unfold grows in f_grows.

    exists (n0_f + n0_g).
    split; try (now apply semirings.pos_plus_compat).
    intros n n_ge_n0.

    assert (n0_f ≤ ∥ n ∥) by (now apply (plus_le n0_f n0_g)).
    assert (n0_g ≤ ∥ n ∥).
    {
      apply (plus_le n0_g n0_f (∥ n ∥)); try assumption.
      now rewrite commutativity.
    }

    transitivity (∥ g n ∥).
     - now apply g_ω_h'.
     - now rewrite f_grows.
  Qed.
End Composition.


Require Import TLC.LibLN.
Require Export Env.

Set Implicit Arguments.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Grammars *)

(* ********************************************************************** *)
(** ** Terms *)

(** Grammar of pre-terms. We use a locally nameless representation where bound variables
    are represented as natural numbers (de Bruijn indices) and free variables are
    represented as atoms. A variable can be bound by an abstraction or a let construction.
    The type [var], defined in the library LibLN_Var, represents 'names' or 'atoms'. One
    central assumption is that it is always possible to generate a fresh atom for any given
    finite set of atoms (lemma [var_fresh]).

    Traditionally, the syntax of simple refinement-types systems is defined in A-normal form.
    This is important when defining the application rule of the typing judgment as we have
    dependent types. Here we don't make a syntactic distinction between values and other
    terms, so the resulting grammar is not in A-normal form. Instead we define a proposition
    that holds for terms that are values and we add the necessary hypothesis when needed.
    For example, the typing judgment only holds for terms that are in A-normal form.
*)

Inductive trm : Set :=
  | trm_nat : nat -> trm
  | trm_true : trm
  | trm_false : trm
  | trm_if : trm -> trm -> trm -> trm
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs : var -> trm -> trm
  | trm_let : trm -> trm -> trm
  | trm_app : trm -> trm -> trm.

Implicit Types t s : trm.

(* ********************************************************************** *)
(** ** Types *)

(** *** Grammar of base types. *)
Inductive typ_base : Set := typ_bool | typ_nat.

(** *** Grammar of types *)
(** A refinement allows us to decorate base types with logical formulas. A refinement
    introduces a binder that can be mentioned in the formula to make constraints about it. As
    with terms, we also use a locally nameless representation to deal with bindings. Arrow
    types are dependent, so they also bind variables.
 *)

Inductive typ : Set :=
  | typ_refinement : typ_base -> formula -> typ
  | typ_arrow : typ -> typ -> typ

(** *** Grammar of formulas *)
(** Simple logical operators plus an equality predicate *)

with formula : Set :=
  | formula_or : formula -> formula -> formula
  | formula_and : formula -> formula -> formula
  | formula_not : formula -> formula
  | formula_true : formula
  | formula_eq : logic_val -> logic_val -> formula

(** *** Grammar of logical values *)
(** Note that the logic is syntactically separated from terms. We then define an operation
    that lifts values to introduce them into the logic. There is a corresponding logical value
    for every value in the language. The translation is straightforward except for lambdas,
    which need to be treated with care. As a simplification we treat lambdas as atomic and
    introduce them into the logic with the constructor [logical_abs_var]. *)

with logic_val : Set :=
  | logical_nat : nat -> logic_val
  | logical_true : logic_val
  | logical_false : logic_val
  | logical_bvar : nat -> logic_val
  | logical_fvar : var -> logic_val
  | logical_abs_var : var -> logic_val.

Implicit Types v u : logic_val.
Implicit Types p q : formula.
Implicit Types T S U : typ.

(** We don't need to make a mutually recursive definition, but we do it for convenience. In
    order to prove propositions about types we also need to prove similar propositions
    about formulas and logical values. If we define them mutually recursive we could make a
    combined mutual recursive principle and make proofs about the three at the same time.
    For consistency we follow the same approach for every definition involving types,
    formulas and logical values. *)

(* Notation for logical values *)
Bind Scope logical_scope with formula.
Delimit Scope logical_scope with logic.

(* Notation for formulas *)
Bind Scope logic_val_scope with logic_val.
Delimit Scope logic_val_scope with logic_val.
Notation " v1 = v2 " := (formula_eq v1 v2) : logical_scope.
Notation " v1 /\ v2 " := (formula_and v1 v2) : logical_scope.
Notation " v1 \/ v2 " := (formula_or v1 v2) : logical_scope.
Notation "~ v" := (formula_not v) : logical_scope.
(* Notation " v1 ==> v2 " := (formula_implies v1 v2) *)
(*                             (at level 90, right associativity): logical_scope. *)

(* Notation for types *)
Bind Scope typ_scope with typ.
Delimit Scope typ_scope with typ.
Notation "{ 'v' : B | p }" := (typ_refinement B p) (at level 0, B at level 0) : typ_scope.
Notation "T1 --> T2" := (typ_arrow T1 T2) (at level 0, T2 at level 0): typ_scope.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Opening *)

Reserved Notation "{ k ~> u } t" (at level 0, k at level 99, t at level 0).
Reserved Notation "t ^^ u" (at level 30).

(* ********************************************************************** *)
(** ** Terms *)
(** Opening replaces a bound variable with a term. We make several simplifying assumptions
    in defining [open_trm_rec]. First, we assume that the argument [s] is locally closed
    (it doesn't contain unbound de Bruijn indices). This assumption simplifies the
    implementation since we do not need to shift indices in [s] when passing under a binder.
    Second, we assume that this function is initially called with index zero and that zero
    is the only unbound index in the term. This eliminates the need to possibly subtract one
    in the case of indices. *)

Fixpoint open_trm_rec (k : nat) (s : trm) (t : trm) : trm :=
  match t with
  | trm_nat n => t
  | trm_true => t
  | trm_false => t
  | trm_if t1 t2 t3 => trm_if ({k ~> s} t1) ({k~>s} t2) ({k ~> s} t3)
  | trm_bvar i => If k = i then s else t
  | trm_fvar x => t
  | trm_abs lbl t1 => trm_abs lbl ({(S k) ~> s} t1)
  | trm_let t1 t2 => trm_let ({k ~> s} t1) ({(S k) ~> s} t2)
  | trm_app t1 t2 => trm_app ({k ~> s} t1) ({k ~> s} t2)
  end

where "{ k ~> s } t" := (open_trm_rec k s t) : trm_scope.

Definition open_trm t s := open_trm_rec 0 s t.

Notation "t ^^ s" := (open_trm t s) : trm_scope.
Notation "t ^ x" := (open_trm t (trm_fvar x)) : trm_scope.
Bind Scope trm_scope with trm.
Delimit Scope trm_scope with trm.

(* ********************************************************************** *)
(** ** Types *)
(** As we have dependent types and bindings for the refinements we need to open types and
    replace bound variables with logical values. In this case we also make the assumption
    that [u] is locally closed and 0 is the only unbound index .*)

Fixpoint open_typ_rec (k : nat) (u : logic_val) (T : typ) : typ :=
  match T with
  | {v :B | p} => typ_refinement B ({(S k) ~> u} p)
  | T1 --> T2 => ({k ~> u} T1) --> ({(S k) ~> u} T2)
  end
where "{ k ~> u } T" := (open_typ_rec k u T) : typ_scope

with open_formula_rec (k : nat) (u : logic_val) (p : formula) : formula :=
  match p with
  | p1 \/ p2 => ({k ~> u} p1) \/ ({k ~> u} p2)
  | p1 /\ p2 => ({k ~> u} p1) /\ ({k ~> u} p2)
  | ~p' => ~({k ~> u} p')
  | formula_true => formula_true
  | v1 = v2 => ({k ~> u} v1) = ({k ~> u} v2)
  end
where "{ k ~> u } p" := (open_formula_rec k u p) : logical_scope

with open_logic_val_rec
    (k : nat) (u : logic_val) (v : logic_val) : logic_val :=
  match v with
  | logical_bvar i => If k = i then u else v
  | _ => v
  end
where "{ k ~> u } v" := (open_logic_val_rec k u v) : logic_val_scope.

Definition open_typ (T : typ) (u : logic_val) := (open_typ_rec 0 u T).
Notation "T ^ x" := (open_typ T (logical_fvar x)) : typ_scope.
Notation "T ^^ u" := (open_typ T u) : typ_scope.

Definition open_formula p u:= open_formula_rec 0 u p.
Notation "p ^ x" := (open_formula p (logical_fvar x)) : logical_scope.
Notation "p ^^ u" := (open_formula p u) : logical_scope.

Definition open_logic_val v u:= open_logic_val_rec 0 u v.
Notation "v ^ x" := (open_logic_val v (logical_fvar x)) : logic_val_scope.
Notation "v ^^ u" := (open_logic_val v u) : logic_val_scope.

(** We need to lift each term value to a logical value. We assume that types are always
    opened with term values *)
Definition lift_value (u : trm) :=
  match u with
    | trm_nat n => logical_nat n
    | trm_true => logical_true
    | trm_false => logical_false
    | trm_fvar x => logical_fvar x
    | trm_abs lbl _ => logical_abs_var lbl
    | _ => logical_true
  end.
Notation "! u" := (lift_value u) (at level 61, right associativity).

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Local Closure *)

(** ** Terms *)

(** Recall that [trm] admits terms that contain unbound indices. We say that a term is locally
    closed, when no indices appearing in it are unbound. The proposition [term e] holds when
    an expression [e] is locally closed.

    Note the use of cofinite quantification in the [term_abs] and [term_let] case. The
    hypotheses in these cases say that the rules hold for all variables except for those in
    a finite set.
*)

Inductive term : trm -> Prop :=
  | term_nat : forall n,
     term (trm_nat n)

  | term_true :
      term trm_true

  | term_false :
     term trm_false

  | term_if : forall t1 t2 t3,
     term t1 ->
     term t2 ->
     term t3 ->
     term (trm_if t1 t2 t3)

  | term_fvar : forall x,
     term (trm_fvar x)

  | term_abs : forall L lbl t,
     (forall x, x \notin L -> term (t ^ x)) ->
     term (trm_abs lbl t)

  | term_let : forall L t1 t2,
     term t1 ->
     (forall x, x \notin L -> term (t2 ^ x)) ->
     term (trm_let t1 t2)

  | term_app : forall t1 t2,
     term t1 ->
     term t2 ->
     term (trm_app t1 t2).
Hint Constructors term.

(** ** Types *)

(** We have the same problem of unbound indices for [typ]. The proposition [type T] holds
    when [T] is locally closed *)

Inductive type : typ -> Prop :=
  | type_refinement : forall L B p,
      (forall x, x \notin L ->
        closed_formula (p ^ x)) ->
      type {v: B | p}

  | type_arrow : forall L T1 T2,
      type T1 ->
      (forall x, x \notin L ->
        type (T2 ^ x)) ->
      type (T1 --> T2)

with closed_formula : formula -> Prop :=
  | closed_formula_or : forall p1 p2,
      closed_formula p1 ->
      closed_formula p2 ->
      closed_formula (p1 \/ p2)

  | closed_formula_and : forall p1 p2,
      closed_formula p1 ->
      closed_formula p2 ->
      closed_formula (p1 /\ p2)

  | closed_formula_not : forall p,
      closed_formula p ->
      closed_formula (~p)

  | closed_formula_true :
      closed_formula formula_true

  | closed_formula_eq : forall v1 v2,
      closed_logic_val v1 ->
      closed_logic_val v2 ->
      closed_formula (v1 = v2)

with closed_logic_val : logic_val -> Prop :=
  | closed_logical_nat : forall n,
      closed_logic_val (logical_nat n)

  | closed_logical_true:
      closed_logic_val logical_true

  | closed_logical_false :
      closed_logic_val logical_false

  | closed_logical_fvar : forall x,
      closed_logic_val (logical_fvar x)

  | closed_logical_fun_var : forall lbl,
      closed_logic_val (logical_abs_var lbl).

Hint Constructors closed_logic_val closed_formula.

(** * Typing *)

(* ********************************************************************** *)
(** ** Values *)

(** The proposition [value e] holds when an expression [e] is a value. Note that the
    hypothesis in the lambda case ensures that this proposition is only defined for locally
    closed terms *)
Inductive value : trm -> Prop :=
  | value_fvar : forall x,
      value (trm_fvar x)

  | value_nat : forall n,
      value (trm_nat n)

  | value_true :
      value trm_true

  | value_false :
      value trm_false

  | value_abs : forall lbl t,
      term (trm_abs lbl t) ->
      value (trm_abs lbl t).
Hint Constructors value.

(** As we have have dependent functions we must introduce terms into types in the application
    rule of the typing judgment. One restriction is that we only allow values to appear as
    arguments of an application so we don't introduce arbitrary expressions into types. We
    must also be careful in the way we introduce lambdas an treat them independently.
    The proposition [atom e] holds for values that are not lambdas *)
Inductive atom : trm -> Prop :=
  | atom_fvar : forall x,
      atom (trm_fvar x)

  | atom_nat : forall n,
      atom (trm_nat n)

  | atom_true :
      atom trm_true

  | atom_false :
      atom trm_false.
Hint Constructors atom.

(** ** Free variables *)

(** The function [trm_fv], defined below, calculates the set of free variables in an
    expression. Because we are using locally nameless representation, where bound variables
    are represented as indices, any name we see is a free variable of a term.
    In particular, this makes the [trm_abs] case simple. *)

Fixpoint trm_fv (t : trm) {struct t} : vars :=
  match t with
  | trm_nat n => \{}
  | trm_true => \{}
  | trm_false => \{}
  | trm_if t1 t2 t3 => (trm_fv t1) \u (trm_fv t2) \u (trm_fv t3)
  | trm_bvar i => \{}
  | trm_fvar x => \{x}
  | trm_abs lbl t1 => trm_fv t1
  | trm_let t1 t2 => (trm_fv t1) \u (trm_fv t2)
  | trm_app t1 t2 => (trm_fv t1) \u (trm_fv t2)
  end.

(** We also define the function [typ_fv] to compute the set of free variables in a type *)

Fixpoint typ_fv (T : typ) : vars :=
  match T with
  | {v : B | p} => formula_fv p
  | T1 --> T2 => typ_fv T1 \u typ_fv T2
  end%typ

with formula_fv (p : formula) : vars :=
  match p with
  | p1 \/ p2 => formula_fv p1 \u formula_fv p2
  | p1 /\ p2 => formula_fv p1 \u formula_fv p2
  | ~p' => formula_fv p'
  | formula_true => \{}
  | v1 = v2 => (logic_val_fv v1) \u (logic_val_fv v2)
  end%logic

with logic_val_fv (v : logic_val) : vars :=
  match v with
  | logical_fvar x => \{x}
  | _ => \{}
  end.

(** ** Environements *)

Definition ctx := env typ formula.
Implicit Types E F : ctx.
Bind Scope env_scope with ctx.
Arguments binds typ%type formula%type x T%typ E%env.

(** ** Substitution *)

(** Substitution replaces a free variable with a term. We don't need substitution to define
    the semantic of the language, because the notion of opening a type is sufficient and we
    use substitution only to make some proofs. We introduce the definition here because we
    need it to state some axioms imposed to the logic. *)

(** The definition below is simple for
    two reasons:
      - Because bound variables are represented using indices, there
        is no need to worry about variable capture.
      - We assume that the term being substituted in is locally
        closed. Thus, there is no need to shift indices when
        passing under a binder.
*)
Reserved Notation "[ x ~> u ] t" (at level 0, x at level 99, t at level 0).

Fixpoint trm_subst (x : var) (s : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_nat n => trm_nat n
  | trm_true => trm_true
  | trm_false => trm_false
  | trm_if t1 t2 t3 => trm_if ([x ~> s] t1) ([x~>s] t2) ([x ~> s] t3)
  | trm_bvar i => trm_bvar i
  | trm_fvar x' => If x' = x then s else (trm_fvar x')
  | trm_abs lbl t1 => trm_abs lbl ([x ~> s] t1)
  | trm_let t1 t2 => trm_let ([x ~> s] t1) ([x ~> s] t2)
  | trm_app t1 t2 => trm_app ([x ~> s] t1) ([x ~> s] t2)
  end
where "[ x ~> s ] t" := (trm_subst x s t) : trm_scope.

(** We also define substitution of free variables by logical values *)
Fixpoint typ_subst (x : var) (v : logic_val) (T : typ) : typ:=
  match T with
  | {v : B | p} => {v : B | [x ~> v] p}%logic
  | T1 --> T2 => ([x ~> v] T1) --> ([x ~> v] T2)
  end
where "[ x ~> v ] T" := (typ_subst x v T) : typ_scope

with formula_subst (x : var) (v : logic_val) (p : formula) : formula :=
  match p with
  | p1 \/ p2 => ([x ~> v] p1) \/ ([x ~> v] p2)
  | p1 /\ p2 => ([x ~> v] p1) /\ ([x ~> v] p2)
  | ~p' => ~([x ~> v] p')
  | formula_true => formula_true
  | v1 = v2 => ([x ~> v] v1 = [x ~> v] v2)%logic_val
  end
where "[ x ~> v ] p" := (formula_subst x v p) : logical_scope

with logic_val_subst
         (x : var) (v : logic_val) (u : logic_val) :=
  match u with
  | logical_fvar x' => If x' = x then v else logical_fvar x'
  | _ => u
  end
where "[ x ~> v ] u" := (logic_val_subst x v u) : logic_val_scope.

(** We also extend the definition to type environements *)
Fixpoint env_subst (x : var) (v : logic_val) (E : ctx) : ctx :=
  match E with
  | empty_env => empty_env
  | E' « y : T => ([x ~> v] E')%env « y : ([x ~> v] T)%typ
  | E' « p => ([x ~> v] E')%env « ([x ~> v] p)%logic
  end
where "[ x ~> v ] E" := (env_subst x v E) : env_scope.

(** ** Well-formedness *)

(** A type environment is well-formed if all variables are defined before use and no duplications
    exist *)
Reserved Notation "  |~ T" (at level 69, T at level 0).
Inductive env_wf : ctx -> Prop :=
| empty_env_wf : env_wf empty_env
| binding_env_wf : forall E x T,
    |~ E ->
    x \notin dom E ->
    typ_fv T \c dom E ->
    type T ->
    env_wf (E« x : T)
| formula_env_wf : forall E p,
    |~ E ->
    formula_fv p \c dom E ->
    closed_formula p ->
    env_wf (E«p)
where "|~ E" := (env_wf E).
Hint Constructors env_wf.

(** A type [T] is well-formed in an environment [E] ([E |~ T]) if all its free variables are
    defined in [E] and [E] itself is well-formed *)
Definition type_wf E T := type T /\ env_wf E /\ (typ_fv T \c dom E).
Notation "E |~ T" := (type_wf E T) (at level 69, T at level 0).

(** ** Subtyping *)

(* Fixpoint Embed (E : env) : formula := *)
(*   match E with *)
(*   | empty_env => formula_true *)
(*   | E'« x:{v: B | p} => Embed E' /\ (p ^ x) *)
(*   | E'« x:_ => Embed E' *)
(*   | E'« p => Embed E' /\ p *)
(*   end%logic. *)

Fixpoint extract (E : ctx) : fset formula :=
  match E with
  | empty_env => \{}
  | E'« x:{v: B | p}%typ => extract E' \u \{(p ^ x)}%logic
  | E'« x:_ => extract E'
  | E'« p => extract E' \u \{p}
  end.

(** The definition of subtyping appeals to the notion of logical consequence or entailment in
    the logic. We assume a judgment [entails E p] which means that the environment [E]
    entails the formula [p] or more precisely that the set of formulas extracted from the
    environment [E] entails the formula [p]. In the context of refinement types we assume
    that this judgment is decidable and typically associated with a call to an SMT solver.

    Other definitions appeal to the notion of validity which is in most senses equivalent
    to the notion of entailment. However, using entailment to define subtyping allows us to
    state the axioms required for the logic in a clean way. We define the notion of validity
    using entailment. *)

Parameter entails : forall (E : fset formula) (p : formula), Prop.
Notation "E |= p" := (entails E p) (at level 69, p at level 0).
Notation "E ||= p" := (entails (extract E) p) (at level 69, p at level 0).
Definition valid p := \{} |= p.

(** The arrow case of the subtyping relation is the typical syntactic one. The refinement
    case is more interesting and crucial for the expressiveness of the system. Intuitively
    a refinement with a formula [p] is a subtype of a refinement with a formula [q], if [q]
    is a logical consequence of [p] in the environment [E]. *)

Reserved Notation "E |~ T1 <: T2" (at level 69, T1 at level 0, T2 at level 0).
Inductive subtype : ctx -> typ -> typ -> Prop :=
  | subtype_refinement : forall L E B p q,
      E |~ {v: B | p} ->
      E |~ {v: B | q} ->
      (forall x, x \notin L ->
        extract (E « (p^x)%logic) |= (q ^ x))%logic ->
      E |~ {v : B | p} <: {v : B | q}

  | subtype_arrow : forall L E T11 T12 T21 T22,
      E |~ T21 <: T11 ->
      (forall x, x \notin L ->
          E « x: T21 |~ (T12 ^ x) <: (T22 ^ x) ) ->
      E |~ (T11 --> T12) <: (T21 --> T22)
where "E |~ T1 <: T2" := (subtype E T1 T2).

(** ** Typing judgment *)

(** The typing judgment has some interesting details.
    - The rules for constant and variables bound to refinements give exact types.
    - The rule for the if expression allows path sensitive reasoning, typing the then
      and else expressions in an environment extended with the appropriate assumption.
    - The application rule introduces the argument into the resulting type.
    - In the if and application rule the hypotheses ensure that we only introduce values into
      the logic.
    - Note again the use of cofinite quantification in the rules that must open terms with
      fresh variables.
*)

Reserved Notation "E |~ t : T" (at level 69, t at level 0, T at level 0) .
Inductive typing : ctx -> trm -> typ -> Prop :=
  | typing_nat : forall E n,
    |~ E ->
    E |~ (trm_nat n) : {v : typ_nat | (logical_bvar 0) = logical_nat n}%logic

  | typing_true : forall E,
      |~ E ->
      E |~ trm_true : {v : typ_bool | (logical_bvar 0) = logical_true}%logic

  | typing_false : forall E,
      |~ E ->
      E |~ trm_false : {v : typ_bool | (logical_bvar 0) = logical_false}%logic

  | typing_var_refinement : forall p E x B,
      |~ E ->
      binds x {v: B | p} E ->
      E |~ (trm_fvar x) : {v : B | (logical_bvar 0) = (logical_fvar x)}%logic

  | typing_var_arrow : forall E x T1 T2,
      |~ E ->
      binds x (T1 --> T2) E ->
      E |~ (T1 --> T2) ->
      E |~ (trm_fvar x) : (T1 --> T2)

  | typing_abs : forall L E T1 T2 lbl t,
      E |~ T1 ->
      (forall x, x \notin L ->
         (E« x:T1) |~ (t ^ x) : (T2^x)) ->
      E |~ (trm_abs lbl t) : (T1 --> T2)

  | typing_if : forall E p b t1 t2 T,
      value b ->
      E |~ b : {v : typ_bool | p} ->
      E « (!b = logical_true)%logic |~ t1 : T ->
      E « (!b = logical_false)%logic |~ t2 : T ->
      E |~ (trm_if b t1 t2) : T

  | typing_app : forall E T11 T12 t1 t2,
      value t1 ->
      value t2 ->
      E |~ t1 : (T11 --> T12) ->
      E |~ t2 : T11 ->
      E |~ (trm_app t1 t2) : (T12 ^^ (!t2))

  | typing_let : forall L E t1 t2 T1 T2,
      E |~ t1 : T1 ->
      (forall x, x \notin L ->
        (E « x:T1) |~ (t2 ^ x) : T2) ->
      E |~ T2 ->
      E |~ (trm_let t1 t2) : T2

  | typing_sub : forall E t T T',
      E |~ t : T ->
      E |~ T <: T' ->
      E |~ t : T'

where "E |~ t : T" := (typing E t T).
Hint Constructors typing.

(** * Axioms about the logic *)

(** In order to prove properties about subtyping a corresponding property must hold for the
    logic. Here we state all the axioms that we require for the language to be sound. The
    statements are defined so they match the statements of the properties about subtyping. *)

Definition subst_set (x : var) (v : logic_val) (E : fset formula) (F: fset formula) :
  Prop := (forall p, p \in E -> ([x ~> v] p)%logic \in F) /\
       (forall q, q \in F -> exists p, p \in E /\ ([x ~> v] p)%logic = q).

Axiom valid_eq : forall {v}, valid (v = v).
Axiom entails_assumption : forall A p, A \u \{p} |= p.
Axiom entails_monotone : forall {A p} B,
    A |= p ->
    A \u B |= p.
Axiom entails_cut : forall {A} p q,
    A |= p ->
    A \u \{p} |= q -> A |= q.
Axiom entails_subst : forall {A q} x v B,
    A |= q ->
    subst_set x v A B ->
    B |= [x ~> v] q.

(* ********************************************************************** *)
(** * Semantics *)

(** We now define the semantics of our call-by-value lambda calculus.
    We define values and the small-step reduction relation. Note the hypotheses
    which ensure that relations hold only for locally closed terms. *)

Reserved Notation "t ---> t'" (at level 68).

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall lbl t1 t2 ,
      term (trm_abs lbl t1) ->
      value t2 ->
      (trm_app (trm_abs lbl t1) t2) ---> (t1 ^^ t2)

  | red_let : forall t1  t2,
      value t1 ->
      term (trm_let t1 t2) ->
      (trm_let t1 t2) ---> (t2 ^^ t1)

  | red_if_true : forall t1 t2,
      term t1 ->
      term t2 ->
      (trm_if trm_true t1 t2) ---> t1

  | red_if_false : forall t1 t2,
      term t1 ->
      term t2 ->
      (trm_if trm_false t1 t2) ---> t2

  | red_let_compat : forall t1 t1' t2,
      term (trm_let t1 t2) ->
      t1 ---> t1' ->
      (trm_let t1 t2) ---> (trm_let t1' t2)

where "t ---> t'" := (red t t').

(** * Goals *)

Definition preservation := forall t s T,
    empty_env |~ t : T ->
    t ---> s ->
    empty_env |~ s : T.

Definition progress := forall t T,
    empty_env |~ t : T ->
    (value t \/ exists s, t ---> s).

Definition refinement_soundness := forall t B p E,
    value t ->
    E |~ t : { v : B | p} ->
    E ||= (p ^^ (! t)).


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d:day) : day :=
  match d with
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => monday
  | saturday  => monday
  | sunday    => monday
  end.

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof.
  simpl.
  reflexivity.
  (* refine (eq_refl). *)
Qed.