Require Export SfLib.
Require Export HelperFunctions.
Require Export SplitCutList.
Require Export InductiveDataTypes.

(* Helper functions to retrieve the leftmost key *)
Fixpoint leftmost_key {X: Type} {b: nat} (tree: bplustree b X) : nat :=
  match tree with
  | bptLeaf (x :: _) => fst x
  | bptNode (_ :: x :: _) => fst x
  | _ => 0
  end.

Fixpoint leftmost_key_deep {X: Type} {b: nat} (tree: bplustree b X) : nat :=
  match tree with
  | bptLeaf (x :: _) => fst x
  | bptNode (x :: _) => leftmost_key_deep (snd x)
  | _ => 0
  end.

Fixpoint keys' {X: Type} (l: list (nat * X)) : list nat :=
  match l with
  | [] => []
  | (k, _)::l' => k::(keys' l')
  end.

Definition keys {X: Type} {b: nat} (tree: bplustree b X): list nat :=
  match tree with
  | bptLeaf kvl => keys' kvl
  | bptNode kpl => keys' kpl
  end.

Definition left := bptLeaf 1 nat [(5, 55)].
Definition centre := bptLeaf 1 nat [(7, 77)].
Definition right := bptLeaf 1 nat [(9, 99)].
Definition root := bptNode 1 nat [(0, left), (leftmost_key centre, centre), (leftmost_key right, right)].

(* Height *)
Fixpoint height {X: Type} {b: nat} (tree: bplustree b X) : nat :=
  match tree with
    | bptLeaf _ => 0
    | bptNode [] => 0
    | bptNode ((_, subtree)::_) => S (height (subtree))
  end.

Example height_1 : height root = 1.
Proof. simpl. reflexivity. Qed.
Example height_2 : height (bptNode 1 nat [(1, bptNode 1 nat [(0, bptLeaf 1 nat [(2, 102)])])]) = 2.
Proof. simpl. reflexivity. Qed.
Example height_3 : height
(bptNode 1 nat [(1, bptNode 1 nat
               [(0, bptNode 1 nat
               [(3, bptNode 1 nat
               [(1, bptLeaf 1 nat [(2, 102)])])])])]) = 4.
Proof. simpl. reflexivity. Qed.

(* Search *)
Fixpoint search_leaf {X: Type} (sk: nat) (kvl: (list (nat * X))) : option X :=
  match kvl with
    | nil => None
    | (k, v) :: kvl' => if beq_nat k sk then Some v else search_leaf sk kvl'
  end.

Fixpoint find_subtree {X: Type} {b: nat} (sk: nat) (kpl: list (nat * bplustree b X)) : option (nat * bplustree b X) :=
  match kpl with
    | [] => None
    | (k, last_tree) :: [] => if ble_nat k sk then Some (k, last_tree) else None
    | (k1, subtree) :: ((k2, _) :: _) as kpl' => if ble_nat k1 sk && blt_nat sk k2
                                                   then Some (k1, subtree)
                                                   else find_subtree sk kpl'
  end.

Fixpoint search' {X: Type} {b: nat} (counter sk: nat) (tree: bplustree b X) {struct counter}: option X :=
  match (counter, tree) with
    | (_, bptLeaf kvl) => search_leaf sk kvl
    | (0, _) => None
    | (S counter', bptNode kpl) => match find_subtree sk kpl with
      | Some (_, subtree) => search' counter' sk subtree
      | None => None
    end
  end.

Definition search {X: Type} {b: nat} (sk: nat) (tree: bplustree b X) : option X :=
  search' (height tree) sk tree.

Example search_test_find_item_left : search 4 root = None.
Proof. simpl. reflexivity. Qed.
Example search_test_find_item_centre : search 7 root = Some 77.
Proof. simpl. reflexivity. Qed.
Example search_test_find_item_right : search 9 root = Some 99.
Proof. unfold root. unfold leftmost_key. simpl. reflexivity. Qed.
Example search_test_cant_find_missing : search 6 root = None.
Proof. simpl. reflexivity. Qed.

Fixpoint inorder {X: Type} {b: nat} (tree: (bplustree b X)) : list (nat * X) :=
  let fix node_members (kpl: (list (nat * bplustree b X))) : list (nat * X) :=
    match kpl with
      | nil => []
      | (k, p) :: kpl' => (inorder p) ++ (node_members kpl')
    end
  in
  match tree with
    | bptLeaf kpl => kpl
    | bptNode kpl => (node_members kpl)
  end.

Example all_members_left : inorder left = [(5, 55)].
Proof. simpl. reflexivity. Qed.
Example all_members_root : inorder root = [(5, 55), (7, 77), (9, 99)].
Proof. simpl. reflexivity. Qed.

(* Insertion *)
(* Leafs *)
Fixpoint insert_into_list {X: Type} (k: nat) (v: X) (kvl: list (nat * X)) : list (nat * X) :=
  match kvl with
    | nil => [(k, v)]
    | (k', v') :: kvl' => if ble_nat k k'
    					  then
    						if beq_nat k k'
    						then ((k, v) :: kvl')
    						else ((k, v) :: kvl)
    					  else (k', v') :: (insert_into_list k v kvl')
  end.

Definition insert_leaf {X: Type} (b: nat) (k: nat) (v: X) (kvl: list (nat * X))
						: (list (nat * X) * option (list (nat * X))) :=
  let kvl' := insert_into_list k v kvl
  in
    if ble_nat (length kvl') (b * 2)
      then (kvl', None)
      else let (fst, snd) := split_list b kvl' in (fst, Some snd)
  .

(* Nodes *)
Definition split_if_necessary {X: Type} {b: nat} (tree: (bplustree b X))
  							: (bplustree b X * option (nat * bplustree b X)) :=
  match tree with
  	| bptLeaf kvl => (tree, None)
  	| bptNode kpl =>
  	  if ble_nat (length kpl) ((b * 2) + 1)
        then (tree, None)
        else match (split_list (b + 1) kpl) with
          | (fst, []) => (bptNode b X fst, None)
          | (fst, (lmk,lmt)::snd') =>
            (bptNode b X fst, Some (lmk, bptNode b X ((0, lmt)::snd')))
        end
          (*

          let (fst, snd) := split_list (b + 1) kpl in
          let new_node := bptNode b X snd in
          (bptNode b X fst, Some (leftmost_key_deep new_node, new_node))
          *)
  end.

Definition insert_node {X: Type} {b: nat} (insertion_key: nat) (old_tree: (bplustree b X))
                       (input: (bplustree b X * option (nat * bplustree b X)))
  					   : (bplustree b X * option (nat * bplustree b X)) :=
  match old_tree with
  	| bptLeaf kvl => input
  	| bptNode kpl =>
  	  match input with
        | (t, None) => (bptNode b X (insert_into_list insertion_key t kpl), None)
              (* No overflow, just replace the pointer with key = insertion_key *)
  		| (t, Some (new_key, new_tree)) => split_if_necessary (
  		                                     bptNode b X (
  		                                       insert_into_list insertion_key t (
  		                                         insert_into_list new_key new_tree kpl)))
  		      (* Overflowed, so replace the tree with key = insertion_key, and
  		       * add the overflow new_tree too. In case this node then overflows,
  		       * we split_if_necessary, that will split if it overflows *)
  	  end
  end.

Fixpoint insert' {X: Type} {b: nat} (counter k: nat) (v: X) (tree: (bplustree b X))
                : (bplustree b X * option (nat * bplustree b X)) :=
  match (tree, counter) with
    | (bptLeaf kvl, _) => let (fst, snd_opt) := insert_leaf b k v kvl in
                     match snd_opt with
                     | None => (bptLeaf b X fst, None)
                     | Some snd =>
                         match key_at_index 0 snd with
                         | None => (bptLeaf b X fst, None)
                         | Some first_key => (bptLeaf b X fst, Some (first_key, bptLeaf b X snd))
                         end
                     end
    | (_, 0) => (tree, None)
    | (bptNode kpl, S counter') => match find_subtree k kpl with
      | None => (tree, None)
      | Some (key, subtree) => insert_node key tree (insert' counter' k v subtree)
    end
  end.

Definition insert {X: Type} {b: nat} (k: nat) (v: X) (tree: (bplustree b X))
                : bplustree b X :=
  match insert' (height tree) k v tree with
    | (tree, None) => tree
    | (left, Some (key, right)) => bptNode b X [(0, left), (key, right)]
  end.

Definition empty2Tree := bptLeaf 1 nat [].
Eval compute in insert 3 103 (insert 2 102 (insert 1 101 empty2Tree)).
Eval compute in insert 4 104 (insert 3 103 (insert 2 102 (insert 1 101 empty2Tree))).
Eval compute in insert 5 105 (insert 4 104 (insert 3 103 (insert 2 102 (insert 1 101 empty2Tree)))).

(* List2Bplustree *)
Fixpoint list2bplustree' {b: nat} {X: Type} (l: list (nat * X)) (tree: bplustree b X) : bplustree b X :=
  match l with
    | []          => tree
    | (k, v) :: l' => list2bplustree' l' (insert k v tree)
  end.

Definition list2bplustree (b: nat) {X: Type} (l: list (nat * X)) : bplustree b X :=
  match l with
    | []          => bptLeaf b X []
    | (k, v) :: l => list2bplustree' l (bptLeaf b X [(k, v)])
  end.

Eval compute in (list2bplustree 1 [(4, 4), (2, 2), (3, 3), (1, 1)]).
Eval compute in (list2bplustree 1 [(1, 1), (2, 2), (3, 3), (4, 4), (5, 5), (6, 6)]).

Example list2bplustree_empty : list2bplustree 2 [] = bptLeaf 2 nat [].
Proof. simpl. reflexivity. Qed.
Example list2bplustree_1 : list2bplustree 4 [(1, 1)] = bptLeaf 4 nat [(1, 1)].
Proof. simpl. reflexivity. Qed.
Example list2bplustree_4 : list2bplustree 1 [(4, 4), (2, 2), (3, 3), (1, 1)] = bptNode 1 nat
         [(0, [[1,nat|(1, 1),(2, 2)]]), (3, [[1,nat|(3, 3),
                                                  (4, 4)]])].
Proof. compute. reflexivity. Qed.

Example list2bplustree_6 : (list2bplustree 1 [(1, 1), (2, 2), (3, 3), (4, 4), (5, 5), (6, 6)]) =
bptNode 1 nat
         [(0, bptNode 1 nat [(0, [[1,nat|(1, 1)]]), (2, [[1,nat|(2, 2)]])]),
         (3,
         bptNode 1 nat
           [(0, [[1,nat|(3, 3)]]), (4, [[1,nat|(4, 4)]]),
           (5, [[1,nat|(5, 5),(6, 6)]])])].
Proof. compute. reflexivity. Qed.

Definition bigtree := list2bplustree 1 [(11, 1), (22, 2), (33, 3), (44, 4), (55, 5), (66, 6), (77, 7)].

Eval compute in (bigtree).
Eval compute in (height bigtree).


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* $Id$ *)

(** * Finite sets library *)

(** This functor derives additional facts from [MSetInterface.S]. These
  facts are mainly the specifications of [MSetInterface.S] written using
  different styles: equivalence and boolean equalities.
  Moreover, we prove that [E.Eq] and [Equal] are setoid equalities.
*)

Require Import DecidableTypeEx.
Require Export MSetInterface.
Set Implicit Arguments.
Unset Strict Implicit.

(** First, a functor for Weak Sets in functorial version. *)

Module WFactsOn (Import E : DecidableType)(Import M : WSetsOn E).

Notation eq_dec := E.eq_dec.
Definition eqb x y := if eq_dec x y then true else false.

(** * Specifications written using implications :
      this used to be the default interface. *)

Section ImplSpec.
Variable s s' : t.
Variable x y : elt.

Lemma In_1 : E.eq x y -> In x s -> In y s.
Proof. intros E; rewrite E; auto. Qed.

Lemma mem_1 : In x s -> mem x s = true.
Proof. intros; apply <- mem_spec; auto. Qed.
Lemma mem_2 : mem x s = true -> In x s.
Proof. intros; apply -> mem_spec; auto. Qed.

Lemma equal_1 : Equal s s' -> equal s s' = true.
Proof. intros; apply <- equal_spec; auto. Qed.
Lemma equal_2 : equal s s' = true -> Equal s s'.
Proof. intros; apply -> equal_spec; auto. Qed.

Lemma subset_1 : Subset s s' -> subset s s' = true.
Proof. intros; apply <- subset_spec; auto. Qed.
Lemma subset_2 : subset s s' = true -> Subset s s'.
Proof. intros; apply -> subset_spec; auto. Qed.

Lemma is_empty_1 : Empty s -> is_empty s = true.
Proof. intros; apply <- is_empty_spec; auto. Qed.
Lemma is_empty_2 : is_empty s = true -> Empty s.
Proof. intros; apply -> is_empty_spec; auto. Qed.

Lemma add_1 : E.eq x y -> In y (add x s).
Proof. intros; apply <- add_spec. auto with relations. Qed.
Lemma add_2 : In y s -> In y (add x s).
Proof. intros; apply <- add_spec; auto. Qed.
Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s.
Proof. rewrite add_spec. intros H [H'|H']; auto. elim H; auto with relations. Qed.

Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
Proof. intros; rewrite remove_spec; intuition. Qed.
Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
Proof. intros; apply <- remove_spec; auto with relations. Qed.
Lemma remove_3 : In y (remove x s) -> In y s.
Proof. rewrite remove_spec; intuition. Qed.

Lemma singleton_1 : In y (singleton x) -> E.eq x y.
Proof. rewrite singleton_spec; auto with relations. Qed.
Lemma singleton_2 : E.eq x y -> In y (singleton x).
Proof. rewrite singleton_spec; auto with relations. Qed.

Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
Proof. rewrite union_spec; auto. Qed.
Lemma union_2 : In x s -> In x (union s s').
Proof. rewrite union_spec; auto. Qed.
Lemma union_3 : In x s' -> In x (union s s').
Proof. rewrite union_spec; auto. Qed.

Lemma inter_1 : In x (inter s s') -> In x s.
Proof. rewrite inter_spec; intuition. Qed.
Lemma inter_2 : In x (inter s s') -> In x s'.
Proof. rewrite inter_spec; intuition. Qed.
Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
Proof. rewrite inter_spec; intuition. Qed.

Lemma diff_1 : In x (diff s s') -> In x s.
Proof. rewrite diff_spec; intuition. Qed.
Lemma diff_2 : In x (diff s s') -> ~ In x s'.
Proof. rewrite diff_spec; intuition. Qed.
Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
Proof. rewrite diff_spec; auto. Qed.

Variable f : elt -> bool.
Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).

Lemma filter_1 : compatb f -> In x (filter f s) -> In x s.
Proof. intros P; rewrite filter_spec; intuition. Qed.
Lemma filter_2 : compatb f -> In x (filter f s) -> f x = true.
Proof. intros P; rewrite filter_spec; intuition. Qed.
Lemma filter_3 : compatb f -> In x s -> f x = true -> In x (filter f s).
Proof. intros P; rewrite filter_spec; intuition. Qed.

Lemma for_all_1 : compatb f ->
      For_all (fun x => f x = true) s -> for_all f s = true.
Proof. intros; apply <- for_all_spec; auto. Qed.
Lemma for_all_2 : compatb f ->
      for_all f s = true -> For_all (fun x => f x = true) s.
Proof. intros; apply -> for_all_spec; auto. Qed.

Lemma exists_1 : compatb f ->
      Exists (fun x => f x = true) s -> exists_ f s = true.
Proof. intros; apply <- exists_spec; auto. Qed.

Lemma exists_2 : compatb f ->
      exists_ f s = true -> Exists (fun x => f x = true) s.
Proof. intros; apply -> exists_spec; auto. Qed.

Lemma elements_1 : In x s -> InA E.eq x (elements s).
Proof. intros; apply <- elements_spec1; auto. Qed.
Lemma elements_2 : InA E.eq x (elements s) -> In x s.
Proof. intros; apply -> elements_spec1; auto. Qed.

End ImplSpec.

Notation empty_1 := empty_spec (only parsing).
Notation fold_1 := fold_spec (only parsing).
Notation cardinal_1 := cardinal_spec (only parsing).
Notation partition_1 := partition_spec1 (only parsing).
Notation partition_2 := partition_spec2 (only parsing).
Notation choose_1 := choose_spec1 (only parsing).
Notation choose_2 := choose_spec2 (only parsing).
Notation elements_3w := elements_spec2w (only parsing).

Hint Resolve mem_1 equal_1 subset_1 empty_1
    is_empty_1 choose_1 choose_2 add_1 add_2 remove_1
    remove_2 singleton_2 union_1 union_2 union_3
    inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1
    partition_1 partition_2 elements_1 elements_3w
    : set.
Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3
    remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2
    filter_1 filter_2 for_all_2 exists_2 elements_2
    : set.

(** * Specifications written using equivalences :
      this is now provided by the default interface. *)

Section IffSpec.
Variable s s' s'' : t.
Variable x y z : elt.

Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s).
Proof.
intros E; rewrite E; intuition.
Qed.

Lemma mem_iff : In x s <-> mem x s = true.
Proof. apply iff_sym, mem_spec. Qed.

Lemma not_mem_iff : ~In x s <-> mem x s = false.
Proof.
rewrite <-mem_spec; destruct (mem x s); intuition.
Qed.

Lemma equal_iff : s[=]s' <-> equal s s' = true.
Proof. apply iff_sym, equal_spec. Qed.

Lemma subset_iff : s[<=]s' <-> subset s s' = true.
Proof. apply iff_sym, subset_spec. Qed.

Lemma empty_iff : In x empty <-> False.
Proof. intuition; apply (empty_spec H). Qed.

Lemma is_empty_iff : Empty s <-> is_empty s = true.
Proof. apply iff_sym, is_empty_spec. Qed.

Lemma singleton_iff : In y (singleton x) <-> E.eq x y.
Proof. rewrite singleton_spec; intuition. Qed.

Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s.
Proof. rewrite add_spec; intuition. Qed.

Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s)  <-> In y s).
Proof. rewrite add_spec; intuition. elim H; auto with relations. Qed.

Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y.
Proof. rewrite remove_spec; intuition. Qed.

Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s).
Proof. rewrite remove_spec; intuition. Qed.

Variable f : elt -> bool.

Lemma for_all_iff : Proper (E.eq==>Logic.eq) f ->
  (For_all (fun x => f x = true) s <-> for_all f s = true).
Proof. intros; apply iff_sym, for_all_spec; auto. Qed.

Lemma exists_iff : Proper (E.eq==>Logic.eq) f ->
  (Exists (fun x => f x = true) s <-> exists_ f s = true).
Proof. intros; apply iff_sym, exists_spec; auto. Qed.

Lemma elements_iff : In x s <-> InA E.eq x (elements s).
Proof. apply iff_sym, elements_spec1. Qed.

End IffSpec.

Notation union_iff := union_spec (only parsing).
Notation inter_iff := inter_spec (only parsing).
Notation diff_iff := diff_spec (only parsing).
Notation filter_iff := filter_spec (only parsing).

(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *)

Ltac set_iff :=
 repeat (progress (
  rewrite add_iff || rewrite remove_iff || rewrite singleton_iff
  || rewrite union_iff || rewrite inter_iff || rewrite diff_iff
  || rewrite empty_iff)).

(**  * Specifications written using boolean predicates *)

Section BoolSpec.
Variable s s' s'' : t.
Variable x y z : elt.

Lemma mem_b : E.eq x y -> mem x s = mem y s.
Proof.
intros.
generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H).
destruct (mem x s); destruct (mem y s); intuition.
Qed.

Lemma empty_b : mem y empty = false.
Proof.
generalize (empty_iff y)(mem_iff empty y).
destruct (mem y empty); intuition.
Qed.

Lemma add_b : mem y (add x s) = eqb x y || mem y s.
Proof.
generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb.
destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition.
Qed.

Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s.
Proof.
intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H).
destruct (mem y s); destruct (mem y (add x s)); intuition.
Qed.

Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y).
Proof.
generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb.
destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition.
Qed.

Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s.
Proof.
intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H).
destruct (mem y s); destruct (mem y (remove x s)); intuition.
Qed.

Lemma singleton_b : mem y (singleton x) = eqb x y.
Proof.
generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb.
destruct (eq_dec x y); destruct (mem y (singleton x)); intuition.
Qed.

Lemma union_b : mem x (union s s') = mem x s || mem x s'.
Proof.
generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x).
destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition.
Qed.

Lemma inter_b : mem x (inter s s') = mem x s && mem x s'.
Proof.
generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x).
destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition.
Qed.

Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s').
Proof.
generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x).
destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition.
Qed.

Lemma elements_b : mem x s = existsb (eqb x) (elements s).
Proof.
generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)).
rewrite InA_alt.
destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros.
symmetry.
rewrite H1.
destruct H0 as (H0,_).
destruct H0 as (a,(Ha1,Ha2)); [ intuition |].
exists a; intuition.
unfold eqb; destruct (eq_dec x a); auto.
rewrite <- H.
rewrite H0.
destruct H1 as (H1,_).
destruct H1 as (a,(Ha1,Ha2)); [intuition|].
exists a; intuition.
unfold eqb in *; destruct (eq_dec x a); auto; discriminate.
Qed.

Variable f : elt->bool.

Lemma filter_b : Proper (E.eq==>Logic.eq) f -> mem x (filter f s) = mem x s && f x.
Proof.
intros.
generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H).
destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition.
Qed.

Lemma for_all_b : Proper (E.eq==>Logic.eq) f ->
  for_all f s = forallb f (elements s).
Proof.
intros.
generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s).
unfold For_all.
destruct (forallb f (elements s)); destruct (for_all f s); auto; intros.
rewrite <- H1; intros.
destruct H0 as (H0,_).
rewrite (H2 x0) in H3.
rewrite (InA_alt E.eq x0 (elements s)) in H3.
destruct H3 as (a,(Ha1,Ha2)).
rewrite (H _ _ Ha1).
apply H0; auto.
symmetry.
rewrite H0; intros.
destruct H1 as (_,H1).
apply H1; auto.
rewrite H2.
rewrite InA_alt. exists x0; split; auto with relations.
Qed.

Lemma exists_b : Proper (E.eq==>Logic.eq) f ->
  exists_ f s = existsb f (elements s).
Proof.
intros.
generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s).
unfold Exists.
destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros.
rewrite <- H1; intros.
destruct H0 as (H0,_).
destruct H0 as (a,(Ha1,Ha2)); auto.
exists a; split; auto.
rewrite H2; rewrite InA_alt; exists a; auto with relations.
symmetry.
rewrite H0.
destruct H1 as (_,H1).
destruct H1 as (a,(Ha1,Ha2)); auto.
rewrite (H2 a) in Ha1.
rewrite (InA_alt E.eq a (elements s)) in Ha1.
destruct Ha1 as (b,(Hb1,Hb2)).
exists b; auto.
rewrite <- (H _ _ Hb1); auto.
Qed.

End BoolSpec.

(** * Declarations of morphisms with respects to [E.eq] and [Equal] *)

Instance In_m : Proper (E.eq==>Equal==>iff) In.
Proof.
unfold Equal; intros x y H s s' H0.
rewrite (In_eq_iff s H); auto.
Qed.

Instance Empty_m : Proper (Equal==>iff) Empty.
Proof.
repeat red; unfold Empty; intros s s' E.
setoid_rewrite E; auto.
Qed.

Instance is_empty_m : Proper (Equal==>Logic.eq) is_empty.
Proof.
intros s s' H.
generalize (is_empty_iff s). rewrite H at 1. rewrite is_empty_iff.
destruct (is_empty s); destruct (is_empty s'); intuition.
Qed.

Instance mem_m : Proper (E.eq==>Equal==>Logic.eq) mem.
Proof.
intros x x' Hx s s' Hs.
generalize (mem_iff s x). rewrite Hs, Hx at 1; rewrite mem_iff.
destruct (mem x s), (mem x' s'); intuition.
Qed.

Instance singleton_m : Proper (E.eq==>Equal) singleton.
Proof.
intros x y H a. rewrite !singleton_iff, H; intuition.
Qed.

Instance add_m : Proper (E.eq==>Equal==>Equal) add.
Proof.
intros x x' Hx s s' Hs a. rewrite !add_iff, Hx, Hs; intuition.
Qed.

Instance remove_m : Proper (E.eq==>Equal==>Equal) remove.
Proof.
intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx, Hs; intuition.
Qed.

Instance union_m : Proper (Equal==>Equal==>Equal) union.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition.
Qed.

Instance inter_m : Proper (Equal==>Equal==>Equal) inter.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition.
Qed.

Instance diff_m : Proper (Equal==>Equal==>Equal) diff.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition.
Qed.

Instance Subset_m : Proper (Equal==>Equal==>iff) Subset.
Proof.
unfold Equal, Subset; firstorder.
Qed.

Instance subset_m : Proper (Equal==>Equal==>Logic.eq) subset.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2.
generalize (subset_iff s1 s2). rewrite Hs1, Hs2 at 1. rewrite subset_iff.
destruct (subset s1 s2); destruct (subset s1' s2'); intuition.
Qed.

Instance equal_m : Proper (Equal==>Equal==>Logic.eq) equal.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2.
generalize (equal_iff s1 s2). rewrite Hs1,Hs2 at 1. rewrite equal_iff.
destruct (equal s1 s2); destruct (equal s1' s2'); intuition.
Qed.

Instance SubsetSetoid : PreOrder Subset. (* reflexive + transitive *)
Proof. firstorder. Qed.

Definition Subset_refl := @PreOrder_Reflexive _ _ SubsetSetoid.
Definition Subset_trans := @PreOrder_Transitive _ _ SubsetSetoid.

Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> impl) In | 1.
Proof.
  simpl_relation. eauto with set.
Qed.

Instance Empty_s_m : Proper (Subset-->impl) Empty.
Proof. firstorder. Qed.

Instance add_s_m : Proper (E.eq==>Subset++>Subset) add.
Proof.
intros x x' Hx s s' Hs a. rewrite !add_iff, Hx; intuition.
Qed.

Instance remove_s_m : Proper (E.eq==>Subset++>Subset) remove.
Proof.
intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx; intuition.
Qed.

Instance union_s_m : Proper (Subset++>Subset++>Subset) union.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition.
Qed.

Instance inter_s_m : Proper (Subset++>Subset++>Subset) inter.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition.
Qed.

Instance diff_s_m : Proper (Subset++>Subset-->Subset) diff.
Proof.
intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition.
Qed.

(* [fold], [filter], [for_all], [exists_] and [partition] requires
  some knowledge on [f] in order to be known as morphisms. *)

Generalizable Variables f.

Instance filter_equal : forall `(Proper _ (E.eq==>Logic.eq) f),
 Proper (Equal==>Equal) (filter f).
Proof.
intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition.
Qed.

Instance filter_subset : forall `(Proper _ (E.eq==>Logic.eq) f),
 Proper (Subset==>Subset) (filter f).
Proof.
intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition.
Qed.

Lemma filter_ext : forall f f', Proper (E.eq==>Logic.eq) f -> (forall x, f x = f' x) ->
 forall s s', s[=]s' -> filter f s [=] filter f' s'.
Proof.
intros f f' Hf Hff' s s' Hss' x. rewrite 2 filter_iff; auto.
rewrite Hff', Hss'; intuition.
red; red; intros; rewrite <- 2 Hff'; auto.
Qed.

(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid
   structures on [list elt] and [option elt]. *)

(* Later:
Add Morphism cardinal ; cardinal_m.
*)

End WFactsOn.

(** Now comes variants for self-contained weak sets and for full sets.
    For these variants, only one argument is necessary. Thanks to
    the subtyping [WS<=S], the [Facts] functor which is meant to be
    used on modules [(M:S)] can simply be an alias of [WFacts]. *)

Module WFacts (M:WSets) := WFactsOn M.E M.
Module Facts := WFacts.


Require Import PL.Imp3.
Import Assertion_D.
Import Abstract_Pretty_Printing.

(* ################################################################# *)
(** * Weakest Precondition *)

(** A Hoare logic is complete if all valid Hoare triples are provable. *)

Definition hoare_complete (T: FirstOrderLogic): Prop :=
  forall P c Q,
    |== {{ P }} c {{ Q }} ->
    |-- {{ P }} c {{ Q }}.

(** The general idea of proving Hoare logic completeness is to prove those
Hoare triples with weakest preconditions are provable. Specifically, an
assertion [P] is called the weakest precondition of [c] and [Q] if Hoare triple

    {{P}} c {{Q}}

is valid and for any other [P'], if [{{P'}} c {{Q}}] is valid, then

    P' IMPLY P

is valid. Again, remember that an assertion is called valid if it is satisfied
on all interpreations. *)

Definition FOL_valid (P: Assertion): Prop :=
  forall J: Interp, J |== P.

Definition wp' (P: Assertion) (c: com) (Q: Assertion): Prop :=
  (|== {{ P }} c {{ Q }}) /\
  (forall P', (|== {{ P' }} c {{ Q }}) -> FOL_valid  (P' IMPLY P)).

(** Although this definition above is very natural, we can actually be more
specific on what this weakest precondition should be. *)

Definition wp (P: Assertion) (c: com) (Q: Assertion): Prop :=
  forall st La,
    (st, La) |== P <->
    (forall st', ceval c st st' -> (st', La) |== Q).

(** This definition says: a beginning state [st] satisfies [P] if and only if
all possible ending states of executing [c] will satisfy [Q]. This definition
directly defines what interpreations satisfy [P]. Of course, it is consistent
will our previous definition. *)

Lemma wp_wp': forall P c Q,
  wp P c Q -> wp' P c Q.
Proof.
  intros.
  unfold wp in H; unfold wp'.
  split.
  + unfold valid.
    intros.
    specialize (H st1 La).
    firstorder.
  + intros.
    unfold FOL_valid; simpl.
    intros.
    destruct J as [st La].
    rewrite H.
    unfold valid in H0.
    specialize (H0 La st).
    pose proof classic ((st, La) |== P').
    destruct H1; [right | left; exact H1].
    firstorder.
Qed.

(** Hoare logic's completeness proof needs two important lemmas:

    - expressiveness: for any [c] and [Q], there is an assertion
      to express the weakest precondition of [c] and [Q];

    - if [P] expresses the weakest precondition of [c] and [Q],
      then [ {{ P }} c {{ Q }} ] is provable.

Here are their formal statement. *)

Definition expressive: Prop :=
  forall c Q, exists P, wp P c Q.

Definition wp_provable (T: FirstOrderLogic): Prop :=
  forall P c Q, wp P c Q -> |-- {{ P }} c {{ Q }}.

(** We show that, if there two properties hold, the Hoare logic is complete
given the fact that the assertion derivation logic itself is complete. *)

Definition FOL_complete (T: FirstOrderLogic): Prop :=
  forall P: Assertion, FOL_valid P -> FOL_provable P.

Proposition Hoare_complete_main_proof: forall T: FirstOrderLogic,
  expressive ->
  wp_provable T ->
  FOL_complete T ->
  hoare_complete T.
Proof.
  intros.
  unfold hoare_complete.
  intros P' c Q ?.
  (** First, by expressiveness, there is an assertion [P] which can
  express [c] and [Q]'s weakest precondition. *)
  unfold expressive in H.
  specialize (H c Q).
  destruct H as [P ?].
  (** Next, by the fact that all triples with weakest preconditions
  are provable, we know that [ {{ P }} c {{ Q }} ] is provable. *)
  unfold wp_provable in H0.
  specialize (H0 _ _ _ H).
  (** Now, by the definition of "weakest_pre", we know that [P'] is
  semantically stronger than [P]. *)
  apply wp_wp' in H.
  unfold wp' in H.
  destruct H.
  apply H3 in H2; clear H H3.
  (** Since we assume that the first order logic [T] is complete, we
  know that [P' |-- P] from the fact that [P' IMPLY P] is valid. *)
  assert (P' |-- P).
  {
    unfold FOL_complete in H1.
    unfold derives.
    apply H1.
    exact H2.
  }
  clear H2.
  (** In the end, we complete our Hoare logic proof using the consequence
  rule. *)
  assert (Q |-- Q).
  {
    unfold FOL_complete in H1.
    unfold derives.
    apply H1.
    unfold FOL_valid.
    intros; simpl.
    tauto.
  }
  eapply hoare_consequence.
  + exact H.
  + exact H0.
  + exact H2.
Qed.

(* ################################################################# *)
(** * Proof of Expressiveness *)

(** We prove this lemma by induction over the syntax tree of [c]. *)

(* ================================================================= *)
(** ** If [c = Skip] *)

(** We are going to prove that: for any assertion [Q], there is another
assertion [P] such that [P] is [c] and [Q]'s weakest precondition.

Let [P] be [Q]. Then for given [st] and [La], it is obvious that

    (st, La) |== P

is equivalent to

    forall st', ceval c st st' -> (st, La) |== Q

since [c = Skip] and [P = Q]. *)

(* ================================================================= *)
(** ** If [c = X ::= E] *)

(** The conclusion can be easily proved if we let [P] be

    Q [X |-> E].
*)

(* ================================================================= *)
(** ** If [c = c1 ;; c2] *)

(** IH1: for any assertion [Q], there is another assertion [P] such that [wp P
c1 Q].

IH2: for any assertion [Q], there is another assertion [P] such that [wp P c2
Q].

We are going to prove that: for any assertion [Q], there is another assertion [P] such that [wp P c Q].

For a fixed postcondition [Q] of [c], let [Q0] be [c2] and [Q]'s weakest
precondition and let [P] be [c1] and [Q0]'s weakest precondition (they must
exist according to IH). And we know that for any [st] and [La],

    (st, La) |== P iff for any st', if ceval c1 st st', then (st', La) |== Q0;
    (st, La) |== Q0 iff for any st', if ceval c2 st st', then (st', La) |== Q.

Combining them together, we have

    (st, La) |== P iff for any st' st'',
       if ceval c1 st st' and ceval c2 st' st'', then (st'', La) |== Q.

Thus, [wp P (c1;;c2) Q]. *)

(* ================================================================= *)
(** ** If [c = If b Then c1 Else c2 EndIf *)

(** IH1: for any assertion [Q], there is another assertion [P] such that [wp P
c1 Q].

IH2: for any assertion [Q], there is another assertion [P] such that [wp P c2
Q].

We are going to prove that: for any assertion [Q], there is another assertion [P] such that [wp P c Q].

For a fixed postcondition [Q] of [c], let [P1] be [c1] and [Q]'s weakest
precondition and let [P2] be [c2] and [Q]'s weakest precondition (they must
exist according to IH). And we know that for any [st] and [La],

    (st, La) |== P1 iff for any st', if ceval c1 st st', then (st', La) |== Q;
    (st, La) |== P2 iff for any st', if ceval c2 st st', then (st', La) |== Q.

Let [P] be [ P1 AND {[b]} OR P2 AND NOT {[b]} ]. Now, given an interpretation
[(st, La)], it satisfies [P] if and only if one of the following is true:

    (st, La) |== P1 and beval b st
    (st, La) |== P2 and (beval b st) is not true.

According to how [P1] and [P2] are introduced, we know [P] is a weakest
precondition of [c] and [Q], i.e. [wp P c Q]. *)

(* ================================================================= *)
(** ** If [c = While b Do c1 EndWhile] *)

(** This is the most difficult case. We want to find a weakest precondition of
[c] and [Q], with the help from induction hypothesis (IH) is: for any assertion
[Q'], there is another assertion [P'] such that [wp P' c1 Q'].

By the definition of [wp], we want to find an assertion [P] such that:

    (st(0), La) |== P if and only if
      for any natural number n,
        for any program states st(1), ..., st(n),
        if for any 0 <= i < n,
             (A) beval b st(i)
             (B) ceval c1 st(i) st(i+1)
        then either (beval b st(n)) or (st(n), La) |== Q.

We know that only finite program variables can be mentioned in [Q] and [c].
Suppose they are [X1], [X2], ..., [Xm]. Then we can restate the criterion
above -- [P] should be (informally):

      for any natural number n,
        for any integers x(0,1), x(0,2), ..., x(0,m),
                         x(1,1), x(1,2), ..., x(1,m),
                         x(2,1), x(2,2), ..., x(2,m),
                         ...
                         x(n,1), x(n,2), ..., x(n,m),
        if
        (1) {[ X1 ]} == x(0,1) AND ... AND {[ Xm ]} == x(0, m) AND
        (2) for any i, if 0 <= i < n, then
              (2.1) b [ X1 |-> x(i, 1); ...; Xm |-> x(i, m) ]
              (2.2) IH(X1 = x(i + 1, 1) AND ... AND Xm = x(i + 1, m))
                      [ X1 |-> x(i, 1); ...; Xm |-> x(i, m) ]
              (2.3) NOT IH(False) [ X1 |-> x(i, 1); ...; Xm |-> x(i, m) ]
        then either
        (3) b [ X1 |-> x(n, 1); ...; Xm |-> x(n, m) ]; or
        (4) Q [ X1 |-> x(n, 1); ...; Xm |-> x(n, m) ].

In this informal statement, we use [x(i,1), x(i,2), ..., x(i,m)] to represent
all program variables' values after [i] iterations. Property (1) says that
[(st, La)] agree with the description of [x(0,1), x(0,2), ..., x(0,m)].
Property (2.1) says that the loop condition is true after the first [i]
iterations. Property (2.2) says: if the loop body of [i+1]th iteration
terminates, its ending state is the one described by [x(i+1,1), ..., x(i+1,m)].
Eventually, property (2.3) says: if the loop body of [i+1]th iteration will
terminate.

Noticing that this is almost an assertion, except for one thing -- the dynamic
sized quantification over integers [x]s. This problem can be solved by Godel's
beta predicate. *)

(* ================================================================= *)
(** ** Godel Beta Predicate *)

(** The Godel beta predicate [Beta(a,b,i,x)] is defined as:

    x = a mod (1 + (i+1) * b)

According to The Chinese remainder theorem, for any natural number [n] and
natural number sequence [x(0)], [x(1)], ..., [x(n)], there always exist [a] and
[b] such that for any [0 <= i <= n],

    Beta(a, b, i, y) if and only if y = x(i).

That means, any quantification over sequences can be represented by a
combination of a fixed number of normal quantification and the Godel beta
predicate. For example, the following two statement are equivalent:

    for any natural numbers n, x(0), x(1), ..., x(n),
      if for any i, 0 <= i < n, x(i) <= x(i+1) holds,
      then x(n) satisfies property R

and

    for any natural numbers n, a, b,
      if:
         for any i, x and x',
           if 0 <= i < n, Beta(a, b, i, x) and Beta(a, b, i+1, x')
           then x < x'
      then:
         for any x,
           if Beta(a, b, n, x) then x satisfies property P.

Using this method, we can easily state loops' weakest preconditions in our
assertion language.

This proves the expressiveness lemma. *)

(* ################################################################# *)
(** * Establishing Triples With Weakest Precondtions *)

(** In this part, we prove that if [P] is [c] and [Q]'s weakest precondition,
then the Hoare triple is provable. Noticing that the assertion [P] is not
necessarily the weakest precondition constructed by the expressiveness lemma,
we argue about all possible triples such that [wp P c Q] holds.

Again, we prove this lemma by induction over the syntax tree of [c]. *)

(* ================================================================= *)
(** ** If [c = Skip] *)

(** If [P] is a weakest precondition of [c] and [Q], we know that [P] is
actually equivalent with [Q]. Thus, [ P IMPLY Q ] is a valid first order
proposition. By the assertion derivation logic's completeness, we know that
[ P |-- Q] which is immediately followed by [ |-- {{ P }} c {{ Q }} ] according
to the consequence rule. *)

(* ================================================================= *)
(** ** If [c = X ::= E] *)

(** The proof is similar. *)

(* ================================================================= *)
(** ** If [c = c1 ;; c2] *)

(** The proof is similar. *)

(* ================================================================= *)
(** ** If [c = If b Then c1 Else c2 EndIf *)

(** The proof is similar. *)

(* ================================================================= *)
(** ** If [c = While b Do c1 EndWhile] *)

(** This is the only interesting case! Suppose [wp P c Q]. We know:

    for any st and La,
      (st, La) |== P if and only if
      for any st', if (ceval c st st'), then (st', La) |== Q.

Now, consider the weakest precondition of [c1] and [P]. We claim that
[ P AND {[ b ]} ] is stronger than weakest preconditions of [c1] and [P].

For fixed [st] and [La], if

    (st, La) |== P AND {[ b ]}

then for any [st']

    if (ceval c st st'), then (st', La) |== Q.

Since [b] is true on [st], we know that for any [st'] and [st''],

    if (ceval c1 st st') and (ceval c st' st''), then (st'', La) |== Q.

This is equivalent to say: for any [st'],

    if (ceval c1 st st') then for any st'',
       if (ceval c st' st''), then (st'', La) |== Q.

By the fact that [wp P c Q], we conclude that for any [st'],

    if (ceval c1 st st') then (st', La) |== P.

Now, suppose [P'] is a weakest precondtion of [c] and [P] (by expressiveness
lemma, it must exist). What we just proved means that [(P AND {[ b ]}) IMPLY P']
is a valid assertion. By the first order logic's completeness,

    P AND {[b]} |-- P'.

By induction hypothesis:

    |-- {{ P' }} c1 {{ P }}.

Then by the consequence rule:

    |-- {{ P AND {[ b ]} }} c1 {{ P }}.

Thus,

    |-- {{ P }} c {{ P AND NOT {[ b ]} }}.

At the same time, due to [wp P c Q], it is obvious that if [(st, La) |== P AND
NOT {[ b ]}] on some interpretation [(st, La)], then [(st, La) |== Q]. In other
words, [ (P AND NOT {[ b ]}) IMPLY Q ] is valid. Thus,

    P AND NOT {[ b ]} |-- Q.

So,

    |-- {{ P }} c {{ Q }}.

This proves that all triples with weakest preconditions are provable. *)

(* Tue Apr 21 11:15:40 CST 2020 *)


Require Export Elementary_Algebra.

(* EXISTENCE OF SETS *)

Module Existence.

(* III Axiom of subsets  If x is a set there is a set y such that for each z,
   if z⊂x, then z∈y. *)

Axiom Axiom_Subsets : forall (x: Class),
  Ensemble x -> exists y, Ensemble y /\ (forall z, z⊂x -> z∈y).

Hint Resolve Axiom_Subsets : set.

(* 33 Theorem  If x is a set and z⊂x, then z is a set. *)

Theorem sub_set : forall x z,
  Ensemble x -> z ⊂ x -> Ensemble z.
Proof.
  intros; apply Axiom_Subsets in H; destruct H.
  apply H in H0; Ens.
Qed.

Hint Resolve sub_set : set.

(* 34 Theorem  Φ = ∩μ and ∪μ = μ. *)

Theorem universe_eleI : Φ = ∩μ.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - generalize (not_bel_zero z); contradiction.
  - apply Axiom_Scheme in H; destruct H; apply H0.
    apply bel_universe_set; generalize (zero_sub z); intros.
    apply sub_set in H1; auto.
Qed.

Theorem universe_eleU : μ = ∪μ.
Proof.
  apply Axiom_Extent; split; intros.
  - apply Lemma_x in H; destruct H; apply Axiom_Scheme in H.
    destruct H; apply Axiom_Scheme; split; try auto.
    generalize (Axiom_Subsets z H); intros.
    destruct H2; destruct H2; exists x; split.
    + apply H3; unfold Subclass; auto.
    + apply bel_universe_set; auto.
  - apply Axiom_Scheme in H; destruct H; apply bel_universe_set; auto.
Qed.

Hint Rewrite universe_eleI universe_eleU : set.

(* 35 Theorem  If x ≠ Φ, then ∩x is a set. *)

Lemma not_zero_exist_bel : forall x, x ≠ Φ <-> exists z, z∈x.
Proof.
  intros; assert (x = Φ <-> ~ (exists y, y∈x)).
  { split; intros.
    - intro; destruct H0; rewrite H in H0.
      apply Axiom_Scheme in H0; destruct H0; case H1; auto.
    - apply Axiom_Extent; split; intros.
      + elim H; exists z; auto.
      + generalize (not_bel_zero z); contradiction. }
  split; intros.
  - apply definition_not with (B:= ~(exists y, y∈x)) in H0; auto.
    apply NNPP in H0; destruct H0; exists x0; auto.
  - apply definition_not with (A:=(~ (exists y, y∈x))); auto.
    destruct H; split; auto.
Qed.

Theorem not_zero_set_eleI : forall x, x ≠ Φ -> Ensemble (∩x).
Proof.
  intros; apply not_zero_exist_bel in H; destruct H; AssE x0.
  generalize (bel_ele x0 x H); intros.
  destruct H1; apply sub_set in H2; auto.
Qed.

Hint Resolve not_zero_exist_bel not_zero_set_eleI : set.

(* 36 Definition  pow(x) = { y : y ⊂ x }. *)

Definition PowerClass x : Class := \{ λ y, y ⊂ x \}.

Notation "pow( x )" := (PowerClass x) (at level 0, right associativity).

Hint Unfold PowerClass : set.

(* 37 Theorem  μ = pow(μ). *)

Theorem universe_pow : μ = pow(μ).
Proof.
  apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme; split; Ens; apply sub_universe.
  - apply Axiom_Scheme in H; destruct H; apply bel_universe_set; auto.
Qed.

Hint Rewrite universe_pow : set.

(* 38 Theorem  If x is a set, then pow(x) is a set, and for each y, y ⊂ x iff
   y ∈ pow(x). *)

Theorem pow_set : forall x y,
  Ensemble x -> Ensemble pow(x) /\ (y ⊂ x <-> y ∈ pow(x)).
Proof.
  intros; split.
  - apply Axiom_Subsets in H; destruct H, H.
    assert (pow(x) ⊂ x0).
    { unfold Subclass; intros; apply Axiom_Scheme in H1.
      destruct H1; apply H0 in H2; auto. }
    apply sub_set in H1; auto.
  - split; intros.
    + apply sub_set with (z:=y) in H; auto.
      apply Axiom_Scheme; split; auto.
    + apply Axiom_Scheme in H0; apply H0.
Qed.

Hint Resolve pow_set : set.

(* 39 Theorem  μ is not a set. *)

(* Russell paradox *)

Lemma Russell_N : ~ Ensemble \{ λ x, x ∉ x \}.
Proof.
  generalize (classic (\{ λ x, x ∉ x \} ∈ \{ λ x, x ∉ x \})).
  intros; destruct H.
  - double H; apply Axiom_Scheme in H; destruct H; contradiction.
  - intro; elim H; apply Axiom_Scheme; split; auto.
Qed.

Theorem universe_notset : ~ Ensemble μ.
Proof.
  unfold not; generalize Russell_N; intros.
  generalize (sub_universe \{ λ x, x ∉ x \}); intros.
  apply sub_set in H1; auto.
Qed.

Hint Resolve Russell_N universe_notset : set.

(* 40 Definition  [x] = { z : if x∈μ, then z=x }. *)

Definition Singleton x : Class := \{ λ z, x∈μ -> z=x \}.

Notation "[ x ]" := (Singleton x) (at level 0, right associativity).

Hint Unfold Singleton : set.

(* 41 Theorem  If x is a set, for each y, y∈[x] iff y=x. *)

Theorem set_bel_sing_eq : forall x, Ensemble x -> (forall y, y∈[x] <-> y=x).
Proof.
  intros; split; intros.
  - apply Axiom_Scheme in H0; destruct H0; apply H1.
    apply bel_universe_set in H; auto.
  - apply Axiom_Scheme; split; intros; auto.
    rewrite <- H0 in H; auto.
Qed.

Hint Resolve set_bel_sing_eq : set.

(* 42 Theorem  If x is a set, then [x] is a set. *)

Theorem sing_set : forall x, Ensemble x -> Ensemble [x].
Proof.
  intros; double H; apply sub_set with (x:= pow(x)).
  - apply pow_set with (y:=x) in H0; destruct H0; auto.
  - unfold Subclass; intros.
    apply pow_set with (y:=z) in H0; destruct H0.
    apply H2; apply Axiom_Scheme in H1; destruct H1.
    apply bel_universe_set in H; apply H3 in H.
    rewrite H; unfold Subclass; auto.
Qed.

Hint Resolve sing_set : set.

(* 43 Theorem  [x] = μ if and only if x is not a set. *)

Theorem sing_eq_universe_iff_not_set : forall x, [x] = μ <-> ~ Ensemble x.
Proof.
  split; intros.
  - unfold not; intros; apply sing_set in H0.
    rewrite H in H0; generalize universe_notset; contradiction.
  - generalize (bel_universe_set x); intros.
    apply definition_not with (B:= x∈μ) in H; try tauto.
    apply Axiom_Extent; split; intros.
    * apply Axiom_Scheme in H1; destruct H1; apply bel_universe_set; auto.
    * apply Axiom_Scheme; split; try contradiction.
      apply bel_universe_set in H1; auto.
Qed.

Hint Rewrite sing_eq_universe_iff_not_set : set.

(* 42' Theorem  If [x] is a set, then x is a set. *)

Theorem sing_set_inv : forall x, Ensemble [x] -> Ensemble x.
Proof.
  intros.
  generalize (classic (Ensemble x)); intros.
  destruct H0; auto; generalize (universe_notset); intros.
  apply sing_eq_universe_iff_not_set in H0; auto.
  rewrite H0 in H; contradiction.
Qed.

Hint Resolve sing_set_inv : set.

(* 44 Theorem  If x is a set, then ∩[x] = x and ∪[x] = x; if x is not a set,
   then ∩[x] = Φ and ∪[x] = μ. *)

Theorem sing_ele : forall x, Ensemble x -> ∩[x] = x /\ ∪[x] = x.
Proof.
  intros; generalize (set_bel_sing_eq x H); intros.
  split; apply Axiom_Extent.
  - split; intros.
    + apply Axiom_Scheme in H1; destruct H1; apply H2; apply H0; auto.
    + apply Axiom_Scheme; split; Ens; intros.
      apply H0 in H2; rewrite H2; auto.
  - split; intros.
    + apply Axiom_Scheme in H1; destruct H1, H2, H2.
      unfold Singleton in H3; apply Axiom_Scheme in H3; destruct H3.
      rewrite H4 in H2; auto; apply bel_universe_set; auto.
    + apply Axiom_Scheme; split; Ens; exists x; split; auto.
      unfold Singleton; apply Axiom_Scheme; auto.
Qed.

Theorem not_sing_ele : forall x, ~ Ensemble x -> ∩[x] = Φ /\ ∪[x] = μ.
Proof.
  intros; apply sing_eq_universe_iff_not_set in H; split; rewrite H.
  - rewrite universe_eleI; auto.
  - rewrite <- universe_eleU; auto.
Qed.

Hint Resolve sing_ele not_sing_ele : set.

(* IV Axiom of union  If x is a set and y is a set so is x∪y. *)

Axiom Axiom_Union : forall (x y: Class),
  Ensemble x /\ Ensemble y -> Ensemble (x∪y).

Corollary Axiom_Union': forall x y,
  Ensemble (x∪y) -> Ensemble x /\ Ensemble y.
Proof.
  intros; split.
  - assert (x ⊂ (x∪y)).
    { unfold Subclass; intros; apply bel_union; tauto. }
    apply sub_set in H0; auto.
  - assert (y ⊂ (x∪y)).
    { unfold Subclass; intros; apply bel_union; tauto. }
    apply sub_set in H0; auto.
Qed.

Hint Resolve Axiom_Union Axiom_Union' : set.

(* 45 Definition  [x|y] = [x] ∪ [y]. *)

Definition Unordered x y : Class := [x]∪[y].

Notation "[ x | y ]" := (Unordered x y) (at level 0).

Hint Unfold Unordered : set.

(* 46 Theorem  If x is a set and y is a set, then [x|y] is a set and z∈[x|y]
   iff z=x or z=y; [x|y] = μ iff x is not a set or y is not a set. *)

Theorem unord_set : forall x y z,
  Ensemble x /\ Ensemble y -> Ensemble [x|y] /\ (z∈[x|y] <-> (z=x \/ z=y)).
Proof.
  split; intros; destruct H.
  - apply sing_set in H; apply sing_set in H0; apply Axiom_Union; auto.
  - split; intros.
    + apply Axiom_Scheme in H1; destruct H1.
      destruct H2; apply Axiom_Scheme in H2; destruct H2.
      * left; apply H3; apply bel_universe_set; auto.
      * right; apply H3; apply bel_universe_set; auto.
    + apply Axiom_Scheme; split.
      * destruct H1; try rewrite <- H1 in H; auto.
        rewrite <- H1 in H0; auto.
      * destruct H1.
        -- left; apply Axiom_Scheme; split; rewrite <- H1 in H; auto.
        -- right; apply Axiom_Scheme; split; rewrite <- H1 in H0; auto.
Qed.

Theorem unord_notset : forall x y, [x|y] = μ <-> ~ Ensemble x \/ ~ Ensemble y.
Proof.
  unfold Unordered; split; intros.
  - generalize (sing_eq_universe_iff_not_set ([x] ∪ [y])); intros.
    destruct H0; rewrite H in H0.
    assert ([μ] = μ); try apply sing_eq_universe_iff_not_set; try apply universe_notset.
    apply H0 in H2; rewrite <- H in H2.
    assert (Ensemble([x]∪[y]) <-> Ensemble [x] /\ Ensemble [y]).
    { split; try apply Axiom_Union; try apply Axiom_Union'. }
    apply definition_not in H3; auto.
    generalize (not_and_or (Ensemble [x]) (Ensemble [y])); intros.
    apply H4 in H3; destruct H3.
    + assert (Ensemble [x] <-> Ensemble x).
      { split; try apply sing_set_inv; try apply sing_set; auto. }
      apply definition_not in H5; auto.
    + assert (Ensemble [y] <-> Ensemble y).
      { split; try apply sing_set_inv; try apply sing_set; auto. }
      apply definition_not in H5; auto.
  - destruct H; apply sing_eq_universe_iff_not_set in H; rewrite H; try apply universe_union.
    generalize (union_com μ [y]); intros; rewrite H0; apply universe_union.
Qed.

Hint Resolve unord_set unord_notset : set.

(* 47 Theorem  If x and y are sets, then ∩[x|y] = x ∩ y and ∪[x|y] = x ∪ y;
   if either x or y is not a set, then ∩[x|y] = Φ and ∪[x|y] = μ. *)

Theorem unord_ele : forall x y,
  Ensemble x /\ Ensemble y -> (∩[x|y] = x ∩ y) /\ (∪[x|y] = x ∪ y).
Proof.
  intros; split; apply Axiom_Extent; intros.
  - split; intros.
    + apply bel_inter.
      split; apply Axiom_Scheme in H0; destruct H0; apply H1; apply bel_union.
      * left; apply Axiom_Scheme; split; try apply H; auto.
      * right; apply Axiom_Scheme; split; try apply H; auto.
    + apply bel_inter in H0; destruct H0.
      apply Axiom_Scheme; split; intros; try AssE z.
      apply bel_union in H2; destruct H2.
      * apply Axiom_Scheme in H2; destruct H2; destruct H.
        apply bel_universe_set in H; apply H4 in H; rewrite H; auto.
      * apply Axiom_Scheme in H2; destruct H2; destruct H.
        apply bel_universe_set in H5; apply H4 in H5; rewrite H5; auto.
  - split; intros.
    + apply Axiom_Scheme in H0; destruct H0; destruct H1; destruct H1.
      apply bel_union in H2; apply bel_union.
      destruct H2; apply Axiom_Scheme in H2; destruct H2.
      * left; destruct H; apply bel_universe_set in H.
        apply H3 in H; rewrite H in H1; auto.
      * right; destruct H; apply bel_universe_set in H4.
        apply H3 in H4; rewrite H4 in H1; auto.
    + apply bel_union in H0; apply Axiom_Scheme.
      split; destruct H0; try AssE z.
      * exists x; split; auto; apply bel_union; left.
        apply Axiom_Scheme; split; try apply H; trivial.
      * exists y; split; auto; apply bel_union; right.
        apply Axiom_Scheme; split; try apply H; trivial.
Qed.

Theorem unord_ele_not : forall x y,
  ~ Ensemble x \/ ~ Ensemble y -> (∩[x|y] = Φ) /\ (∪[x|y] = μ).
Proof.
  intros; split; apply unord_notset in H; rewrite H.
  - rewrite universe_eleI; auto.
  - rewrite <- universe_eleU; auto.
Qed.

Hint Resolve unord_ele unord_ele_not : set.

End Existence.

Export Existence.


Require Import String.
Require Import Omega.

Require Import Cryptol.Coqlib.

Require Import Cryptol.AST.
Require Import Cryptol.Bitvectors.
Require Import Cryptol.Utils.

Import ListNotations.

(**************** Functions ****************)

(* convert a forced list of bits to a bitvector *)
Fixpoint to_bitv {ws : nat} (l : list ext_val) : option (BitV ws) :=
  match l, ws with
  | nil, O => Some (@repr 0 0)
  | (ebit b) :: r, S n =>
    match @to_bitv n r with
    | Some bv => Some (@repr (S n) (unsigned bv + if b then (two_power_nat n) else 0))
    | None => None
    end
  | _,_ => None
  end.

Fixpoint from_bitv' (ws : nat) (n : nat) (bv : BitV ws) : list ext_val :=
  match n with
  | O => nil
  | S n' => (ebit (testbit bv (Z.of_nat n')) :: from_bitv' ws n' bv)
  end.

Definition from_bitv {ws : nat} (bv : BitV ws) : list ext_val :=
  from_bitv' ws ws bv.

Lemma tobit_length :
  forall l ws bv,
    @to_bitv ws l = Some bv ->
    ws = length l.
Proof.
  induction l; intros.
  unfold to_bitv in *. destruct ws; simpl in H; inv H. reflexivity.
  destruct ws; simpl in H. destruct a; simpl in H; inv H.
  destruct a; simpl in H; try solve [inv H].
  match goal with
  | [ H : context[ match ?X with _ => _ end ] |- _ ] => destruct X eqn:?
  end; inv H.
  eapply IHl in Heqo. simpl. auto.
Qed.

Lemma to_bitv_width_zero : forall l (bv : BitV 0),
  to_bitv l = Some bv -> l = nil.
Proof.
  destruct l; intros.
  - reflexivity.
  - exfalso. inversion H.
    destruct e; try congruence.
Qed.

Lemma intval_width_zero : forall (bv : BitV 0),
  intval bv = 0.
Proof.
  intros. unfold intval. destruct bv. unfold two_power_nat in intrange. simpl in intrange. omega.
Qed.

Lemma frombitv_cons : forall l width length (bv : BitV width),
  from_bitv' width length bv = l ->
    exists a,
    from_bitv' width (S length) bv = (a::l).
Proof.
  intros. simpl. rewrite H. eauto.
Qed.

Lemma frombit_nil : forall ws (bv : BitV ws),
  from_bitv bv = [] -> ws = 0%nat.
Proof.
  intros. unfold from_bitv in H. destruct ws eqn:?; try congruence.
  inversion H.
Qed.

Lemma list_helper : forall {A : Type} (l1 : list A) (l2 : list A) (v v0 : A),
   (l2 ++ v :: nil) ++ v0 :: l1 = l2 ++ (v :: v0 :: l1).
Proof.
  intros. induction l2.
  - simpl. reflexivity.
  - simpl. rewrite IHl2. reflexivity.
Qed.

Lemma lt_irrefl : forall n,
  ~(two_power_nat n < two_power_nat n).
Proof.
  intros. omega.
Qed.

Lemma testbit_power_two : forall n,
  Z.testbit (two_power_nat n) (Z.of_nat n) = true.
Proof.
  intros. rewrite Zsign_bit.
  destruct (zlt (two_power_nat n) (two_power_nat n)) eqn:?.
   - exfalso. clear Heqs.  apply lt_irrefl in l. exact l.
   - reflexivity.
   - generalize (two_power_nat_pos n). intros. split; try omega.
     rewrite two_power_nat_S. omega.
Qed.

Lemma lt_rewrite_larger : forall a b c,
  a < b ->
    b + b < c ->
    a + b < c.
Proof.
  intros. omega.
Qed.

Lemma testbit_single : forall ws l1 (b0 : BitV ws) (b : bool) len (bv : BitV (S ws)),
  len = length l1 ->
  to_bitv l1 = Some b0 ->
  repr (unsigned b0 + (if b then two_power_nat ws else 0)) = bv ->
   testbit bv (Z.of_nat len) = b.
Proof.
  induction ws; intros.
  - unfold two_power_nat in H1. simpl in H1. rewrite <- H1. apply to_bitv_width_zero in H0. subst. simpl. unfold unsigned.
    assert (intval b0 = 0). { apply intval_width_zero. }
    rewrite H. simpl. destruct b; auto.
  - rewrite <- H1. rewrite testbit_repr.
    Focus 2. unfold zwordsize. split. omega.
    apply Nat2Z.inj_lt. apply tobit_length in H0. omega.

    unfold unsigned. destruct b.
    + apply tobit_length in H0. rewrite <- H0 in H. rewrite H. rewrite Zsign_bit. destruct (zlt (intval b0 + two_power_nat (S ws)) (two_power_nat (S ws))) eqn :?.
      * exfalso. clear Heqs. generalize (intrange b0). intros. omega.
      * reflexivity.
      * split.
         -- generalize (intrange b0). intros. omega.
         -- generalize (intrange b0). intros. rewrite 3 two_power_nat_S. rewrite two_power_nat_S in H2. inversion H2. eapply lt_rewrite_larger in H4. omega. instantiate (1:=(2*(2*(2*two_power_nat ws)))). omega.
    + apply tobit_length in H0. rewrite <- H0 in H. rewrite H. rewrite Zsign_bit. destruct (zlt (intval b0 + two_power_nat (S ws)) (two_power_nat (S ws))) eqn :?.
      * exfalso. clear Heqs. generalize (intrange b0). intros. omega.
      * clear Heqs. generalize (intrange b0). intros. destruct (zlt (intval b0 + 0) (two_power_nat (S ws))) eqn:?.
         -- reflexivity.
         -- exfalso. replace (intval b0 + 0) with (intval b0) by omega. omega.
      * split.
         -- generalize (intrange b0). intros. omega.
         -- generalize (intrange b0). intros. replace (intval b0 + 0) with (intval b0) by omega. rewrite two_power_nat_S. omega.
Qed.

Lemma z_two_power_nat :
  forall x,
    2 ^ Z.of_nat x = two_power_nat x.
Proof.
  intros.
  rewrite two_power_nat_correct.
  rewrite Zpower_nat_Z.
  reflexivity.
Qed.

Lemma testbit_widen :
  forall wsbig wssmall zidx bv_z,
    (wsbig >= wssmall)%nat ->
    Z.of_nat wssmall > zidx ->
    testbit (@repr wsbig bv_z) zidx = testbit (@repr wssmall bv_z) zidx.
Proof.
  intros. unfold testbit.
  rewrite unsigned_repr_eq. rewrite unsigned_repr_eq.
  unfold modulus.
  replace (two_power_nat wsbig) with (2 ^ (Z.of_nat wsbig)).

  rewrite Z.mod_pow2_bits_low.
  replace (two_power_nat wssmall) with (2 ^ (Z.of_nat wssmall)).
  rewrite Z.mod_pow2_bits_low.
  reflexivity.
  omega.
  eapply z_two_power_nat; eauto.
  omega.
  eapply z_two_power_nat; eauto.
Qed.

Lemma repr_mod :
  forall {ws} z,
    ws <> O ->
    @repr ws z = @repr ws (z mod (@modulus ws)).
Proof.
  intros. unfold repr.
  eapply unsigned_eq. simpl.
  repeat rewrite Z_mod_modulus_eq by auto.
  rewrite Z.mod_mod. reflexivity. unfold modulus.
  generalize (two_power_nat_pos ws). intros. omega.
Qed.

Lemma testbit_tobitv : forall len ws l1 l2 v (bv : BitV ws),
  len = length l1 ->
    @to_bitv ws (l2 ++ v :: l1) = Some bv ->
    ebit (testbit bv (Z.of_nat len)) = v.
Proof.
  induction ws; intros.
  - inversion H0. destruct l2; simpl in *; try congruence. destruct v; inversion H2. destruct e; try congruence.
  - simpl in H0. destruct l2 eqn:?; simpl in *; try congruence. destruct v eqn:?; simpl in *; try congruence. destruct (to_bitv l1) eqn:?. inversion H0. f_equal. eapply testbit_single.
    + eauto.
    + eauto.
    + reflexivity.
    + inversion H0.
    + remember H as Hlen. clear HeqHlen. destruct e eqn:?; try congruence. destruct (to_bitv (l++v::l1)) eqn :?. eapply IHws in H; eauto.
      * subst. inversion H0. subst.
        clear H0. f_equal.
        erewrite testbit_widen.
        instantiate (1 := ws).

        Focus 3.
        eapply tobit_length in Heqo. rewrite Heqo.
        destruct l; simpl; auto. rewrite Zpos_P_of_succ_nat. omega.
        rewrite Zpos_P_of_succ_nat. rewrite app_length.
        simpl.
        unfold Z.of_nat. destruct (length l + S (length l1))%nat eqn :?. simpl. omega. destruct (length l1) eqn:?. simpl.
        apply Zgt_pos_0.
        rewrite Zpos_P_of_succ_nat. rewrite Zpos_P_of_succ_nat.  omega.

        Focus 2. omega.

        rewrite repr_mod.
        replace ((unsigned b0 + (if b then two_power_nat ws else 0)) mod modulus) with (unsigned b0).
        rewrite repr_unsigned. reflexivity.
        unfold modulus. destruct b.

        rewrite Zplus_mod. rewrite Z_mod_same_full. rewrite Zmod_small. rewrite Zmod_small. omega.

        unfold unsigned. generalize (intrange b0). intros. omega.
        rewrite Zmod_small. generalize (intrange b0). intros.
        assert (unsigned b0 + 0 = unsigned b0) by omega. rewrite H0.
        unfold unsigned. omega.
        unfold unsigned. generalize (intrange b0). intros. omega.
        assert (unsigned b0 + 0 = unsigned b0) by omega. rewrite H. rewrite Zmod_small. reflexivity.
        generalize (intrange b0). unfold unsigned. intros. omega.

        destruct ws.
        apply tobit_length in Heqo. symmetry in Heqo. rewrite length_zero_iff_nil in Heqo. destruct l. simpl in Heqo. inversion Heqo. inversion Heqo.

        auto.

      * congruence.
Qed.

Lemma tobit_frombit' :
  forall len v l1 l2 width (bv : BitV width),
    (width >= len)%nat ->
    to_bitv (l2++v::l1) = Some bv ->
    length l1 = len ->
    from_bitv' width len bv = l1.
Proof.
  induction len; intros.
  - simpl. apply length_zero_iff_nil in H1. auto.
  - destruct l1. inversion H1. simpl. f_equal. clear -H0 H1. destruct width.
    + inversion H1. eapply testbit_tobitv. instantiate (1:=l1). reflexivity. instantiate (1:=(l2++(cons v nil))). rewrite list_helper. assumption.
    + inversion H1. eapply testbit_tobitv. instantiate (1:=l1). reflexivity. instantiate (1:=(l2++(cons v nil))). rewrite list_helper. assumption.
    + eapply IHlen.
      * omega.
      * instantiate (1:=e). instantiate (1:=l2++(cons v nil)). rewrite list_helper. assumption.
      * inversion H1. reflexivity.
Qed.

Lemma tobit_frombit : forall l ws (bv : BitV ws),
  to_bitv l = Some bv -> from_bitv bv = l.
Proof.
  intros. destruct l.
  - apply tobit_length in H. simpl in H. destruct ws.
     + unfold from_bitv. simpl. reflexivity.
     + inversion H.
  - unfold from_bitv. destruct ws.
    + inversion H. destruct e; congruence.
    + simpl.
      assert (Datatypes.length l = ws). {
        eapply tobit_length in H.
        simpl in H. inversion H. auto.
      }
      erewrite tobit_frombit'; try solve [eauto].
      f_equal.
      eapply testbit_tobitv; eauto.
      instantiate (1 := nil). assumption.
      instantiate (2 := nil).
      eapply H.
Qed.

Lemma from_bitv'_widen :
  forall ws ws',
    (ws' >= ws)%nat ->
    forall bv,
      from_bitv' ws' ws (@repr ws' bv) = from_bitv' ws ws (@repr ws bv).
Proof.
  induction ws; intros.
  simpl. reflexivity.
  simpl. f_equal.
  repeat erewrite testbit_repr; eauto;
    unfold zwordsize.
  split. omega.
  eapply inj_lt. omega.
  split. omega.
  eapply inj_lt. omega.
  assert (S ws >= ws)%nat by omega.
  erewrite (IHws _ H0).
  eapply IHws; eauto. omega.
Qed.

Lemma Some_eq :
  forall {A} (x y : A),
    x = y ->
    Some x = Some y.
Proof.
  congruence.
Qed.

Definition Z_nat_ind
    (P : Z -> Prop)
    (Hbase : P 0)
    (Hneg : forall x, x < 0 -> P x)
    (Hpos : forall x, x >= 0 -> P x -> P (Z.succ x))
    (z : Z)
  : P z.
Proof.
  assert (z < 0 \/ z >= 0) by omega.
  destruct H. eauto.
  eapply natlike_ind; intros; eauto.
  eapply Hpos; auto; omega.
  omega.
Defined.

Lemma Z_add_bit_n :
  forall n a b,
    Z.testbit (a + b) n = xorb (Z.testbit a n) (Z.testbit b n).
Proof.
  induction n using Z_nat_ind; intros.
  repeat rewrite Ztestbit_base.
  eapply Z.odd_add.

  repeat rewrite Z.testbit_neg_r; eauto.
  replace (Z.succ n) with (n + 1) by omega.
  rewrite <- Z.shiftr_spec by omega.

  (* This is a true property, which might take a bit of work to prove, but is necessary for the proof below *)

Admitted.

Lemma frombit_tobit : forall l ws (bv : BitV ws),
  from_bitv bv = l -> to_bitv l = Some bv.
Proof.
  induction l; intros.
  - apply frombit_nil in H. subst. simpl. generalize (intval_width_zero).
    intros. f_equal. eapply f_equal. apply unsigned_eq. simpl. unfold unsigned. rewrite H. reflexivity.
  - unfold from_bitv in H. unfold from_bitv in IHl. destruct ws.
    + inversion H.
    + simpl in H. inversion H.
      destruct bv. replace ({| intval := intval; intrange := intrange |}) with (@repr (S ws) intval) in *.
      erewrite (from_bitv'_widen ws (S ws)) in * by omega.
      simpl.
      subst l. specialize (IHl _ _ eq_refl).
      rewrite IHl.
      simpl.
      eapply Some_eq.
      eapply same_bits_eq. intros.
      destruct ws.
      unfold two_power_nat in intrange. simpl in intrange.
      assert (intval = 0 \/ intval = 1) by omega.
      unfold zwordsize in H0.
      simpl in H0.
      assert (i = 0) by omega. subst i.
      simpl.
      destruct H2; subst; simpl; auto.
      rewrite Z_mod_modulus_eq by congruence.
      unfold modulus.
      unfold testbit.
      repeat rewrite unsigned_repr_eq.
      unfold modulus.
      repeat rewrite two_power_nat_equiv.
      unfold zwordsize in *.
      repeat rewrite Z.mod_pow2_bits_low; try omega; try (eapply inj_lt; omega).
      erewrite Z_add_bit_n.
      assert (i = Z.of_nat (S ws) \/ i < Z.of_nat (S ws)). {
        destruct H0.
        repeat rewrite Nat2Z.inj_succ in *.
        omega.
      }
      destruct H2.
      subst i. rewrite Z.mod_pow2_bits_high by omega.
      rewrite xorb_false_l.
      destruct (Z.testbit intval (Z.of_nat (S ws))).
      eapply Z.pow2_bits_true; eauto. omega.
      eapply Z.testbit_0_l.
      repeat rewrite Z.mod_pow2_bits_low; try omega; try (eapply inj_lt; omega).
      destruct (Z.testbit intval i);
        try rewrite xorb_true_l;
        try rewrite negb_true_iff;
        try rewrite xorb_false_l;
        try rewrite negb_false_iff;
      destruct (Z.testbit intval (Z.of_nat (S ws)));
        try solve [rewrite Z.pow2_bits_false; eauto; omega];
        eapply Z.testbit_0_l.

      unfold repr.
      eapply unsigned_eq. simpl.
      rewrite Z_mod_modulus_eq by congruence.
      unfold modulus.
      rewrite Zmod_small; auto. omega.
Qed.

(* Main theorem *)
Theorem tobit_frombit_equiv : forall l ws (bv : BitV ws),
  to_bitv l = Some bv <-> from_bitv bv = l.
Proof.
  intros. split.
  apply tobit_frombit.
  apply frombit_tobit.
Qed.


(**

  This file is a part of a formalisation of a subset of Core Erlang.

  In this file, we describe the capture-avoiding
  renaming and substitution for Core
  Erlang expressions. This work is based on the techniques of the Autosubst
  library [1] and Wand et al. [2].

  1: https://github.com/coq-community/autosubst
  2: https://dl.acm.org/doi/10.1145/3236782
*)

Require Export ExpSyntax
               Coq.Structures.OrderedType.

Import ListNotations.

Definition composition {A B C} (f : A -> B) (g : B -> C) : A -> C := fun x => g (f x).

Notation "f >>> g" := (composition f g)
  (at level 56, left associativity).

Definition Renaming : Type := nat -> nat.

Definition upren (ρ : Renaming) : Renaming :=
  fun n =>
    match n with
    | 0 => 0
    | S n' => S (ρ n')
    end.

Fixpoint iterate {A : Type} (f : A -> A) n a :=
  match n with
    | 0 => a
    | S n' => f (iterate f n' a)
  end.

Notation uprenn := (iterate upren).

Fixpoint rename (ρ : Renaming) (e : Exp) : Exp :=
match e with
 | ELit l => e
 | EPid p => e
 | EVar n => EVar (ρ n)
 | EFunId n => EFunId (ρ n)
 | EFun vl e => EFun vl (rename (uprenn (S (length vl)) ρ) e)
 | EApp exp l => EApp (rename ρ exp) (map (rename ρ) l)
 | ELet v e1 e2 => ELet v (rename ρ e1) (rename (upren ρ) e2)
 | ELetRec f vl b e => ELetRec f vl (rename (uprenn (1 + length vl) ρ) b)
                                    (rename (upren ρ) e)
 | ECase e1 p e2 e3 => ECase (rename ρ e1) p (rename (uprenn (pat_vars p) ρ) e2) (rename ρ e3)
 | ECons e1 e2 => ECons (rename ρ e1) (rename ρ e2)
 | ENil => e
 | VCons e1 e2 => VCons (rename ρ e1) (rename ρ e2)
 | EBIF e l => EBIF (rename ρ e) (map (rename ρ) l)
 | EReceive l => EReceive (map (fun '(p, v) => (p, rename (uprenn (pat_vars p) ρ) v)) l)
end.

Definition Substitution := nat -> Exp + nat.
(** We need to have the names for the
    identity elements explicitly, because of the shiftings (up, upn) *)

Definition idsubst : Substitution := fun x => inr x.

Definition shift (ξ : Substitution) : Substitution :=
fun s =>
  match ξ s with
  | inl exp => inl (rename (fun n => S n) exp)
  | inr num => inr (S num)
  end.

Definition up_subst (ξ : Substitution) : Substitution :=
  fun x =>
    match x with
    | 0 => inr 0
    | S x' => shift ξ x'
    end.

Notation upn := (iterate up_subst).

Fixpoint subst (ξ : Substitution) (base : Exp) : Exp :=
match base with
 | ELit l => base
 | EPid p => base
 | EVar n => match ξ n with
             | inl exp => exp
             | inr num => EVar num
             end
 | EFunId n => match ξ n with
               | inl exp => exp
               | inr num => EFunId num
               end
 | EFun vl e => EFun vl (subst (upn (S (length vl)) ξ) e)
 | EApp exp l => EApp (subst ξ exp) (map (subst ξ) l)
 | ELet v e1 e2 => ELet v (subst ξ e1) (subst (up_subst ξ) e2)
 | ELetRec f vl b e => ELetRec f vl (subst (upn (1 + length vl) ξ) b)
                                    (subst (up_subst ξ) e)
 | ECase e1 p e2 e3 => ECase (subst ξ e1) p (subst (upn (pat_vars p) ξ) e2) (subst ξ e3)
 | ECons e1 e2 => ECons (subst ξ e1) (subst ξ e2)
 | ENil => base
 | VCons e1 e2 => VCons (subst ξ e1) (subst ξ e2)
 | EBIF e l => EBIF (subst ξ e) (map (subst ξ) l)
 | EReceive l => EReceive (map (fun '(p, v) => (p, subst (upn (pat_vars p) ξ) v)) l)
end.

Definition scons {X : Type} (s : X) (σ : nat -> X) (x : nat) : X :=
  match x with
  | S y => σ y
  | _ => s
  end.
Notation "s .: σ" := (scons (inl s) σ) (at level 55, σ at level 56, right associativity).
Notation "s .:: σ" := (scons s σ) (at level 55, σ at level 56, right associativity).
Notation "s .[ σ ]" := (subst σ s)
  (at level 2, σ at level 200, left associativity,
   format "s .[ σ ]" ).
Notation "s .[ t /]" := (subst (t .: idsubst) s)
  (at level 2, t at level 200, left associativity,
   format "s .[ t /]").
Notation "s .[ t1 , t2 , .. , tn /]" :=
  (subst (scons (t1) (scons (t2) .. (scons (tn) idsubst) .. )) s)
  (at level 2, left associativity,
   format "s '[ ' .[ t1 , '/' t2 , '/' .. , '/' tn /] ']'").

Definition list_subst (l : list Exp) (ξ : Substitution) : Substitution :=
  fold_right (fun v acc => v .: acc) ξ l.

Open Scope Z_scope.
(** Tests: *)
Goal (inc 1).[ELit 0/] = inc 1. Proof. reflexivity. Qed.
Goal (inc 1).[ELit 0/] = inc 1. Proof. reflexivity. Qed.
Goal (EApp (EVar 0) [EVar 0; ELet XVar (EVar 0) (EVar 0)]).[ELit 0/]
  = (EApp (ELit 0) [ELit 0; ELet XVar (ELit 0) (EVar 0)]). Proof. reflexivity. Qed.

Compute (ELit 0 .: ELit 0 .: idsubst) 3.

Definition substcomp (ξ η : Substitution) : Substitution :=
  fun x => (* composition (substi ξ) η*)
    match ξ x with
    | inl exp => inl (subst η exp)
    | inr n   => η n
    end.

Ltac fold_upn :=
match goal with
| |- context G [up_subst (upn ?n ?ξ)] => replace (up_subst (upn n ξ)) with (upn (S n) ξ) by auto
| |- context G [upren (uprenn ?n ?ξ)] => replace (upren (uprenn n ξ)) with (uprenn (S n) ξ) by auto
end.

Ltac fold_upn_hyp :=
match goal with
| [ H : context G [up_subst (upn ?n ?ξ)] |- _ ] => replace (up_subst (upn n ξ)) with (upn (S n) ξ) in H by auto
| [ H : context G [upren (uprenn ?n ?ξ)] |- _ ] => replace (upren (uprenn n ξ)) with (uprenn (S n) ξ) in H by auto
end.

Definition ren (ρ : Renaming) : Substitution :=
  fun x => inr (ρ x).

Theorem ren_up ρ :
  ren (upren ρ) = up_subst (ren ρ).
Proof.
  extensionality x. unfold ren, upren, up_subst.
  destruct x; reflexivity.
Qed.

Corollary renn_up : forall n ρ,
  ren (uprenn n ρ) = upn n (ren ρ).
Proof.
  induction n; intros; try reflexivity.
  cbn. rewrite ren_up. rewrite IHn. auto.
Qed.

Theorem renaming_is_subst : forall e ρ,
  rename ρ e = e.[ren ρ].
Proof.
  induction e using Exp_ind2 with
    (Q := fun l => forall ρ, Forall (fun e => rename ρ e = e.[ren ρ]) l)
    (W := fun l => forall ρ, Forall (fun '(p,e) => rename ρ e = e.[ren ρ]) l)
    ; intros; try reflexivity; cbn.
  * rewrite IHe, ren_up, renn_up. auto.
  * rewrite IHe. erewrite map_ext_Forall. reflexivity. auto.
  * rewrite IHe1. rewrite <- ren_up, IHe2. auto.
  * rewrite <- ren_up, <- renn_up, IHe1, IHe2, <- ren_up. auto.
  * rewrite IHe1, IHe3, <- renn_up, IHe2. auto.
  * now rewrite IHe1, IHe2.
  * now rewrite IHe1, IHe2.
  * rewrite IHe. erewrite map_ext_Forall. reflexivity. auto.
  * erewrite map_ext_Forall. reflexivity.
    induction l; constructor.
    - destruct a. specialize (IHe (uprenn (pat_vars p) ρ)). inversion IHe. subst.
      rewrite H1, <- renn_up. reflexivity.
    - apply IHl. intros. specialize (IHe ρ0). inversion IHe. auto.
  * constructor.
  * constructor; auto.
  * constructor.
  * constructor; auto.
Qed.

Theorem idrenaming_up : upren id = id.
Proof.
  extensionality x. destruct x; auto.
Qed.

Corollary idrenaming_upn n : uprenn n id = id.
Proof.
  induction n; auto.
  simpl. rewrite IHn, idrenaming_up. auto.
Qed.

Theorem idrenaming_is_id : forall e, rename id e = e.
Proof.
  induction e using Exp_ind2 with
   (Q := fun l => Forall (fun e => rename id e = e) l)
   (W := fun l => Forall (fun '(_,e) => rename id e = e) l); intros; cbn; try rewrite idrenaming_upn; try rewrite idrenaming_up; try rewrite IHe; try rewrite IHe1; try rewrite IHe2; try rewrite IHe3; try reflexivity.
  4-7: constructor; auto.
  all: rewrite map_ext_Forall with (g := id); auto; try rewrite map_id; try reflexivity.
  induction l; auto; inversion IHe; constructor; subst; auto.
  destruct a. rewrite idrenaming_upn, H1. reflexivity.
Qed.

Theorem idsubst_up : up_subst idsubst = idsubst.
Proof.
  extensionality x. unfold up_subst. destruct x; auto.
Qed.

Corollary idsubst_upn n : upn n idsubst = idsubst.
Proof.
  induction n; auto.
  simpl. rewrite IHn, idsubst_up. auto.
Qed.

Theorem idsubst_is_id : forall e, e.[idsubst] = e.
Proof.
  induction e using Exp_ind2 with (Q := fun l => Forall (fun e => e.[idsubst] = e) l)
                                  (W := fun l => Forall (fun '(_,e) => e.[idsubst] = e) l); intros; cbn; try rewrite idsubst_upn; try rewrite idsubst_up; try rewrite IHe; try rewrite IHe1; try rewrite IHe2; try rewrite IHe3; try reflexivity.
  4-7: constructor; auto.
  all: rewrite map_ext_Forall with (g := id); auto; try rewrite map_id; try reflexivity.
  induction l; auto; inversion IHe; constructor; subst; auto.
  destruct a. rewrite idsubst_upn, H1. reflexivity.
Qed.

Lemma up_get_inl ξ x y:
  ξ x = inl y -> up_subst ξ (S x) = inl (rename (fun n => S n) y).
Proof.
  intros. unfold up_subst. unfold shift. rewrite H. auto.
Qed.

Lemma up_get_inr ξ x y:
  ξ x = inr y -> up_subst ξ (S x) = inr (S y).
Proof.
  intros. unfold up_subst. unfold shift. rewrite H. auto.
Qed.

Open Scope nat_scope.

Lemma renaming_fold m :
  (fun n => m + n) = iterate (fun x => S x) m.
Proof.
  extensionality x. induction m; cbn; auto.
Qed.

Lemma upren_subst_up : forall σ ξ,
  upren σ >>> up_subst ξ = up_subst (σ >>> ξ).
Proof.
  intros. extensionality x. unfold upren, up_subst, ">>>".
  destruct x; auto.
Qed.

Corollary uprenn_subst_upn n : forall σ ξ,
  uprenn n σ >>> upn n ξ = upn n (σ >>> ξ).
Proof.
  induction n; intros; auto.
  cbn. rewrite <- IHn, upren_subst_up. auto.
Qed.

Lemma subst_ren (σ : Renaming) (ξ : Substitution) e :
  e.[ren σ].[ξ] = e.[σ >>> ξ].
Proof.
  revert ξ σ. induction e using Exp_ind2 with
    (Q := fun l => forall ξ σ, Forall (fun e => e.[ren σ].[ξ] = e.[σ >>> ξ]) l)
    (W := fun l => forall ξ σ, Forall (fun '(_,e) => e.[ren σ].[ξ] = e.[σ >>> ξ]) l); simpl; intros; auto.
  * rewrite <- renn_up, <- ren_up. rewrite IHe, upren_subst_up, uprenn_subst_upn. auto.
  * rewrite IHe. erewrite map_map, map_ext_Forall. reflexivity. auto.
  * rewrite <- ren_up, IHe1, IHe2, upren_subst_up. auto.
  * rewrite <- renn_up, <- ren_up. rewrite IHe1, upren_subst_up, uprenn_subst_upn.
    rewrite <- ren_up, IHe2, upren_subst_up. auto.
  * now rewrite IHe1, IHe3, <- renn_up, IHe2, uprenn_subst_upn.
  * now rewrite IHe1, IHe2.
  * now rewrite IHe1, IHe2.
  * rewrite IHe. erewrite map_map, map_ext_Forall. reflexivity. auto.
  * erewrite map_map, map_ext_Forall. reflexivity. auto.
    induction l; auto; constructor.
    - clear IHl. destruct a. epose proof (IHe _ _). inversion H. subst.
      rewrite <- renn_up, H2, uprenn_subst_upn. reflexivity.
    - apply IHl. intros. specialize (IHe ξ0 σ0). inversion IHe. auto.
Qed.

Notation "σ >> ξ" := (substcomp σ ξ) (at level 56, left associativity).

Theorem upren_comp : forall σ ρ,
  upren σ >>> upren ρ = upren (σ >>> ρ).
Proof.
  intros. unfold upren, ">>>". extensionality n. destruct n; auto.
Qed.

Corollary uprenn_comp : forall n σ ρ,
  uprenn n σ >>> uprenn n ρ = uprenn n (σ >>> ρ).
Proof.
  induction n; intros; auto. simpl. rewrite upren_comp, IHn. auto.
Qed.

Theorem rename_up : forall e n σ ρ,
  rename (uprenn n σ) (rename (uprenn n ρ) e) = rename (uprenn n (ρ >>> σ)) e.
Proof.
  induction e using Exp_ind2 with
    (Q := fun l => forall n σ ρ, Forall (fun e => rename (uprenn n σ) (rename (uprenn n ρ) e) = rename (uprenn n (ρ >>> σ)) e) l)
    (W := fun l => forall n σ ρ, Forall (fun '(_,e) => rename (uprenn n σ) (rename (uprenn n ρ) e) = rename (uprenn n (ρ >>> σ)) e) l);
  intros; simpl; auto.
  * rewrite <- uprenn_comp. reflexivity.
  * rewrite <- uprenn_comp. reflexivity.
  * repeat fold_upn. rewrite IHe, uprenn_comp. auto.
  * erewrite IHe, map_map, map_ext_Forall. reflexivity. auto.
  * rewrite IHe1. do 2 fold_upn. rewrite IHe2. auto.
  * repeat fold_upn. rewrite IHe1, IHe2, uprenn_comp. auto.
  * now rewrite IHe1, IHe2, IHe3, <- uprenn_comp.
  * now rewrite IHe1, IHe2.
  * now rewrite IHe1, IHe2.
  * erewrite IHe, map_map, map_ext_Forall. reflexivity. auto.
  * erewrite map_map, map_ext_Forall. reflexivity. auto.
    induction l; auto; constructor.
    - clear IHl. destruct a. epose proof (IHe _ _ _). inversion H. subst.
      rewrite <- uprenn_comp, H2. reflexivity.
    - apply IHl. intros. epose proof (IHe _ _ _). inversion H. eauto.
Qed.

Theorem rename_comp :
  forall e σ ρ, rename σ (rename ρ e) = rename (ρ >>> σ) e.
Proof.
  induction e using Exp_ind2 with
    (Q := fun l => forall σ ρ, Forall (fun e => rename σ (rename ρ e) = rename (ρ >>> σ) e) l)
    (W := fun l => forall σ ρ, Forall (fun '(_,e) => rename σ (rename ρ e) = rename (ρ >>> σ) e) l); intros; auto; cbn.
  * do 3 fold_upn. now rewrite rename_up.
  * now erewrite IHe, map_map, map_ext_Forall.
  * now rewrite IHe1, IHe2, upren_comp.
  * do 2 fold_upn. now rewrite IHe1, IHe2, uprenn_comp, upren_comp.
  * now rewrite IHe1, IHe3, rename_up.
  * now rewrite IHe1, IHe2.
  * now rewrite IHe1, IHe2.
  * now erewrite IHe, map_map, map_ext_Forall.
  * erewrite map_map, map_ext_Forall. reflexivity. auto.
    induction l; auto; constructor.
    - clear IHl. destruct a. epose proof (IHe _ _). inversion H. subst.
      rewrite <- uprenn_comp, H2. reflexivity.
    - apply IHl. intros. epose proof (IHe _ _). inversion H. eauto.
Qed.

Lemma subst_up_upren : forall σ ξ,
  up_subst ξ >> ren (upren σ) = up_subst (ξ >> ren σ).
Proof.
  intros. extensionality x. unfold upren, up_subst, ">>", shift.
  destruct x; auto. destruct (ξ x) eqn:P; auto.
  rewrite <- renaming_is_subst, <- renaming_is_subst. f_equiv.
  replace (fun n : nat => match n with
                       | 0 => 0
                       | S n' => S (σ n')
                       end) with (upren σ) by auto.
  rewrite rename_comp, rename_comp. f_equiv.
Qed.

Lemma subst_upn_uprenn : forall n σ ξ,
  upn n ξ >> ren (uprenn n σ) = upn n (ξ >> ren σ).
Proof.
  induction n; intros; auto. simpl.
  rewrite subst_up_upren, IHn. auto.
Qed.

Lemma ren_subst (ξ : Substitution) (σ : Renaming) e :
  e.[ξ].[ren σ] = e.[ξ >> ren σ].
Proof.
  revert ξ σ. induction e using Exp_ind2
    with (Q := fun l => forall ξ σ, Forall (fun e => e.[ξ].[ren σ] = e.[ξ >> ren σ]) l)
         (W := fun l => forall ξ σ, Forall (fun '(_,e) => e.[ξ].[ren σ] = e.[ξ >> ren σ]) l);
  simpl; intros; auto.
  * unfold ">>", ren. destruct (ξ n) eqn:P; auto.
  * unfold ">>", ren. destruct (ξ n) eqn:P; auto.
  * do 3 fold_upn. now rewrite <- renn_up, <- subst_upn_uprenn, IHe.
  * now erewrite IHe, map_map, map_ext_Forall.
  * now rewrite <- ren_up, <- subst_up_upren, IHe1, IHe2.
  * do 2 fold_upn. rewrite <- renn_up, <- subst_upn_uprenn, IHe1.
    replace (up_subst (ξ >> ren σ)) with (up_subst ξ >> ren (upren σ)) by apply subst_up_upren. (* rewrite does not work here for some reason *)
    now rewrite <- IHe2, <- ren_up, <-subst_up_upren.
  * now rewrite IHe1, <- renn_up, <- subst_upn_uprenn, IHe2, IHe3.
  * now rewrite IHe1, IHe2.
  * now rewrite IHe1, IHe2.
  * now erewrite IHe, map_map, map_ext_Forall.
  * erewrite map_map, map_ext_Forall. reflexivity. auto.
    induction l; auto; constructor.
    - clear IHl. destruct a. epose proof (IHe _ _). inversion H. subst.
      rewrite <- renn_up, <- subst_upn_uprenn, H2. reflexivity.
    - apply IHl. intros. epose proof (IHe _ _). inversion H. eauto.
Qed.

Lemma up_comp ξ η :
  up_subst ξ >> up_subst η = up_subst (ξ >> η).
Proof.
  extensionality x.
  unfold ">>". cbn. unfold up_subst, shift. destruct x; auto.
  destruct (ξ x) eqn:P; auto.
  do 2 rewrite renaming_is_subst. rewrite ren_subst, subst_ren.
  unfold ren. f_equiv. f_equiv. extensionality n.
  unfold ">>>", ">>", up_subst, shift. destruct (η n) eqn:P0; auto.
  rewrite renaming_is_subst. auto.
Qed.

Corollary upn_comp : forall n ξ η,
  upn n ξ >> upn n η = upn n (ξ >> η).
Proof.
  induction n; intros; auto. simpl. rewrite <- IHn, up_comp. auto.
Qed.

Lemma subst_comp ξ η e :
  e.[ξ].[η] = e.[ξ >> η].
Proof.
  revert ξ η. induction e using Exp_ind2 with
    (Q := fun l => forall ξ η, Forall (fun e => e.[ξ].[η] = e.[ξ >> η]) l)
    (W := fun l => forall ξ η, Forall (fun '(_,e) => e.[ξ].[η] = e.[ξ >> η]) l); simpl; intros; auto.
  * unfold ">>". break_match_goal; auto.
  * unfold ">>". break_match_goal; auto.
  * do 3 fold_upn. now rewrite IHe, upn_comp.
  * now erewrite IHe, map_map, map_ext_Forall.
  * now rewrite IHe1, IHe2, up_comp.
  * do 3 fold_upn. now rewrite IHe1, IHe2, upn_comp, up_comp.
  * now rewrite IHe1, IHe2, upn_comp, IHe3.
  * now rewrite IHe1, IHe2.
  * now rewrite IHe1, IHe2.
  * now erewrite IHe, map_map, map_ext_Forall.
  * erewrite map_map, map_ext_Forall. reflexivity. auto.
    induction l; auto; constructor.
    - clear IHl. destruct a. epose proof (IHe _ _). inversion H. subst.
      rewrite H2, upn_comp. reflexivity.
    - apply IHl. intros. epose proof (IHe _ _). inversion H. eauto.
Qed.

Theorem rename_subst_core : forall e v,
  (rename (fun n : nat => S n) e).[v .:: idsubst] = e.
Proof.
  intros.
  rewrite renaming_is_subst, subst_comp. cbn.
  unfold substcomp, ren. cbn. rewrite idsubst_is_id. reflexivity.
Qed.

Theorem rename_subst : forall e v,
  (rename (fun n : nat => S n) e).[v/] = e.
Proof.
  intros. apply rename_subst_core.
Qed.

Lemma scons_substcomp_core v ξ η :
  (v .:: ξ) >> η = match v with
                   | inl exp => inl (exp.[η])
                   | inr n => η n
                   end .:: (ξ >> η).
Proof.
  extensionality x. unfold scons, substcomp. now destruct x.
Qed.

Lemma scons_substcomp v ξ η :
  (v .: ξ) >> η = v.[η] .: (ξ >> η).
Proof.
  apply scons_substcomp_core.
Qed.

Lemma scons_substcomp_list ξ η vals :
  (list_subst vals ξ) >> η = list_subst (map (subst η) vals) (ξ >> η).
Proof.
  induction vals; simpl. auto.
  rewrite scons_substcomp, IHvals. auto.
Qed.

Lemma substcomp_scons_core v ξ η :
  up_subst ξ >> v .:: η = v .:: (ξ >> η).
Proof.
  extensionality x. unfold scons, substcomp, up_subst. destruct x; auto.
  unfold shift. destruct (ξ x) eqn:P; auto.
  rewrite renaming_is_subst, subst_comp. f_equiv.
Qed.

Lemma substcomp_scons v ξ η :
  up_subst ξ >> v .: η = v .: (ξ >> η).
Proof.
  apply substcomp_scons_core.
Qed.

Corollary substcomp_list l ξ η :
  upn (length l) ξ >> list_subst l η = list_subst l (ξ >> η).
Proof.
  induction l; simpl; auto.
  * now rewrite substcomp_scons, IHl.
Qed.

Theorem subst_extend_core : forall ξ v,
  (up_subst ξ) >> (v .:: idsubst) = v .:: ξ.
Proof.
  intros. unfold substcomp. extensionality x. destruct x; auto.
  cbn. break_match_goal.
  * unfold shift in Heqs. break_match_hyp; inversion Heqs. rewrite rename_subst_core. auto.
  * unfold shift in Heqs. break_match_hyp; inversion Heqs. cbn. reflexivity.
Qed.

Theorem subst_extend : forall ξ v,
  (up_subst ξ) >> (v .: idsubst) = v .: ξ.
Proof.
  intros. apply subst_extend_core.
Qed.

Corollary subst_list_extend : forall n ξ vals, length vals = n ->
  (upn n ξ) >> (list_subst vals idsubst) = list_subst vals ξ.
Proof.
  induction n; intros.
  * apply length_zero_iff_nil in H. subst. cbn. unfold substcomp. extensionality x.
    break_match_goal; try rewrite idsubst_is_id; try reflexivity.
  * simpl. apply eq_sym in H as H'. apply element_exist in H'. destruct H', H0. subst.
    simpl. rewrite substcomp_scons. rewrite IHn; auto.
Qed.

Theorem list_subst_lt : forall n vals ξ, n < length vals ->
  list_subst vals ξ n = inl (nth n vals (ELit (Int 0))).
Proof.
  induction n; intros; destruct vals.
  * inversion H.
  * simpl. auto.
  * inversion H.
  * simpl in H. apply Lt.lt_S_n in H. eapply IHn in H. simpl. exact H.
Qed.

Theorem list_subst_ge : forall n vals ξ, n >= length vals ->
  list_subst vals ξ n = ξ (n - length vals).
Proof.
  induction n; intros; destruct vals.
  * simpl. auto.
  * inversion H.
  * cbn. auto.
  * simpl in H. apply le_S_n in H. eapply IHn in H. simpl. exact H.
Qed.

Corollary list_subst_get_possibilities : forall n vals ξ,
  list_subst vals ξ n = inl (nth n vals (ELit (Int 0))) /\ n < length vals
\/
  list_subst vals ξ n = ξ (n - length vals) /\ n >= length vals.
Proof.
  intros. pose (Nat.lt_decidable n (length vals)). destruct d.
  * left. split. now apply list_subst_lt. auto.
  * right. split. apply list_subst_ge. lia. lia.
Qed.

Lemma substcomp_id_r :
  forall ξ, ξ >> idsubst = ξ.
Proof.
  unfold ">>". intros. extensionality x.
  break_match_goal; auto. rewrite idsubst_is_id. auto.
Qed.

Lemma substcomp_id_l :
  forall ξ, idsubst >> ξ = ξ.
Proof.
  unfold ">>", idsubst. intros. extensionality x. auto.
Qed.

Lemma subst_ren_scons : forall (ξ : Substitution) e,
  ξ 0 = inl e ->
  (e .: (fun n : nat => n + 1) >>> ξ) = ξ.
Proof.
  intros. extensionality x. unfold ">>>", scons. destruct x; auto.
  rewrite Nat.add_comm. reflexivity.
Qed.

Lemma ren_up_subst :
  forall ξ,
    ren (fun n => S n) >> up_subst ξ = ξ >> ren (fun n => S n).
Proof.
  intros. extensionality x; cbn.
  unfold shift. unfold ">>".
  break_match_goal; cbn.
  now rewrite <- renaming_is_subst.
  reflexivity.
Qed.

Lemma ren_scons :
  forall ξ f, forall x, ren (fun n => S (f n)) >> x .: ξ = ren (fun n => f n) >> ξ.
Proof.
  intros.
  extensionality k. cbn. auto.
Qed.

Lemma rename_upn_list_subst :
  forall m ξ vals, length vals = m ->
    ren (fun n => m + n) >> (upn m ξ >> list_subst vals idsubst) = ξ.
Proof.
  intros.
  rewrite (subst_list_extend m ξ vals H).
  generalize dependent vals. induction m; intros; cbn.
  - replace (ren (fun n => n)) with idsubst by auto. apply length_zero_iff_nil in H.
    subst. cbn. now rewrite substcomp_id_l.
  - assert (length vals = S m) by auto.
    apply eq_sym, element_exist in H as [x0 [xs H1]]. subst. inversion H0.
    replace (list_subst (x0 :: xs) ξ) with (x0 .: list_subst xs ξ) by auto.
    specialize (IHm xs H1).
    erewrite H1, ren_scons; eauto.
Qed.

Ltac fold_list_subst :=
match goal with
| |- context G [?x .: list_subst ?xs ?ξ] => replace (x .: list_subst xs ξ) with (list_subst (x :: xs) ξ) by auto
end.

Ltac fold_list_subst_hyp :=
match goal with
| [H: context G [?x .: list_subst ?xs ?ξ] |- _] => replace (x .: list_subst xs ξ) with (list_subst (x :: xs) ξ) in H by auto
end.

Lemma substcomp_assoc :
  forall ξ σ η, (ξ >> σ) >> η = ξ >> (σ >> η).
Proof.
  intros. extensionality x. unfold ">>".
  destruct (ξ x) eqn:D1; auto.
  rewrite subst_comp. reflexivity.
Qed.