Require Import ZArith PArith.
Require Import ASN1FP.Aux.StructTactics ASN1FP.Aux.Bits.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Lia.

Require Import Coq.ZArith.ZArith.
Require Import ASN1FP.Aux.Zlib.

Open Scope Z.

Definition nblen (n : Z) : nat := Z.to_nat (Z.log2 n + 1).

Inductive container (l : nat) :=
  cont (v : Z) (N : 0 <= v) (L : (nblen v <= l)%nat) : container l.

Definition cast_cont {l1 l2 : nat} (c1 : container l1) (E : l1 = l2) : container l2 :=
  match E in _ = p return container p with
  | eq_refl => c1
  end.

Hint Rewrite
     two_power_nat_correct
     Zpower_nat_Z
     two_power_nat_equiv
     Z2Nat.id
  : rew_Z_bits.

Fact join_nneg (l2 : nat) {v1 v2 : Z} (N1 : 0 <= v1) (N2 : 0 <= v2) :
  0 <= v1 * two_power_nat l2 + v2.
Proof.
  autorewrite with rew_Z_bits.
  remember (Z.of_nat l2) as p.
  remember (2 ^ p) as p2.
  assert(0 <= p2).
  {
    subst.
    apply Z.pow_nonneg.
    lia.
  }
  eauto with zarith.
Qed.

Lemma Zmul_lt_trans (x y a b : Z) :
  x <= y ->
  a < x * b ->
  0 <= b ->
  a < y * b.
Proof.
  intros XY A B.
  replace y with (x + (y - x)) by lia.
  assert (0 <= y - x) by lia.
  remember (y - x) as c; clear Heqc XY y.
  rewrite Z.mul_add_distr_r.
  generalize (Z.mul_nonneg_nonneg c b H B).
  lia.
Qed.

Lemma Zpow2_positive (x : Z) :
  0 <= x ->
  1 <= 2 ^ x.
Proof.
  intros X.
  replace 1 with (2 ^ 0).
  apply Z.log2_le_pow2.
  apply Z.pow_pos_nonneg.
  all: try lia.
  apply Z.log2_nonneg.
Qed.

Fact join_nblen
      {l1 l2 : nat}
      {v1 v2 : Z}
      (N1 : 0 <= v1) (N2 : 0 <= v2)
      (L1 : (nblen v1 <= l1)%nat)
      (L2 : (nblen v2 <= l2)%nat):
  (nblen (v1 * two_power_nat l2 + v2) <= l1 + l2)%nat.
Proof.
  unfold nblen in *.
  apply Nat2Z.inj_le.
  rewrite Z2Nat.id.
  -
    apply Nat2Z.inj_le in L1.
    apply Nat2Z.inj_le in L2.
    rewrite Z2Nat.id in L1.
    rewrite Z2Nat.id in L2.
    +
      assert (Z.log2 (v1 * two_power_nat l2 + v2) < Z.of_nat (l1 + l2)); [|lia].
      generalize (Nat2Z.is_nonneg l1); intros P1.
      generalize (Nat2Z.is_nonneg l2); intros P2.
      rewrite Nat2Z.inj_add, two_power_nat_equiv.
      remember (Z.of_nat l1) as z1.
      remember (Z.of_nat l2) as z2.
      clear Heqz1 Heqz2 l1 l2.
      assert (Q1 : Z.log2 v1 < z1) by lia; clear L1.
      assert (Q2 : Z.log2 v2 < z2) by lia; clear L2.
      assert (Z1 : 1 <= 2 ^ z1) by (apply Zpow2_positive; auto).
      assert (Z2 : 1 <= 2 ^ z2) by (apply Zpow2_positive; auto).
      destruct (Z.eq_dec v1 0); [subst; simpl; lia|].
      assert (W1 : 0 < v1) by lia; clear N1 n.
      apply Z.log2_lt_pow2 in Q1; auto.
      assert (T : 0 < v1 * 2 ^ z2 + v2).
      {
        remember (2 ^ z2) as p2.
        assert (0 < v1 * p2) by (apply Z.mul_pos_pos; lia).
        lia.
      }
      destruct (Z.eq_dec v2 0).
      assert (v1 * 2 ^ z2 + v2 < 2 ^ (z1 + z2)).
      rewrite Z.pow_add_r by auto.
      apply Z.mul_lt_mono_pos_r with (p := 2 ^ z2) in Q1; try lia.
      apply Z.log2_lt_pow2 in H; try apply T.
      clear T.
      apply H.
      assert (W2 : 0 < v2) by lia; clear N2 n.

      apply Z.log2_lt_pow2 in Q2.
      apply Z.log2_lt_pow2; [apply T|].
      rewrite Z.pow_add_r by auto.
      remember (2 ^ z1) as p1; remember (2 ^ z2) as p2;
        clear Heqp1 Heqp2 P1 P2 z1 z2.
      assert (V1 : v1 <= p1 - 1) by lia;
        assert (V2 : v2 <= p2 - 1) by lia;
        clear Q1 Q2.
      apply Z.mul_le_mono_nonneg_r with (p := p2) in V1; lia.
      apply W2.
    +
      assert(0<=Z.log2 v2) by apply Z.log2_nonneg; lia.
    +
      assert(0<=Z.log2 v1) by apply Z.log2_nonneg; lia.
  -
    assert(0<=(Z.log2 (v1 * two_power_nat l2 + v2))) by apply Z.log2_nonneg.
    lia.
Qed.

Definition join_cont {l1 l2 : nat} (c1 : container l1) (c2 : container l2)
  : container (l1 + l2) :=
  match c1, c2 with
  | cont _ v1 N1 L1, cont _ v2 N2 L2 =>
    cont (l1 + l2)
         (v1 * two_power_nat l2 + v2)
         (join_nneg l2 N1 N2)
         (join_nblen N1 N2 L1 L2)
  end.

Fact split_div_nneg (l2 : nat) {v : Z} (N : 0 <= v):
  0 <= v / two_power_nat l2.
Proof.
  autorewrite with rew_Z_bits.
  apply Z.div_pos; auto.
  apply Z.pow_pos_nonneg; lia.
Qed.

Fact split_mod_nneg (l2 : nat) {v : Z} (N : 0 <= v) :
  0 <= v mod two_power_nat l2.
Proof.
  autorewrite with rew_Z_bits.
  assert(0 < 2 ^ Z.of_nat l2) by (apply Z.pow_pos_nonneg; lia).
  apply Z.mod_pos_bound, H.
Qed.

Fact split_div_nblen {l1 l2 : nat} {v : Z} (N : 0 <= v)
      (B : (nblen v <= l1 + l2)%nat) :
  (0 < l1)%nat ->
  (0 < l2)%nat ->
  (nblen (v / two_power_nat l2) <= l1)%nat.
Proof.
  intros L1 L2.
  unfold nblen in *.
  apply Nat2Z.inj_le.
  apply Nat2Z.inj_le in B.
  rewrite Z2Nat.id in *;
    [
      |(generalize (Z.log2_nonneg v); lia)
      |(generalize (Z.log2_nonneg (v / two_power_nat l2)); lia)
    ].
  rewrite Nat2Z.inj_add in B; rewrite two_power_nat_equiv.
  assert (N1 : 0 < Z.of_nat l1) by lia; remember (Z.of_nat l1) as n1; clear Heqn1 L1 l1.
  assert (N2 : 0 < Z.of_nat l2) by lia; remember (Z.of_nat l2) as n2; clear Heqn2 L2 l2.
  assert (V : Z.log2 v < n1 + n2) by lia; clear B.

  destruct (Z.eq_dec 0 v); [subst; simpl; lia|].
  assert (P : 0 < v) by lia; clear N n.

  apply Z.log2_lt_pow2 in V; auto.
  rewrite Z.pow_add_r in V; try lia.
  rewrite Z.mul_comm in V.
  apply Z.div_lt_upper_bound in V.
  - destruct (Z_lt_le_dec 0 (v / 2 ^ n2)).
    apply Z.log2_lt_pow2 in V.
    + lia.
    + auto.
    + rewrite Z.log2_nonpos; lia.
  - replace 0 with (0 ^ n2) by
        (rewrite Z.pow_0_l by auto; reflexivity).
    apply Z.pow_lt_mono_l; lia.
Qed.

Fact split_mod_nblen {l1 l2 : nat} {v : Z} (N : 0 <= v)
      (B : (nblen v <= l1 + l2)%nat) :
  (0 < l1)%nat ->
  (0 < l2)%nat ->
  (nblen (v mod two_power_nat l2) <= l2)%nat.
Proof.
  intros L1 L2.
  clear L1 B l1.
  unfold nblen.
  apply Nat2Z.inj_le.
  rewrite two_power_nat_equiv.
  assert (N2 : 0 < Z.of_nat l2) by lia; remember (Z.of_nat l2) as n2; clear Heqn2 L2 l2.
  rewrite Z2Nat.id; [| generalize (Z.log2_nonneg (v mod 2 ^ n2)); lia].
  assert (0 < 2 ^ n2) by (apply Z.pow_pos_nonneg; lia).
  generalize (Z.mod_pos_bound v (2 ^ n2) H);
    clear H; intros H; destruct H.
  destruct (Z.eq_dec (v mod 2 ^ n2) 0); [rewrite e; simpl; lia |].
  assert (P : 0 < v mod 2 ^ n2) by lia; clear H n.
  apply Z.log2_lt_pow2 in H0; lia.
Qed.

Definition split_cont {l1 l2: nat} (c : container (l1+l2)) (L1 : (0 < l1)%nat) (L2 : (0 < l2)%nat)
  : container l1 * container l2 :=
  match c with
  | cont _ v N B =>
    ((cont l1
           (v / (two_power_nat l2))
           (split_div_nneg l2 N)
           (split_div_nblen N B L1 L2)),
     (cont l2
           (v mod (two_power_nat l2))
           (split_mod_nneg l2 N)
           (split_mod_nblen N B L1 L2)))
  end.

Lemma nblen_positive (x : Z) :
  (0 < nblen x)%nat.
Proof.
  unfold nblen.
  generalize (Z.log2_nonneg x); intros.
  replace 0%nat with (Z.to_nat 0) by trivial.
  apply Z2Nat.inj_lt; lia.
Qed.

Lemma cont_len_positive {l : nat} (c : container l) :
  (0 < l)%nat.
Proof.
  destruct c.
  generalize (nblen_positive v).
  lia.
Qed.

Definition Z_of_cont {l : nat} (c : container l) :=
  match c with cont _ v _ _ => v end.

(** * common container lengths *)

Definition cont1 := container 1.
Definition cont2 := container 2.
Definition cont8 := container 8.

Definition b1_cont (v : Z) (N : 0 <= v) (L : (nblen v <= 1)%nat) : cont1
:= cont 1 v N L.
Definition b2_cont (v : Z) (N : 0 <= v) (L : (nblen v <= 2)%nat) : cont2
:= cont 2 v N L.
Definition b8_cont (v : Z) (N : 0 <= v) (L : (nblen v <= 8)%nat) : cont8
:= cont 8 v N L.

(* create and append containers of common lengths *)
Definition append_b1_cont (v : Z) (N : 0 <= v) (L : (nblen v <= 1)%nat)
        {l : nat} (c : container l)
: container (1 + l) := join_cont (b1_cont v N L) c.

Definition append_b2_cont (v : Z) (N : 0 <= v) (L : (nblen v <= 2)%nat)
        {l : nat} (c : container l)
: container (2 + l) := join_cont (b2_cont v N L) c.

Definition append_b8_cont (v : Z) (N : 0 <= v) (L : (nblen v <= 8)%nat)
        {l : nat} (c : container l)
: container (8 + l) := join_cont (b8_cont v N L) c.

(* common operations *)
Definition c2z {l : nat} (c : container l) := Z_of_cont c.
Definition c2n {l : nat} (c : container l) := Z.to_nat (c2z c).

(* cut containers of common lengths (from left *)
Fact O_lt_1 : (0 < 1)%nat.
Proof. lia. Qed.

Definition cut_b1_cont {l : nat} (c : container (1 + l)) (L : (0 < l)%nat)
: cont1 * container l := split_cont c O_lt_1 L.

Fact O_lt_2 : (0 < 2)%nat.
Proof. lia. Qed.

Definition cut_b2_cont {l : nat} (c : container (2 + l)) (L : (0 < l)%nat)
: cont2 * container l := split_cont c O_lt_2 L.

Fact O_lt_8 : (0 < 8)%nat.
Proof. lia. Qed.

Definition cut_b8_cont {l : nat} (c : container (8 + l)) (L : (0 < l)%nat)
: cont8 * container l := split_cont c O_lt_8 L.

Ltac uncont :=
  unfold c2n, c2z, Z_of_cont in *; try reflexivity.


(**
挿入ソートの証明駆動開発
 *)

(** * はじめに *)

(**
挿入ソート (Insertion Sort) を Coq の 「Programコマンド」を使って証明駆動開発してみます。

プログラムの定義や検証の方法は以下のサイトに基づいていますから、併読してください。
ただし、証明そのものは少し違うところがあります。

#
プログラミング Coq 証明駆動開発入門(1)
#
*)

(**
ソースコードは、
#
ここ

にあります。
 *)

Require Import List.
Require Import Arith.
Require Import Sorting.Permutation.
Require Import Sorting.Sorted.
Require Import Program.

(** * 準備 *)

(** 証明に perm と sort のコンストラクタを使いますから、
これらをHintデータベースに追加します。 *)

Hint Resolve perm_nil perm_skip perm_swap perm_trans Permutation_cons : perm.

Hint Resolve LSorted_nil LSorted_cons1 LSorted_consn : sort.

(** さらに不等号についての補題

[n < m -> n <= m]

をHintデータベースに追加します。*)

Hint Resolve lt_le_weak : lt_le.

(** * insert の定義と証明 *)

(**
最初に挿入関数 [insert] を証明付きで定義します。
定義自体は最初の参考文献とおなじです。

この関数では、リスト [l] に [a] を挿入した結果が関数の値 [l'] になるので、
これらをソートのために使う場合は次の関係を満たす必要があります。

(1) [a] と [l] を結合(cons)したものと、[l'] が Permutation の関係にあること。

(2) [l] がソートされているなら、[l'] もソートされていること。

のふたつです。これに加えて

(3) [a] と リスト [l] と [l'] との関係として、

(3.1) [a] は [l'] の先頭である（[a]が[l]の先頭に置かれる場合）、または、

(3.2) [l] と [l'] の先頭が同じ（[a]が[l]の途中以降に挿入される場合）

を追加しておきます。以上を連言でつないでいます。
それを関数の値に記載して、証明することになります。

関数の定義では、サブタイプコアーションが働くので、insert の再帰呼び出しでは、
証明の部分を無視して、リストだけを返す関数として使うことができます。
*)

Program Fixpoint insert (a : nat) (l : list nat) {struct l} :
  {l' : list nat | Permutation (a :: l) l' /\
                   (LocallySorted le l -> LocallySorted le l') /\
                   (hd a l' = a \/ hd a l' = hd a l)} :=
  match l with
  | nil => a :: nil
  | x :: l' =>
    if le_gt_dec a x then
      a :: x :: l'
  else
    x :: (insert a l')
  end.
Obligation 1.
Proof.
  now auto with sort.
Defined.
Obligation 2.
  now auto with sort.
Defined.
Obligation 3.
Proof.
  split.
  - rewrite perm_swap.
    now auto with perm.
  - split.
    + intros Hxl'.
      assert (LocallySorted le l') as H1 by (inversion Hxl'; auto with sort).
      assert (LocallySorted le x0) as H2 by auto.
      destruct x0.
      * now auto with sort.
      * inversion Hxl'; simpl in o; destruct o; subst;
          now auto with sort lt_le.
    + now auto.
Defined.

(**
rewrite では、通常の [=] ではなく、
Permutation に対する rewrite が行われていることに注意してください。

ゴール [Permutation (a :: x :: l') (x :: x0)] に対して、
[[
perm_swap : forall (A : Type) (x y : A) (l : list A),
       Permutation (y :: x :: l) (x :: y :: l)
]]
でrewriteすることで、ゴールのPermutationの左側が書き換えられ、

[Permutation (x :: a :: l') (x :: x0)]

が得られます。
それができるのは、Import している [Sorting/Permutation.v] のなかで、
[Instance Permutation_Equivalence] が定義されているからですが、
このあたりについては、

#
A Gentle Introduction to Type Classes and Relations in Coq
#

を参照してください。
 *)

(**
また、[auto with sort lt_le] では、
[apply LSorted_consn] と [apply lt_le] が実行されています。
 *)

(**
実行してみます。証明の部分を取り除いて値だけを取り出すために、
[proj1_sig] の演算子 [`] を使います。
*)

Compute ` (insert 1 [2; 3]).             (** ==> [[1; 2; 3]]  *)

Compute ` (insert 2 [1; 3]).             (** ==> [[1; 2; 3]]  *)

(**
OCaml のコードを生成してみます。証明の部分のコードは含まれていません。
 *)

Extraction insert.
(**
[[
val insert : nat -> nat list -> nat list

let rec insert a = function
| Nil -> Cons (a, Nil)
| Cons (x, l') ->
  (match le_gt_dec a x with
   | Left -> Cons (a, (Cons (x, l')))
   | Right -> Cons (x, (insert a l')))
]]
*)

(** * Insertion Sort の定義と証明  *)

(**
最後にソート関数 isort を証明付きで定義します。
定義自体は最初の参考文献とおなじです。

また、その正しさの証明も同じで、ソート前の引数 [l] と、ソート結果の関数値 [l'] に対して、

(1) [l] と [l'] が Permutation の関係であること。

(2) [l'] がソートされていること。

のふたつで、それらを連言でつないでいます。
それを関数の値に記載して、証明することになります。

関数の定義では、サブタイプコアーションが働くので、isort の再帰呼び出しのみならず、
下位処理として呼び出す insert もリストだけを返す関数として使うことができます。
  *)

Program Fixpoint isort l {struct l} :
  {l' : list nat | Permutation l l' /\ LocallySorted le l'} :=
  match l with
  | nil => nil
  | a :: l' => insert a (isort l')
  end.
Obligations.
Obligation 1.
Proof.
  now auto with sort perm.
Defined.
Obligation 2.
Proof.
  remember (insert a x).
  destruct s; subst.
  destruct a0; subst.
  simpl.
  split.
  - eauto with perm.
  - destruct a0; now auto.
Defined.

(**
実行してみます。証明の部分を取り除いて値だけを取り出すために、
[proj1_sig] の演算子 [`] を使います。
*)

Compute ` (isort [0; 2; 1; 3]).             (** ==> [[0; 1; 2; 3]]  *)

(**
OCaml のコードを生成してみます。証明の部分のコードは含まれていません。
 *)

Extraction isort.
(**
[[
val isort : nat list -> nat list

let rec isort = function
| Nil -> Nil
| Cons (a, l') -> insert a (isort l')
]]
*)

(* END *)


Require Export TopologicalSpaces.
From ZornsLemma Require Export InverseImage.
Require Export Continuity.

(* Also called "final topology". Its construction is dual
   (in the categorical sense) to the construction of the weak topology. *)

Section StrongTopology.

Variable A:Type.
Variable X:forall a:A, TopologicalSpace.
Variable Y:Type.
Variable f:forall a:A, point_set (X a) -> Y.

Definition strong_open (S:Ensemble Y) : Prop :=
  forall a:A, open (inverse_image (f a) S).

Definition StrongTopology : TopologicalSpace.
refine (Build_TopologicalSpace Y strong_open _ _ _).
- intros.
  red; intro.
  assert (inverse_image (f a) (FamilyUnion F) =
    IndexedUnion (fun U:{ U:Ensemble Y | In F U } =>
                   inverse_image (f a) (proj1_sig U))).
  { apply Extensionality_Ensembles; red; split; red; intros.
    - destruct H0.
      inversion H0.
      exists (exist _ S H1).
      constructor.
      exact H2.
    - destruct H0. destruct H0.
      destruct a0 as [U].
      constructor.
      exists U; trivial.
  }
  rewrite H0.
  apply open_indexed_union.
  intros.
  destruct a0 as [U].
  simpl.
  apply H; trivial.
- intros.
  red; intro.
  rewrite inverse_image_intersection.
  apply open_intersection2; (apply H || apply H0).
- red; intro.
  rewrite inverse_image_full.
  apply open_full.
Defined.

Lemma strong_topology_makes_continuous_funcs:
  forall a:A, continuous (f a) (Y:=StrongTopology).
Proof.
intros.
red.
intros.
auto.
Qed.

Lemma strong_topology_strongest: forall (T':Ensemble Y->Prop)
  (H1:_) (H2:_) (H3:_),
  (forall a:A, continuous (f a)
          (Y:=Build_TopologicalSpace Y T' H1 H2 H3)) ->
  forall V:Ensemble Y, T' V -> strong_open V.
Proof.
intros.
unfold continuous in H.
simpl in H.
red; intros; apply H; trivial.
Qed.

Lemma strong_topology_continuous_char (Z : TopologicalSpace)
      (g : point_set StrongTopology -> point_set Z) :
  continuous g <->
  forall a, continuous (compose g (f a)).
Proof.
split.
- intros. unfold compose.
  apply continuous_composition; auto.
  apply strong_topology_makes_continuous_funcs.
- intros.
  red; intros.
  simpl. red. intros.
  rewrite <- inverse_image_composition.
  apply H.
  assumption.
Qed.

End StrongTopology.

Arguments StrongTopology {A} {X} {Y}.


(* Internal import(s). *)
Require Import Basics.Identifier.
Require Import Basics.Map.

Inductive exp: Type :=
  (* Primitives. *)
  | ENat  (x: nat)
  | EBool (x: bool)
  | EId   (x: identifier)
  (* Arithmetic operators. *)
  | EAdd (e e': exp)
  | ESub (e e': exp)
  | EMul (e e': exp)
  | EDiv (e e': exp)
  (* Logical operators. *)
  | EEq  (e e': exp)
  | ELt  (e e': exp)
  | ENot (e   : exp)
  | EAnd (e e': exp)
  (* If-then-else. *)
  | EIte   (e e' e'': exp)
  (* Lambdas. *)
  | EAbs (x   : identifier) (e: exp)
  | EFix (x   : identifier) (e: exp)
  | EApp (e e': exp)
  (* Hole. *)
  | EHole.

Inductive stack: Type :=
  | EmptyStack
  | Stack      (e: exp) (s:stack).

Inductive cfg: Type :=
  Cfg (s: stack) (m: map_id_nat).
Definition emptyCfg := Cfg EmptyStack map_id_nat_empty.

Coercion ENat : nat        >-> exp.
Coercion EBool: bool       >-> exp.
Coercion EId  : identifier >-> exp.
Infix "+"      := EAdd (at level 50, left associativity).
Infix "-"      := ESub (at level 50, left associativity).
Infix "*"      := EMul (at level 40, left associativity).
Infix "/"      := EDiv (at level 40, left associativity).
Infix "==?"    := EEq  (at level 55, left associativity).
Infix "<?"     := ELt  (at level 54, left associativity).
Infix "&"      := EAnd (at level 56, left associativity).
Notation "! b" := (ENot b)   (at level 30, right associativity).

Notation "'ITE' b 'THEN' c1 'ELSE' c2 'ETI'" :=
  (EIte b c1 c2)
  (at level 70, right associativity).

Notation "e '~>' st" := (Stack e st) (at level 80, right associativity).
Notation "[ s | m ]" := (Cfg s m)    (at level 90).


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : Lst) : Lst
           := match rev_arg0 with
              | nil => nil
              | cons x y => append (rev y) (cons x nil)
              end.

Theorem theorem0 : forall (x : Lst) (y : Nat), eq (rev (append x (cons y nil))) (cons y (rev x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. reflexivity.
Qed.


Require Import Coq.Unicode.Utf8_core.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.

Inductive varSet : Type :=
| Empty : varSet
| Var   : nat -> varSet -> varSet.

Fixpoint member_ (vs: varSet) (n:nat) : bool :=
match vs with
| Empty        => false
| Var m rest => if (beq_nat n m) then true else member_ rest n
end.

Inductive member : varSet -> nat -> Prop :=
| member_var : forall n rest,  member (Var n rest) n
| member_rest : forall n1 n2 rest, not (n1 = n2) ->
                                   member rest n1 ->
                                   member (Var n2 rest) n2.

Inductive notMember : varSet -> nat -> Prop :=
| notMember_empty : forall n, notMember Empty n
| notMember_var   : forall n n1 rest, not (n = n1) ->
                                      notMember rest n ->
                                      notMember (Var n1 rest) n.

Fixpoint add_ (vs : varSet) (n: nat) : varSet :=
  if (member_ vs n) then
    vs
  else
    (Var n vs).

Inductive add : varSet -> nat -> varSet -> Prop :=
| IsMember : forall n vs, member vs n -> add vs n vs
| IsNotMember : forall n vs, notMember vs n -> add vs n (Var n vs).

Inductive unique : varSet -> Prop :=
| unique_empty : unique Empty
| unique_var   : forall n rest, notMember rest n ->
                                unique rest ->
                                unique (Var n rest).

Fixpoint union_ (vs1 vs2: varSet) : varSet :=
match vs1 with
| Empty      => vs2
| Var n rest => union_ rest (add_ vs2 n)
end.

Inductive union : varSet -> varSet -> varSet -> Prop :=
| union_empty : forall vs, union Empty vs vs
| union_var   : forall n rest vs vsInt vsRes, add vs n vsInt ->
                                              union rest vsInt vsRes ->
                                              union (Var n rest) vs vsRes.

Theorem union_comm :
  forall v1 v2 vRes,
    union v1 v2 vRes ->
    union v2 v1 vRes.
Admitted.

Theorem union_unique :
  forall vs1 vs2 vsRes, unique vs1 ->
                        unique vs2 ->
                        union vs1 vs2 vsRes ->
                        unique vsRes.
Proof.
  intros vs1 vs2 vsRes Hvs1 Hvs2 Hunion.
  induction Hunion.
  - assumption.
  - apply IHHunion.
    + inversion Hvs1. subst. assumption.
    + inversion H; subst.
      * assumption.
      * constructor. assumption. assumption.
Qed.

Inductive disjoint : varSet -> varSet -> Prop :=
| disjoint_empty : forall vs, disjoint Empty vs
| disjoint_var   : forall n rest vs, notMember vs n ->
                                     disjoint rest vs ->
                                     disjoint (Var n rest) vs.

Inductive subset : varSet -> varSet -> Prop :=
| subset_empty : forall vs, subset Empty vs
| subset_var   : forall n rest vs, member vs n ->
                                   subset rest vs ->
                                   subset (Var n rest) vs.

Theorem subsets_disjoint :
  forall v1 v2 va vb,
  subset v1 va ->
  subset v2 vb ->
  disjoint va vb ->
  disjoint v1 v2.
Proof.
  Admitted.

Inductive equal : varSet -> varSet -> Prop :=
| equal_ : forall vs1 vs2, subset vs1 vs2 -> subset vs2 vs1 -> equal vs1 vs2.

Theorem union_lvar :
  forall n rest v2 vInt vRes,
  union rest v2 vInt ->
  union (Var n rest) v2 vRes ->
  equal vRes (Var n vInt).
Admitted.

Theorem union_rvar :
  forall n rest v2 vInt vRes,
  union v2 rest vInt ->
  union v2 (Var n rest) vRes ->
  equal vRes (Var n vInt).
Admitted.

Theorem subsets_union :
  forall v1 v2 v3 va vb vc,
    subset v1 va ->
    subset v2 vb ->
    union v1 v2 v3 ->
    union va vb vc ->
    subset v3 vc.
Admitted.

Theorem self_union :
  forall v,
    union v v v.
Admitted.

Theorem union_implies_subset :
  forall a b c,
    union a b c -> subset a c.
Admitted.

Theorem subset_transitivity :
  forall a b c,
    subset a b -> subset b c -> subset a c.
Admitted.

Theorem union_symmetry :
  forall a b c,
    union a b c -> union b a c.
Admitted.

Theorem exists_union :
  forall a b,
  exists c, union a b c.
Admitted.


Require Import List Program Arith String.
Open Scope string_scope.
Open Scope list_scope.

Require Import PFDS.common.DecidableOrder.
Require Import PFDS.common.Power.
Require Import PFDS.common.Result.
Require Import PFDS.common.Util.

Declare Module Seed : DecidableOrder.Seed.
Module Elem := DecidableOrder.Make(Seed).
Import Elem.Op.

Inductive heap : Set :=
| E : heap
| T : nat -> Elem.T -> heap -> heap -> heap.

Inductive HeapForall (P : Elem.T -> Prop) : heap -> Prop :=
| HFE : HeapForall P E
| HFT : forall r x a b, HeapForall P a -> HeapForall P b -> P x -> HeapForall P (T r x a b).

Lemma HeapForall_impl : forall (P Q: Elem.T -> Prop),
    (forall x, P x -> Q x) ->
    forall h, HeapForall P h -> HeapForall Q h.
Proof.
  intros P Q Hpq h HForallP. induction HForallP.
  - now constructor.
  - now constructor; [| | apply Hpq].
Qed.

Fixpoint right_spine(h : heap) :=
  match h with
  | E => []
  | T r x left_ right_ => x :: right_spine right_
  end.

Definition calc_rank(h : heap) := List.length (right_spine h).

Lemma rank_T : forall r x left_ right_,
    calc_rank(T r x left_ right_) = 1 + calc_rank(right_).
Proof.
  now intros.
Qed.

Fixpoint size(h : heap) :=
  match h with
  | E => 0
  | T _ _ a b => 1 + size(a) + size(b)
  end.

Inductive Leftist : heap -> Prop :=
| LeftistE : Leftist E
| LeftistT : forall a b r x,
    (calc_rank b <= calc_rank a)%nat -> Leftist a -> Leftist b -> Leftist (T r x a b).

(** ** Exercise 3.1 *)

Lemma ex3_1_aux : forall t, Leftist t -> (2 ^^ (calc_rank t) <= size t + 1)%nat.
Proof.
  induction t as[| r x a IHa b IHb].
  - reflexivity.
  - rewrite rank_T. simpl size. intro HLeftist.
    cutrewrite (S (size a + size b) + 1 = (size a + 1) + (size b + 1)); [| ring].
    inversion HLeftist as [|a0 b0 r0 x0 Hrank HLa HLb]. subst. apply IHa in HLa. apply IHb in HLb.
    apply (le_trans _ (pow 2 (calc_rank a) + (size b + 1))); [|now apply plus_le_compat_r].
    apply (le_trans _ (pow 2 (calc_rank a) + pow 2 (calc_rank b))); [|now apply plus_le_compat_l].
    rewrite pow_plus. simpl (pow 2 1).
    cutrewrite (2 * pow 2 (calc_rank b) = pow 2 (calc_rank b) + pow 2 (calc_rank b)); [|ring].
    apply (plus_le_compat_r). now apply pow_le; [now auto with arith|].
Qed.

(**
   ** merge関数
   > どの右スパインの長さもたかだか対数のオーダーであるから、[merge]は O(log n) 時間で実行される。 (p.28)
 *)

(**
   *** merge関数の実装
 *)

Definition rank h :=
  match h with
  | E => 0
  | T r _ _ _ => r
  end.

Definition makeT x a b :=
  if le_lt_dec (rank b) (rank a) then T (1 + rank b) x a b
  else T (1 + rank a) x b a.

Require Import Recdef.

Function merge h1_h2 {measure (pair_size size size) h1_h2} :=
  match (h1_h2) with
  | (E, h2) => h2
  | (h1, E) => h1
  | (T _ x a1 b1 as h1, T _ y a2 b2 as h2) =>
    if Elem.leq_bool x y then
      makeT x a1 (merge (b1, h2))
    else
      makeT y a2 (merge (h1, b2))
  end.
Proof. (* 停止性の証明 *)
  - simpl. now auto with arith.
  - simpl. now auto with arith.
Defined.

(**
   *** merge関数の証明
*)

(**
   **** merge関数でrank関数の健全性が保たれる
*)

Inductive RankSound : heap -> Prop :=
| RSE : RankSound E
| RST : forall r x a b, RankSound a -> RankSound b -> rank (T r x a b) = calc_rank (T r x a b) -> RankSound(T r x a b).

Lemma RankSound_eq : forall h,
    RankSound h -> rank h = calc_rank h.
Proof.
  intros h Hrank. now induction Hrank.
Qed.

Lemma makeT_rank : forall x a b,
  RankSound a -> RankSound b ->
    RankSound (makeT x a b).
Proof.
  intros x a b Hranka Hrankb. unfold makeT.
  destruct (le_lt_dec (rank b) (rank a)).
  - constructor; [assumption| assumption|]. rewrite rank_T. now rewrite (RankSound_eq _ Hrankb).
  - constructor; [assumption| assumption|]. rewrite rank_T. now rewrite (RankSound_eq _ Hranka).
Qed.

Lemma merge_rank : forall h1 h2,
  RankSound h1 -> RankSound h2 -> RankSound (merge (h1,h2)).
Proof.
  cut (forall h1h2, RankSound (fst h1h2) -> RankSound (snd h1h2) -> RankSound (merge h1h2)); [intros; now apply H|].
  intros h1h2. apply merge_ind.
  - now intros.
  - now intros.
  - simpl. intros h1_h2 _r1 x a1 b1 _r2 y a2 b2 Heq Hleq IH Hrank1 Hrank2. subst.
    inversion Hrank1. inversion Hrank2. subst.
    apply makeT_rank; [assumption|]. now apply IH.
  - simpl. intros h1_h2 _r1 x a1 b1 _r2 y a2 b2 Heq Hleq IH Hrank1 Hrank2. subst.
    inversion Hrank1. inversion Hrank2. subst.
    apply makeT_rank; [assumption|]. now apply IH.
Qed.

(**
   **** merge関数でLeftist性が保存される
*)

Lemma makeT_Leftist : forall x a b,
    RankSound a -> RankSound b ->
    Leftist a -> Leftist b ->
    Leftist (makeT x a b).
Proof.
  intros x a b Hra Hrb Hla Hlb. unfold makeT.
  destruct (le_lt_dec _ _).
  - constructor; [|assumption|assumption].
    now rewrite <- (RankSound_eq _ Hrb), <- (RankSound_eq _ Hra).
  - constructor; [|assumption|assumption].
    apply lt_le_weak. now rewrite <- (RankSound_eq _ Hrb), <- (RankSound_eq _ Hra).
Qed.

Lemma merge_Leftist : forall h1 h2,
      RankSound h1 -> RankSound h2 ->
      Leftist h1 -> Leftist h2 ->
      Leftist (merge (h1, h2)).
Proof.
  cut (forall h1h2, RankSound (fst h1h2) -> RankSound (snd h1h2) -> Leftist (fst h1h2) -> Leftist (snd h1h2) -> Leftist (merge h1h2)); [intros; now apply H|].
  intros h1h2. apply merge_ind.
  - now intros.
  - now intros.
  - simpl. intros h1_h2 _r1 x a1 b1 _r2 y a2 b2 Heq _ IH Hr1 Hr2 Hl1 Hl2.
    inversion Hr1. inversion Hl1. subst.
    inversion Hr2. inversion Hl2. subst.
    apply makeT_Leftist; [assumption| | assumption|].
    + now apply merge_rank.
    + now apply IH.
  - simpl. intros h1_h2 _r1 x a1 b1 _r2 y a2 b2 Heq _ IH Hr1 Hr2 Hl1 Hl2.
    inversion Hr1. inversion Hl1. subst.
    inversion Hr2. inversion Hl2. subst.
    apply makeT_Leftist; [assumption | | assumption|].
    + now apply merge_rank.
    + now apply IH.
Qed.

(**
   **** merge関数とHeapForallのいい関係
*)

Lemma makeT_Forall : forall P x a b,
    (HeapForall P a /\ HeapForall P b /\ P x) <-> HeapForall P (makeT x a b).
Proof.
  intros P x a b. unfold makeT. destruct (le_lt_dec _ _); split; intros.
  + now constructor.
  + now inversion H.
  + now constructor.
  + now inversion H.
Qed.

Lemma merge_Forall : forall P h1 h2,
    (HeapForall P h1 /\ HeapForall P h2) <-> HeapForall P (merge (h1,h2)).
Proof.
  intros P. cut (forall p, HeapForall P (fst p) /\ HeapForall P (snd p) <-> HeapForall P (merge p)); [intros; now destruct (H (h1,h2))|].
  intros h1h2. apply merge_ind.
  - intros. simpl. split; [tauto|]. now split; [constructor | ].
  - intros. simpl. split; [tauto|]. now split; [ | constructor].
  - simpl. intros h1_h2 _r1 x a1 b1 _r2 y a2 b2 Heq _ IH.
    rewrite <- makeT_Forall. rewrite <- IH. split.
    + intros H. destruct H as [H1 H2]. inversion H1. now inversion H2.
    + intros H. split; [|tauto]. now constructor.
  - simpl. intros h1_h2 _r1 x a1 b1 _r2 y a2 b2 Heq _ IH.
    rewrite <- makeT_Forall. rewrite <- IH. split.
    + intros H. destruct H as [H1 H2]. inversion H1. now inversion H2.
    + intros H. split; [tauto|]. now constructor.
Qed.

(**
   **** merge関数でヒープとしての性質: 「常にrootノードの値が最小値」を保存することを証明
*)

Inductive Heap : heap -> Prop :=
| HeapE : Heap E
| HeapT : forall r x a b, Heap a -> Heap b -> HeapForall (fun elem => x <= elem) (T r x a b) -> Heap (T r x a b).

Lemma makeT_Heap : forall x a b,
    Heap a -> Heap b ->
    HeapForall (fun elem => x <= elem) a ->
    HeapForall (fun elem => x <= elem) b ->
    Heap (makeT x a b).
Proof.
Admitted.

Lemma merge_Heap : forall h1 h2,
    Heap h1 -> Heap h2 ->
    Heap (merge (h1,h2)).
Proof.
  cut (forall p, Heap (fst p) -> Heap (snd p) -> Heap (merge p)); [intros; now apply H|].
  intro h1h2. apply merge_ind.
  - now intros.
  - now intros.
  - simpl. intros h1_h2 _r1 x a1 b1 _r2 y a2 b2 Heq Hleq IH Hh1 Hh2.
    inversion Hh1. inversion Hh2. subst.
    inversion H5. inversion H12. subst.
    apply makeT_Heap; [assumption| now apply IH|assumption|].
    apply merge_Forall. split; [assumption |].
    eapply HeapForall_impl; [|now apply H12]. simpl. intros elem Helem.
    apply (Elem.Ord.le_trans _ y); [|assumption]. now apply Elem.leq_bool_correct.
  - simpl. intros h1_h2 _r1 x a1 b1 _r2 y a2 b2 Heq Hleq IH Hh1 Hh2.
    inversion Hh1. inversion Hh2. subst.
    inversion H5. inversion H12. subst.
    apply makeT_Heap; [assumption| now apply IH|assumption|].
    apply merge_Forall. split; [| assumption].
    rewrite Elem.leq_bool_correct_inv in Hleq. apply Elem.Ord.not_le_lt in Hleq. apply Elem.Ord.lt_le_incl in Hleq.
    constructor.
    + eapply HeapForall_impl; [ |now apply H3]. simpl. intros elem Helem.
      now apply (Elem.Ord.le_trans _ x).
    + eapply HeapForall_impl; [ |now apply H7]. simpl. intros elem Helem.
      now apply (Elem.Ord.le_trans _ x).
    + assumption.
Qed.

(**
   ** insert
*)

(**
   *** insert関数の実装
*)

Definition insert x h := merge (T 1 x E E, h).

(**
   ** findMin
*)

(**
   *** findMin 関数の実装
*)

Definition findMin h :=
  match h with
  | E => Error "Empty Heap"
  | T _ x _ _ => Ok x
  end.

(**
   ** deleteMin
*)

(**
   *** deleteMin関数の実装
*)

Definition deleteMin h :=
  match h with
  | E => Error "Empty Heap"
  | T _ _ a b => Ok (merge(a, b))
  end.


Inductive SC : Type :=
| Value : nat -> SC
| Unknown : SC.

Inductive NatStack : Type :=
| Empty : NatStack
| Add : nat -> NatStack -> NatStack.

Definition pop(s:NatStack) : NatStack :=
match s with
| Empty => Empty
| Add _ xs => xs
end.

Definition top(s:NatStack) : SC :=
match s with
| Empty => Unknown
| Add s' _ => Value s'
end.

Fixpoint isEmpty (s:NatStack):bool:=
match s with
| Empty => true
| Add _ s' => false
end.

(*
Add::
Add is already a constructor in Inductive Definition. So, need not explicitly define it again.
Precondition : Add doesnot have any precondition.
Post Condition : If we add an element to stack and evaluate top of stack,
                 it should return the same value.
                   (top ( Add x xs )) = Value x.
Invariant : Add an element into stack and pop the stack,
            will return the original stack eliminating the top value.
                   (pop ( Add x xs )) = xs.
*)

Theorem add_post_condition : forall x xs, (top ( Add x xs )) = Value x.
Proof.
 intros.
 simpl.
 reflexivity.
Qed.

Theorem add_invariant : forall x xs, pop ( Add x xs ) = xs.
Proof.
intros.
simpl.
reflexivity.
Qed.

(*
Pop::
Precondition : The stack is not empty.
Poscondition : This is similar to the invariant of Add.
               pop ( Add x xs ) = xs.
invariant : The post condition is an invariant itself.
*)

Theorem pop_post_condition : forall x xs, pop ( Add x xs ) = xs.
Proof.
intros.
simpl.
reflexivity.
Qed.

(*
top::
Precondition : The stack is not empty.
Postcondition : Add an element and return the top of the stack,
                should return the element which we added.
                    top ( Add x xs) = Value x.
Invariant : Since top operation not changing the other elements of stack, it should remain unchanged.
*)

Theorem top_post_condition : forall x xs, top ( Add x xs) = Value x.
Proof.
 intros.
 simpl.
 reflexivity.
Qed.

(*
isEmpty ::
Precondition : Doesn't have any precondition
PostCondition : The result should return  boolean value(true) if the stack is empty and viceversa.
invariant : Since this doesn't have any effects, no invariant exists.
*)

Theorem isEmpty_post_condition : isEmpty ( Empty ) = true.
Proof.
simpl.
reflexivity.
Qed.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

(** Lemmas and tactics for working with and solving goals related to
    non-membership in finite sets.  The main tactic of interest here
    is [solve_notin].

    Implicit arguments are declared by default in this library. *)

Require Import Coq.FSets.FSetInterface.

Require Import Metalib.CoqFSetDecide.

(* Suppress warnings about Hint Resolve *)
Local Set Warnings "-fragile-hint-constr".

(* *********************************************************************** *)
(** * Implementation *)

Module Notin_fun
  (E : DecidableType) (Import X : FSetInterface.WSfun E).

Module Import D := CoqFSetDecide.WDecide_fun E X.

(* *********************************************************************** *)
(** * Facts about set non-membership *)

Section Lemmas.

Variables x y  : elt.
Variable  s s' : X.t.

Lemma notin_empty_1 :
  ~ In x empty.
Proof. fsetdec. Qed.

Lemma notin_add_1 :
  ~ In y (add x s) ->
  ~ E.eq x y.
Proof. fsetdec. Qed.

Lemma notin_add_1' :
  ~ In y (add x s) ->
  x <> y.
Proof. fsetdec. Qed.

Lemma notin_add_2 :
  ~ In y (add x s) ->
  ~ In y s.
Proof. fsetdec. Qed.

Lemma notin_add_3 :
  ~ E.eq x y ->
  ~ In y s ->
  ~ In y (add x s).
Proof. fsetdec. Qed.

Lemma notin_singleton_1 :
  ~ In y (singleton x) ->
  ~ E.eq x y.
Proof. fsetdec. Qed.

Lemma notin_singleton_1' :
  ~ In y (singleton x) ->
  x <> y.
Proof. fsetdec. Qed.

Lemma notin_singleton_2 :
  ~ E.eq x y ->
  ~ In y (singleton x).
Proof. fsetdec. Qed.

Lemma notin_remove_1 :
  ~ In y (remove x s) ->
  E.eq x y \/ ~ In y s.
Proof. fsetdec. Qed.

Lemma notin_remove_2 :
  ~ In y s ->
  ~ In y (remove x s).
Proof. fsetdec. Qed.

Lemma notin_remove_3 :
  E.eq x y ->
  ~ In y (remove x s).
Proof. fsetdec. Qed.

Lemma notin_remove_3' :
  x = y ->
  ~ In y (remove x s).
Proof. fsetdec. Qed.

Lemma notin_union_1 :
  ~ In x (union s s') ->
  ~ In x s.
Proof. fsetdec. Qed.

Lemma notin_union_2 :
  ~ In x (union s s') ->
  ~ In x s'.
Proof. fsetdec. Qed.

Lemma notin_union_3 :
  ~ In x s ->
  ~ In x s' ->
  ~ In x (union s s').
Proof. fsetdec. Qed.

Lemma notin_inter_1 :
  ~ In x (inter s s') ->
  ~ In x s \/ ~ In x s'.
Proof. fsetdec. Qed.

Lemma notin_inter_2 :
  ~ In x s ->
  ~ In x (inter s s').
Proof. fsetdec. Qed.

Lemma notin_inter_3 :
  ~ In x s' ->
  ~ In x (inter s s').
Proof. fsetdec. Qed.

Lemma notin_diff_1 :
  ~ In x (diff s s') ->
  ~ In x s \/ In x s'.
Proof. fsetdec. Qed.

Lemma notin_diff_2 :
  ~ In x s ->
  ~ In x (diff s s').
Proof. fsetdec. Qed.

Lemma notin_diff_3 :
  In x s' ->
  ~ In x (diff s s').
Proof. fsetdec. Qed.

End Lemmas.

(* *********************************************************************** *)
(** * Hints *)

#[global]
Hint Resolve
  @notin_empty_1 @notin_add_3 @notin_singleton_2 @notin_remove_2
  @notin_remove_3 @notin_remove_3' @notin_union_3 @notin_inter_2
  @notin_inter_3 @notin_diff_2 @notin_diff_3 : core.

(* *********************************************************************** *)
(** * Tactics for non-membership *)

(** [destruct_notin] decomposes all hypotheses of the form [~ In x s]. *)

Ltac destruct_notin :=
  match goal with
    | H : In ?x ?s -> False |- _ =>
      change (~ In x s) in H;
      destruct_notin
    | |- In ?x ?s -> False =>
      change (~ In x s);
      destruct_notin
    | H : ~ In _ empty |- _ =>
      clear H;
      destruct_notin
    | H : ~ In ?y (add ?x ?s) |- _ =>
      let J1 := fresh "NotInTac" in
      let J2 := fresh "NotInTac" in
      pose proof H as J1;
      pose proof H as J2;
      apply notin_add_1 in H;
      apply notin_add_1' in J1;
      apply notin_add_2 in J2;
      destruct_notin
    | H : ~ In ?y (singleton ?x) |- _ =>
      let J := fresh "NotInTac" in
      pose proof H as J;
      apply notin_singleton_1 in H;
      apply notin_singleton_1' in J;
      destruct_notin
    | H : ~ In ?y (remove ?x ?s) |- _ =>
      let J := fresh "NotInTac" in
      apply notin_remove_1 in H;
      destruct H as [J | J];
      destruct_notin
    | H : ~ In ?x (union ?s ?s') |- _ =>
      let J := fresh "NotInTac" in
      pose proof H as J;
      apply notin_union_1 in H;
      apply notin_union_2 in J;
      destruct_notin
    | H : ~ In ?x (inter ?s ?s') |- _ =>
      let J := fresh "NotInTac" in
      apply notin_inter_1 in H;
      destruct H as [J | J];
      destruct_notin
    | H : ~ In ?x (diff ?s ?s') |- _ =>
      let J := fresh "NotInTac" in
      apply notin_diff_1 in H;
      destruct H as [J | J];
      destruct_notin
    | _ =>
      idtac
  end.

(** [solve_notin] decomposes hypotheses of the form [~ In x s] and
    then tries some simple heuristics for solving the resulting
    goals. *)

Ltac solve_notin :=
  intros;
  destruct_notin;
  repeat first [ apply notin_union_3
               | apply notin_add_3
               | apply notin_singleton_2
               | apply notin_empty_1
               ];
  auto;
  try tauto;
  fail "Not solvable by [solve_notin]; try [destruct_notin]".

(* *********************************************************************** *)
(** * Examples and test cases *)

(** These examples and test cases are not meant to be exhaustive. *)

Lemma test_solve_notin_1 : forall x E F G,
  ~ In x (union E F) ->
  ~ In x G ->
  ~ In x (union E G).
Proof. solve_notin. Qed.

Lemma test_solve_notin_2 : forall x y E F G,
  ~ In x (union E (union (singleton y) F)) ->
  ~ In x G ->
  ~ In x (singleton y) /\ ~ In y (singleton x).
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_3 : forall x y,
  ~ E.eq x y ->
  ~ In x (singleton y) /\ ~ In y (singleton x).
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_4 : forall x y E F G,
  ~ In x (union E (union (singleton x) F)) ->
  ~ In y G.
Proof. solve_notin. Qed.

Lemma test_solve_notin_5 : forall x y E F,
  ~ In x (union E (union (singleton y) F)) ->
  ~ In y E ->
  ~ E.eq y x /\ ~ E.eq x y.
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_6 : forall x y E,
  ~ In x (add y E) ->
  ~ E.eq x y /\ ~ In x E.
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_7 : forall x,
  ~ In x (singleton x) ->
  False.
Proof. solve_notin. Qed.

End Notin_fun.


(*
  Verificación Formal - Unam 2020-2
  Ciro Iván García López
  Proyecto 1. Session Type Systems Verification
*)

(*
Definición 2.1, ULL Propositions
*)
Inductive Proposition : Type :=
  | ONE : Proposition
  | ABS : Proposition
  | TEN (A : Proposition) (B : Proposition) : Proposition
  | PAR (A : Proposition) (B : Proposition) : Proposition
(*   | ULLT_IMP (A : ULLType) (B : ULLType) : ULLType  *)
  | EXP (A : Proposition) : Proposition
  | MOD (A : Proposition) : Proposition.
Hint Constructors Proposition : core.

(*
Notación análoga a la propuesta por el artículo.
Los niveles de asociatividad se dan siguiendo las ideas de Honda.
*)
Notation "¶" := ONE.
Notation "⊥" := ABS.
Notation "A ⊗ B" := (TEN A B)(at level 70, right associativity).
Notation "A ⅋ B" := (PAR A B)(at level 70, right associativity).
(* Notation "A −∘ B" := (ULLT_IMP A B)(at level 50, left associativity). *)
Notation "! A" := (EXP A)(at level 60, right associativity).
Notation "? A" := (MOD A)(at level 60, right associativity).

(*
Definicion 2.2, Dualidad
*)
Fixpoint Dual_Prop ( T : Proposition ) : Proposition :=
match T with
  | ¶ => ⊥
  | ⊥ => ¶
  | A ⊗ B => (Dual_Prop A) ⅋ (Dual_Prop B)
  | A ⅋ B => (Dual_Prop A) ⊗ (Dual_Prop B)
  | ! A => ? (Dual_Prop A)
  | ? A => ! (Dual_Prop A)
end.
Hint Unfold Dual_Prop : core.
Notation "A '^⊥'" := (Dual_Prop A)(at level 60, right associativity).

(*
Definición del operador −∘ de acuerdo a los descrito en el primer parrafo de la Definición 2.2.
*)
Definition ULLT_IMP (A : Proposition) (B : Proposition) : Proposition := (A^⊥) ⅋ B.
Notation "A −∘ B" := (ULLT_IMP A B)(at level 70, right associativity).

(*
⊥
⊗
⅋
−∘
^⊥
*)


Inductive listN : Set :=
 | Nil : listN
 | Cons : nat -> listN -> listN.

Fixpoint app (u1 : listN) (u2 : listN) : listN :=
  match u1 with
   | Nil => u2
   | Cons x r1 => Cons x (app r1 u2)
  end.

Infix "::" := Cons (at level 60, right associativity).
Notation "[ ]" := Nil (format "[ ]").
Infix "@" := app (right associativity, at level 60).

(* Révisions (utile pour la suite) *)
Theorem app_neutre_droite : forall u, u @ [] = u.
Proof.
  induction u.
  - reflexivity.
  - simpl. rewrite IHu. reflexivity.
Qed.

Theorem app_assoc : forall u1 u2 u3, (u1 @ u2) @ u3 = u1 @ (u2 @ u3).
Proof.
  induction u1.
  - reflexivity.
  - simpl. intros. rewrite IHu1. reflexivity.
Qed.

Fixpoint rv (u : listN) : listN :=
  match u with
   | [] => []
   | x :: u' => (rv u') @ (x :: [])
  end.

Fixpoint rv_acc (u : listN) (a : listN) : listN :=
  match u with
   | [] => a
   | x :: u' =>  rv_acc u' (x :: a)
  end.

(* Trouver le lemme auxiliaire utile ! *)
Theorem rv_acc_rv : forall u, rv_acc u [] = rv u.
Proof.
Admitted.

(* Si temps disponible *)

Lemma rv_app : forall u v, rv (u @ v) = rv v @ rv u.
Proof.
Admitted.

Theorem rv_rv : forall u, rv (rv u) = u.
Proof.
Admitted.


Add LoadPath "D:\sfsol".
Require Export Stlc.

Module STLCChecker.
Import STLC.

Fixpoint beq_ty (T1 T2:ty) : bool :=
  match T1,T2 with
  | TBool, TBool =>
      true
  | TArrow T11 T12, TArrow T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | _,_ =>
      false
  end.

Lemma beq_ty_refl : forall T1,
  beq_ty T1 T1 = true.
Proof.
  intros T1. induction T1; simpl.
    reflexivity.
    rewrite IHT1_1. rewrite IHT1_2. reflexivity. Qed.

Lemma beq_ty__eq : forall T1 T2,
  beq_ty T1 T2 = true -> T1 = T2.
Proof with auto.
  intros T1. induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq.
  Case "T1=TBool".
    reflexivity.
  Case "T1=TArrow T1_1 T1_2".
    apply andb_true in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHT1_1 in Hbeq1. apply IHT1_2 in Hbeq2. subst... Qed.

Fixpoint type_check (Gamma:context) (t:tm) : option ty :=
  match t with
  | tvar x => Gamma x
  | tabs x T11 t12 => match type_check (extend Gamma x T11) t12 with
                          | Some T12 => Some (TArrow T11 T12)
                          | _ => None
                        end
  | tapp t1 t2 => match type_check Gamma t1, type_check Gamma t2 with
                      | Some (TArrow T11 T12),Some T2 =>
                        if beq_ty T11 T2 then Some T12 else None
                      | _,_ => None
                    end
  | ttrue => Some TBool
  | tfalse => Some TBool
  | tif x t f => match type_check Gamma x with
                     | Some TBool =>
                       match type_check Gamma t, type_check Gamma f with
                         | Some T1, Some T2 =>
                           if beq_ty T1 T2 then Some T1 else None
                         | _,_ => None
                       end
                     | _ => None
                   end
  end.

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  t_cases (induction t) Case; intros Gamma T Htc; inversion Htc.
  Case "tvar"...
  Case "tapp".
    remember (type_check Gamma t1) as TO1.
    remember (type_check Gamma t2) as TO2.
    destruct TO1 as [T1|]; try solve by inversion;
    destruct T1 as [|T11 T12]; try solve by inversion.
    destruct TO2 as [T2|]; try solve by inversion.
    destruct (beq_ty T11 T2) eqn: Heqb;
    try solve by inversion.
    apply beq_ty__eq in Heqb.
    inversion H0; subst...
  Case "tabs".
    rename i into y. rename t into T1.
    remember (extend Gamma y T1) as G'.
    remember (type_check G' t0) as TO2.
    destruct TO2; try solve by inversion.
    inversion H0; subst...
  Case "ttrue"...
  Case "tfalse"...
  Case "tif".
    remember (type_check Gamma t1) as TOc.
    remember (type_check Gamma t2) as TO1.
    remember (type_check Gamma t3) as TO2.
    destruct TOc as [Tc|]; try solve by inversion.
    destruct Tc; try solve by inversion.
    destruct TO1 as [T1|]; try solve by inversion.
    destruct TO2 as [T2|]; try solve by inversion.
    destruct (beq_ty T1 T2) eqn:Heqb;
    try solve by inversion.
    apply beq_ty__eq in Heqb.
    inversion H0. subst. subst...
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof with auto.
  intros Gamma t T Hty.
  has_type_cases (induction Hty) Case; simpl.
  Case "T_Var"...
  Case "T_Abs". rewrite IHHty...
  Case "T_App".
    rewrite IHHty1. rewrite IHHty2.
    rewrite (beq_ty_refl T11)...
  Case "T_True"...
  Case "T_False"...
  Case "T_If". rewrite IHHty1. rewrite IHHty2.
    rewrite IHHty3. rewrite (beq_ty_refl T)...
Qed.

End STLCChecker.


Set Implicit Arguments.

Require Import set.
Require Import subset.
Require Import equiv.
Require Import subset_transitive.

Proposition equiv_transitive: forall (a b c:set),
  equiv a b -> equiv b c -> equiv a c.
Proof.
  intros a b c Hab Hbc.
  unfold equiv in Hab. unfold equiv in Hbc.
  elim Hab. clear Hab. intros Hab Hba.
  elim Hbc. clear Hbc. intros Hbc Hcb.
  unfold equiv. split.
  apply subset_transitive with (b:= b). exact Hab. exact Hbc.
  apply subset_transitive with (b:= b). exact Hcb. exact Hba.
Qed.


(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

Set Implicit Arguments.

From Coq Require Import Setoid Relations List Wellfounded.
From CoLoR Require Export TransClosure.

Lemma acc_trans :
 forall A (R : relation A) a, Acc R a -> Acc (trans_clos R) a.
Proof.
intros A R a Acc_R_a.
induction Acc_R_a as [a Acc_R_a IH].
apply Acc_intro.
intros b b_Rp_a; induction b_Rp_a.
apply IH; trivial.
apply Acc_inv with y.
apply IHb_Rp_a; trivial.
apply t_step; trivial.
Defined.

Lemma wf_trans :
  forall A (R : relation A) , well_founded R -> well_founded (trans_clos R).
Proof.
unfold well_founded; intros A R WR.
intro; apply acc_trans; apply WR; trivial.
Defined.

Lemma trans_incl :
  forall A (R1 R2 : relation A), inclusion _ R1 R2 -> inclusion _ (trans_clos R1) (trans_clos R2).
Proof.
intros A R1 R2 R1_in_R2 a b H; induction H as [a' b' H | a' b' c' H1 H2].
apply t_step; apply R1_in_R2; trivial.
apply t_trans with b'; trivial.
apply R1_in_R2; trivial.
Qed.

Lemma refl_trans_incl :
  forall A (R1 R2 : relation A), inclusion _ R1 R2 -> inclusion _ (refl_trans_clos R1) (refl_trans_clos R2).
Proof.
intros A R1 R2 R1_in_R2 a b [a' | a' b' H].
left.
apply t_clos; apply trans_incl with R1; assumption.
Qed.

Lemma trans_incl2 :
  forall A B (f : A -> B) (R1 : relation A) (R2 : relation B),
  (forall a1 a2, R1 a1 a2 -> R2 (f a1) (f a2)) ->
	forall a1 a2, trans_clos R1 a1 a2 ->  trans_clos R2 (f a1) (f a2).
Proof.
intros A B f R1 R2 R1_in_R2 a b H; induction H as [a' b' H | a' b' c' H1 H2].
apply t_step; apply R1_in_R2; trivial.
apply t_trans with (f b'); trivial.
apply R1_in_R2; trivial.
Qed.

Lemma trans_with_eq :
  forall A (R : relation A) a1 a2,
  trans_clos (union A (@eq _) R) a1 a2 <-> refl_trans_clos R a1 a2.
Proof.
intros A R a1 a2; split.
intro H; induction H as [b1 b2 H | b1 b2 b3 H1 H2].
destruct H as [H | H].
subst b2; apply r_step; assumption.
apply t_clos; apply t_step; assumption.
destruct H1 as [H1 | H1].
subst b2; assumption.
destruct IHH2 as [b2 | b2 b3 H3].
apply t_clos; apply t_step; assumption.
apply t_clos; apply t_trans with b2; assumption.

intro H; destruct H as [a1 | a1 a2 H].
apply t_step; left; apply eq_refl.
apply (@trans_incl _ R); trivial.
right; assumption.
Qed.

Lemma acc_star :
   forall A (R : relation A) a, Acc R a -> forall b,  refl_trans_clos  R b a -> Acc R b.
Proof.
intros A R a Acc_a b H; destruct H as [a1 | a1 a2 H].
assumption.
apply Acc_incl with (trans_clos R).
intros b1 b2 H'; apply t_step; assumption.
apply Acc_inv with a2; trivial.
apply acc_trans; trivial.
Qed.

Inductive compose_rel A (R1 R2 : relation A) : relation A :=
  Comp : forall a1 a2 a3, R1 a1 a2 -> R2 a2 a3 -> compose_rel R1 R2 a1 a3.

Section Compose.
Variable A : Type.
Variable R1 : relation A.
Variable R2 : relation A.

Lemma trans_union :
  forall a b,
  trans_clos (union _ R1 R2) a b <->
  union _ (trans_clos R1)
            (compose_rel (refl_trans_clos R1) (trans_clos (compose_rel R2 (refl_trans_clos R1)))) a b.
Proof.
intros a b; split.
(* 1/2 -> *)
intro H; induction H as [x y H1 | x y z H1 Hn].
destruct H1 as [H1 | H1].
left; apply t_step; assumption.
right; apply Comp with x.
apply r_step.
apply t_step.
apply Comp with y; trivial.
apply r_step.
destruct H1 as [H1 | H2]; destruct IHHn as [IHHn | IHHn].
left; apply t_trans with y; trivial.
right; inversion IHHn as [x' y' z' K1 K2]; subst x' z'; clear IHHn.
apply Comp with y'.
inversion K1 as [y1 | y1 y2 K1']; clear K1.
subst y1 y'; apply t_clos; apply t_step; trivial.
subst y1 y2; apply t_clos; apply t_trans with y; trivial.
trivial.
right.
apply Comp with x.
apply r_step.
apply t_step; apply Comp with y; trivial.
apply t_clos; trivial.
right; inversion IHHn as [x' y' z' K1 K2]; subst x' z'; clear IHHn.
apply Comp with x.
apply r_step.
apply t_trans with y'; trivial.
apply Comp with y; trivial.
(* 1/1 <- *)
intros [H | H].
apply trans_incl with R1; trivial.
intros; left; trivial.
inversion H as [x' y' z' K1 K2]; clear H; subst x' z'.
inversion K1 as [y1 | y1 y2 K1']; clear K1.
subst y1 y'.
apply trans_clos_is_clos.
apply trans_incl with (compose_rel R2 (refl_trans_clos R1)); trivial.
clear a b K2; intros a b K2.
inversion K2 as [x' y' z' K1 K2']; clear K2; subst x' z'.
inversion K2' as [y1 | y1 y2 K2'']; clear K2'.
subst y1 y'; apply t_step; right; trivial.
subst y1 y2.
apply t_trans with y'.
right; trivial.
apply trans_incl with R1; trivial.
intros; left; trivial.
subst y1 y2.
apply trans_clos_is_trans with y'.
apply trans_incl with R1; trivial.
intros; left; trivial.
apply trans_clos_is_clos.
apply trans_incl with (compose_rel R2 (refl_trans_clos R1)); trivial.
clear a b y' K1' K2; intros a b K2.
inversion K2 as [x' y' z' K1 K2']; clear K2; subst x' z'.
inversion K2' as [y1 | y1 y2 K2'']; clear K2'.
subst y' y1.
left; right; trivial.
subst y1 y2.
right with y'.
right; trivial.
apply trans_incl with R1; trivial.
intros; left; trivial.
Qed.

Lemma trans_union_alt :
  forall a b,
  trans_clos (union _ R1 R2) a b <->
  union _ (trans_clos R1)
             (compose_rel (trans_clos (compose_rel (refl_trans_clos R1) R2))
                                  (refl_trans_clos R1)) a b.
Proof.
intros a b; split.
(* 1/2 -> *)
rewrite trans_clos_trans_clos_alt in *; intro H; induction H as [x y H1 | x y z H1 IHH1 Hn].
(* 1/3 one step *)
destruct H1 as [H1 | H1].
left; left; assumption.
right; apply Comp with y.
left; apply Comp with x; trivial.
left.
left.
(* 1/2 several steps *)
destruct IHH1 as [IHH1 | IHH1]; destruct Hn as [Hn | Hn].
(* 1/5 *)
left; rewrite trans_clos_trans_clos_alt in *; right with y; trivial.
(* 1/4 *)
right; apply Comp with z.
left; apply Comp with y; trivial.
right; trivial.
left.
(* 1/3 *)
inversion IHH1 as [x' y' z' K1 K2]; subst x' z'; clear IHH1.
right; apply Comp with y'; trivial.
inversion K2 as [y'' | a a' K2' K2''].
subst y' y''.
right; left; trivial.
subst a a'; right; apply trans_clos_is_trans with y; trivial.
left; trivial.
(* 1/2 *)
inversion IHH1 as [x' y' z' K1 K2]; subst x' z'; clear IHH1.
right.
apply Comp with z.
apply trans_clos_is_trans with y'; trivial.
left; apply Comp with y; trivial.
left.
(* 1/1 <- *)
intros [H | H].
apply trans_incl with R1; trivial.
intros; left; trivial.
inversion H as [x' y' z' K1 K2]; clear H; subst x' z'.
inversion K2 as [y1 | y1 y2 K2']; clear K2.
subst y1 y'.
apply trans_clos_is_clos.
apply trans_incl with (compose_rel (refl_trans_clos R1) R2); trivial.
clear a b K1; intros a b H.
inversion H as [x' y' z' K1 K2]; subst x' z'; clear H.
inversion K1 as [y1 | y1 y2 K1']; clear K1.
subst y1 y'; apply t_step; right; trivial.
subst y1 y2.
apply trans_clos_is_trans with y'.
apply trans_incl with R1; trivial.
intros; left; trivial.
left; right; trivial.
subst y1 y2.
apply trans_clos_is_trans with y'.
apply trans_clos_is_clos.
apply trans_incl with (compose_rel (refl_trans_clos R1) R2); trivial.
clear a b y' K1 K2'; intros a b H.
inversion H as [x' y' z' K1 K2]; subst x' z'; clear H.
inversion K1 as [y1 | y1 y2 K1']; clear K1.
subst y1 y'; apply t_step; right; trivial.
subst y1 y2.
apply trans_clos_is_trans with y'.
apply trans_incl with R1; trivial.
intros; left; trivial.
left; right; trivial.
apply trans_incl with R1; trivial.
intros; left; trivial.
Qed.

Lemma acc_union :
  well_founded R1 ->
  forall a, Acc (compose_rel R2 (refl_trans_clos R1)) a <-> Acc (union _ R1 R2) a.
Proof.
intros W1'.
assert (W1 := wf_trans W1'); clear W1'.
intros a; split.
intro Acc_a; induction Acc_a as [a Acc_a' IH2].
assert (Acc_a : Acc (compose_rel R2 (refl_trans_clos R1)) a).
apply Acc_intro; trivial.
clear Acc_a'.
revert IH2 Acc_a.
pattern a; apply (well_founded_ind W1); clear a.
intros a IH1 IH2 Acc_a.
apply Acc_intro.
intros b [H1 | H2].
apply IH1.
apply t_step; trivial.
intros c H2; apply IH2.
inversion H2 as [c' d' b' H H']; subst.
apply Comp with d'; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; trivial.
apply Acc_intro; intros c H2.
apply Acc_inv with a; trivial.
inversion H2 as [c' d' b' H H']; subst.
apply Comp with d'; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; trivial.
apply IH2.
apply Comp with a; trivial.
apply r_step.

intro Acc_a; apply Acc_incl with (trans_clos (union _ R1 R2)).
intros a1 a3 H; inversion H as [b1 b2 b3 H1 H2]; clear H; subst a1 a3.
inversion H2 as [b | a2 a3 K2]; clear H2; subst.
left; right; assumption.
apply t_trans with b2.
right; assumption.
apply trans_incl with R1; trivial.
intros x y H; left; assumption.
apply acc_trans; assumption.
Qed.

Lemma acc_union_weak :
  forall a, Acc (compose_rel R2 (refl_trans_clos R1)) a ->
              (forall b, refl_trans_clos (compose_rel R2 (refl_trans_clos R1)) b a -> Acc R1 b) ->
              Acc (union _ R1 R2) a.
Proof.
intros a Acc_a H;
induction Acc_a as [a Acc_a' IH2].
assert (Acc_a : Acc (compose_rel R2 (refl_trans_clos R1)) a).
apply Acc_intro; trivial.
clear Acc_a'.
assert (Acc1_a : Acc R1 a).
apply H; left.
revert IH2 H Acc_a.
induction Acc1_a as [a Acc1_a IH1].
intros IH2 H Acc_a.
apply Acc_intro.
intros b [H1 | H2].
apply IH1; trivial.
intros c H2; apply IH2.
inversion H2 as [c' d' b' h H']; subst.
apply Comp with d'; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; trivial.
intros c K; inversion K; clear K; subst.
apply Acc1_a; assumption.
apply H.
rewrite trans_clos_trans_clos_alt in H0.
inversion H0; clear H0; subst.
right; left.
inversion H2; clear H2; subst.
apply Comp with a2; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; exact H1.
inversion H3; clear H3; subst.
apply refl_trans_clos_is_trans with y; trivial.
right; rewrite trans_clos_trans_clos_alt; assumption.
right; left.
apply Comp with a2; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; exact H1.
apply Acc_intro; intros c K.
apply Acc_inv with a; trivial.
inversion K; clear K; subst.
apply Comp with a2; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; exact H1.

apply IH2.
apply Comp with a; [assumption | left].
intros c K; apply H.
apply refl_trans_clos_is_trans with b; trivial.
right; left; apply Comp with a; [assumption | left].
Qed.

Lemma acc_union_alt :
  well_founded R1 ->
  forall a, (forall b, refl_trans_clos R1 b a -> Acc (compose_rel (refl_trans_clos R1) R2) b) <-> Acc (union _ R1 R2) a.
Proof.
intros W1'; split.
intro Ha; apply acc_union_weak; trivial.
apply Acc_intro; intros b4 H.
inversion H as [a4 b2 a1 H' H21]; clear H; subst.
assert (Acc_b2 := Ha b2 H21).
revert a Ha b4 H' H21; induction Acc_b2 as [b2 Acc_b2 IH].
intros a Ha b4 H' H21.
apply Acc_intro.
intros b6 H.
inversion H as [a6 b5 a4 H65 H54]; clear H; subst.
apply IH with b5 b4; trivial.
apply Comp with b4; trivial.
intros b7 H7.
apply Acc_b2.
apply Comp with b4; trivial.

intros Acc_a b H; apply Acc_incl with (trans_clos (union _ R1 R2)).
clear b H; intros a1 a3 H; inversion H as [b1 b2 b3 H1 H2]; clear H; subst a1 a3.
inversion H1 as [b | a2 a3 K1]; clear H1; subst.
left; right; assumption.
apply trans_clos_is_trans with b2.
apply trans_incl with R1; trivial.
intros x y H; left; assumption.
left; right; assumption.
inversion H as [a' | b' a' K]; clear H.
apply acc_trans; assumption.
subst; apply Acc_inv with a.
apply acc_trans; assumption.
apply trans_incl with R1; trivial.
intros x y H; left; assumption.
Qed.

Lemma acc_union_alt_weak :
  forall a, (forall b, refl_trans_clos (compose_rel R2 (refl_trans_clos R1)) b a -> Acc R1 b) ->
               (forall b, refl_trans_clos R1 b a -> Acc (compose_rel (refl_trans_clos R1) R2) b) ->
              Acc (union _ R1 R2) a.
Proof.
intros a H1a H2a.
apply acc_union_weak; trivial.
clear H1a.
apply Acc_intro; intros b4 H.
inversion H as [a4 b2 a1 H' H21]; clear H; subst.
assert (Acc_b2 := H2a b2 H21).
revert a H2a b4 H' H21; induction Acc_b2 as [b2 Acc_b2 IH].
intros a Ha b4 H' H21.
apply Acc_intro.
intros b6 H.
inversion H as [a6 b5 a4 H65 H54]; clear H; subst.
apply IH with b5 b4; trivial.
apply Comp with b4; trivial.
intros b7 H7.
apply Acc_b2.
apply Comp with b4; trivial.
Qed.

Lemma wf_union_alt :
  well_founded R1 ->
  (well_founded (compose_rel (refl_trans_clos R1) R2) <-> well_founded (union _ R1 R2)).
Proof.
intros W1'; split.
intro W; intro a; rewrite <- acc_union; trivial.
assert (W1 := wf_trans W1'); clear W1'.
apply Acc_intro.
intros b4 H.
inversion H as [a4 b2 a1 H' H21]; clear H; subst.
clear a H21.
revert b4 H'.
pattern b2; apply (well_founded_ind (wf_trans W)); clear b2.
intros a IH b H.
apply Acc_intro; intros c K.
inversion K as [d' c' b' H1 H2];clear K; subst.
apply IH with c'; trivial.
left; apply Comp with b; trivial.

intros W a; apply Acc_incl with (trans_clos (union _ R1 R2)).
intros a1 a3 H; inversion H as [b1 b2 b3 H1 H2]; clear H; subst a1 a3.
inversion H1 as [b | a2 a3 K1]; clear H1; subst.
left; right; assumption.
apply trans_clos_is_trans with b2.
apply trans_incl with R1; trivial.
intros x y H; left; assumption.
left; right; assumption.
apply acc_trans; apply W.
Qed.

Lemma acc_comp_incl :
  forall R, (forall a, Acc R a -> Acc (union _ R1 R2) a) ->
  forall a, Acc R a -> Acc (compose_rel (refl_trans_clos R1) R2) a.
Proof.
intros R H a Acc_a.
apply Acc_incl with (trans_clos (union _ R1 R2)).
clear; intros a b H.
inversion H as [c1 c2 c3 K1 K2]; clear H; subst.
inversion K1 as [c | b1 b2 K3 K4]; clear K1; subst.
left; right; assumption.
apply trans_clos_is_trans with c2.
apply trans_incl with R1; trivial.
clear; intros a b H; left; assumption.
left; right; assumption.
apply acc_trans.
apply H; assumption.
Qed.

End Compose.

Definition rest A P R := fun (a b : A) => R a b /\ P a /\ P b.

Lemma rest_union : forall A P (R1 R2 : relation A) a b, rest P (union _ R1 R2) a b <-> union _ (rest P R1) (rest P R2) a b.
intros A P R1 R2 a b; split.
intros [[H1 | H2] [Pa Pb]]; [left | right]; repeat split; assumption.
intros [[H1 [Pa Pb]] | [H2 [Pa Pb]]]; repeat split; trivial.
left; assumption.
right; assumption.
Qed.

Lemma rest_trans :
   forall A (P : A -> Prop) (R : relation A), (forall a b, P a -> R b a -> P b) ->
	forall a, P a -> forall b, trans_clos (rest P R) b a <-> trans_clos R b a.
Proof.
intros A P R Inv a Pa b; split.
apply trans_incl; intros x y [H _]; assumption.
intro H; rewrite trans_clos_trans_clos_alt in H; rewrite trans_clos_trans_clos_alt.
induction H as [x y K | x y z K1 K2].
left; repeat split; trivial.
apply Inv with y; assumption.
assert (Py := Inv _ _ Pa H).
right with y.
exact (K2 Py).
repeat split; assumption.
Qed.

Lemma acc_rest :
  forall A (R : relation A) (P : A -> Prop),
  (forall (a b : A), P a -> R b a -> P b) ->
  (forall a, (P a -> Acc R a) <-> Acc (rest P R) a).
Proof.
intros A R P Inv a; split.
intro K; apply Acc_intro; intros b [H [Wb Wa]].
apply Acc_inv with a; trivial.
apply Acc_incl with R.
clear; intros a b [H _]; assumption.
apply K; assumption.
repeat split; assumption.
intro Acc_a; induction Acc_a as [a Acc_a IH].
intro Pa; apply Acc_intro; intros b H.
apply IH.
repeat split; trivial.
apply Inv with a; assumption.
apply Inv with a; assumption.
Qed.

Lemma wf_rest :
  forall A (R : relation A) (P : A -> Prop),
  (forall (a b : A), P a -> R b a -> P b) ->
  ((forall a, P a -> Acc R a) <->  well_founded (rest P R)).
Proof.
intros A R P Inv; split.
intros W a; rewrite <- acc_rest; trivial.
apply W.
intros W a; rewrite acc_rest; trivial.
Qed.

Lemma acc_union_rest :
  forall A (R1 R2 : relation A) (P : A -> Prop),
  (forall (a b : A), P a -> R1 b a -> P b) ->
  (forall (a b : A), P a -> R2 b a -> P b) ->
  (forall a, P a -> Acc R1 a) ->
  forall a, P a -> Acc (compose_rel R2 (refl_trans_clos R1)) a -> Acc (union _ R1 R2) a.
Proof.
intros A R1 R2 P Inv1 Inv2 W1' a Wa Acc_a.
rewrite wf_rest in W1'.
set (R1' := fun a b => R1 a b /\ P a /\ P b) in *.
assert (W1 := wf_trans W1'); clear W1'.
revert Wa; induction Acc_a as [a Acc_a' IH2].
assert (Acc_a : Acc (compose_rel R2 (refl_trans_clos R1)) a).
apply Acc_intro; trivial.
clear Acc_a'.
revert IH2 Acc_a.
pattern a; apply (well_founded_ind W1); clear a.
intros a IH1 IH2 Acc_a Wa.
apply Acc_intro.
intros b [H1 | H2].
apply IH1.
apply t_step; repeat split; trivial.
apply Inv1 with a; trivial.
intros c H2; apply IH2.
inversion H2 as [c' d' b' H H']; subst.
apply Comp with d'; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; trivial.
apply Acc_intro; intros c H2.
apply Acc_inv with a; trivial.
inversion H2 as [c' d' b' H H']; subst.
apply Comp with d'; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; trivial.
apply Inv1 with a; trivial.
apply IH2.
apply Comp with a; trivial.
apply r_step.
apply Inv2 with a; trivial.
trivial.
Qed.

Lemma acc_union_rest_alt :
  forall A (R1 R2 : relation A) (P : A -> Prop),
  (forall (a b : A), P a -> R1 b a -> P b) ->
  (forall (a b : A), P a -> R2 b a -> P b) ->
  (forall a, P a -> Acc R1 a) ->
  (forall a, (forall b, refl_trans_clos R1 b a -> Acc (compose_rel (refl_trans_clos R1) R2) b) -> P a -> Acc (union _ R1 R2) a).
Proof.
intros A R1 R2 P Inv1 Inv2 W1' a W Pa.
assert (H : Acc (union _ (rest P R1) (rest P R2)) a).
rewrite <- acc_union_alt.
intros b H; apply Acc_incl with (compose_rel (refl_trans_clos R1) R2).
clear; intros a1 a2 H; inversion H as [c1 a c2 H1 [H2 _]]; subst.
apply Comp with a; [idtac | assumption].
apply refl_trans_incl with (rest P R1); [idtac | assumption].
clear; intros a1 a2 [H _]; assumption.
apply W.
apply refl_trans_incl with (rest P R1); [idtac | assumption].
clear; intros a1 a2 [H _]; assumption.
rewrite wf_rest in W1'; assumption.
clear W; revert Pa; induction H as [a Acc_a IH].
intro Pa; apply Acc_intro; intros a1 [H1 | H2]; apply IH.
left; repeat split; trivial.
apply Inv1 with a; assumption.
apply Inv1 with a; assumption.
right; repeat split; trivial.
apply Inv2 with a; assumption.
apply Inv2 with a; assumption.
Qed.

Lemma acc_union_rest_alt_weak :
  forall A (R1 R2 : relation A) (P : A -> Prop),
  (forall (a b : A), P a -> R1 b a -> P b) ->
  (forall (a b : A), P a -> R2 b a -> P b) ->
  forall a, (forall b, refl_trans_clos (compose_rel R2 (refl_trans_clos R1)) b a -> Acc R1 b) ->
               (forall b, refl_trans_clos R1 b a -> Acc (compose_rel (refl_trans_clos R1) R2) b) ->
               P a -> Acc (union _ R1 R2) a.
Proof.
intros A R1 R2 P Inv1 Inv2 a H1a H2a Pa.
assert (H : Acc (union _ (rest P R1) (rest P R2)) a).
apply acc_union_alt_weak.
intros b H; apply Acc_incl with R1.
clear; intros a1 a2 [H _]; assumption.
apply H1a.
apply refl_trans_incl with (compose_rel (rest P R2) (refl_trans_clos (rest P R1))); trivial.
clear; intros a1 a2 H; inversion H as [c1 a c2 H1 H2]; subst.
apply Comp with a.
inversion H1; trivial.
apply refl_trans_incl with (rest P R1); [idtac | assumption].
clear; intros a1 a2 [H _]; assumption.

intros b H; apply Acc_incl with (compose_rel (refl_trans_clos R1) R2).
clear; intros a1 a2 H; inversion H as [c1 a c2 H1 [H2 _]]; subst.
apply Comp with a; [idtac | assumption].
apply refl_trans_incl with (rest P R1); [idtac | assumption].
clear; intros a1 a2 [H _]; assumption.
apply H2a.
apply refl_trans_incl with (rest P R1); [idtac | assumption].
clear; intros a1 a2 [H _]; assumption.
clear H1a H2a; revert Pa; induction H as [a Acc_a IH].
intro Pa; apply Acc_intro; intros a1 [H1 | H2]; apply IH.
left; repeat split; trivial.
apply Inv1 with a; assumption.
apply Inv1 with a; assumption.
right; repeat split; trivial.
apply Inv2 with a; assumption.
apply Inv2 with a; assumption.
Qed.

Lemma accR2 : forall A (R : relation A) a, Acc R a <-> Acc (compose_rel R R) a.
Proof.
intros A R a; split.
intro Acc_a; apply Acc_incl with (trans_clos R).
intros x z H; inversion H as [x' y z' H1 H2]; clear H; subst; apply t_trans with y; trivial.
apply t_step; trivial.
apply acc_trans; trivial.
intros Acc_a; induction Acc_a as [a Acc_a IH].
apply Acc_intro; intros b H; apply Acc_intro; intros c H'.
apply IH; apply Comp with b; trivial.
Qed.

Lemma acc_inv_im :
	forall A B (R1 : relation A) (R2 : relation B) (f : A -> B),
	(forall a1 a2, R1 a1 a2 -> R2 (f a1) (f a2)) ->
	forall a, Acc R2 (f a) -> Acc R1 a.
Proof.
intros A B R1 R2 f H a.
set (b := f a) in *.
assert (b_eq_fa := eq_refl b).
unfold b at 2 in b_eq_fa; clearbody b.
intro Acc_b; revert a b_eq_fa; induction Acc_b as [b Acc_b IH].
intros a b_eq_fa; apply Acc_intro; intros a' H'.
apply IH with (f a'); trivial.
subst b; apply H; trivial.
Qed.

Lemma acc_inv_im2 :
   forall A B (R1 : relation A) (R2 : relation B) (f : A -> B),
  forall a, (forall a1 a2 a3, R1 a3 a2 -> R1 a2 a1 -> refl_trans_clos R1 a1 a -> R2 (f a2) (f a1)) ->
  Acc R2 (f a) -> Acc R1 a.
Proof.
intros A B R1 R2 f a Hinv Acc_b.
set (b := f a) in *.
assert (b_eq_fa := eq_refl b).
unfold b at 2 in b_eq_fa; clearbody b.
revert a b_eq_fa Hinv; induction Acc_b as [b Acc_b IH].
intros a b_eq_fa Hinv.
apply Acc_intro; intros a2 H2.
apply Acc_intro; intros a3 H3.
apply Acc_inv with a2; trivial.
apply IH with (f a2); trivial.
subst b; apply Hinv with a3; trivial.
left.
revert Hinv H2; clear; intros Hinv H2.
intros b1 b2 b3 K3 K2 K1.
apply Hinv with b3; trivial.
inversion K1 as [b | b' a' K1'].
right; left; assumption.
right; apply trans_clos_is_trans with a2; trivial.
left; assumption.
Qed.

Lemma acc_inv_im3 :
   forall A B (R1 : relation A) (R2 : relation B) (f : A -> B),
  forall a, (forall a1 a2, R1 a2 a1 -> refl_trans_clos R1 a1 a -> R2 (f a2) (f a1)) ->
  Acc R2 (f a) -> Acc R1 a.
Proof.
intros A B R1 R2 f a Hinv Acc_b.
set (b := f a) in *.
assert (b_eq_fa := eq_refl b).
unfold b at 2 in b_eq_fa; clearbody b.
revert a b_eq_fa Hinv; induction Acc_b as [b Acc_b IH].
intros a b_eq_fa Hinv.
apply Acc_intro; intros a2 H2.
apply IH with (f a2); trivial.
subst b; apply Hinv; trivial.
left.
revert Hinv H2; clear; intros Hinv H2.
intros b1 b2 K2 K1.
apply Hinv; trivial.
inversion K1 as [b | b' a' K1'].
right; left; assumption.
right; apply trans_clos_is_trans with a2; trivial.
left; assumption.
Qed.

Lemma union_equiv :
forall A R1 R2 R3 R4 (R1_equiv_R3: forall x y, R1 x y <-> R3 x y)
(R2_equiv_R4: forall x y, R2 x y <-> R4 x y) x y,
(union A R1 R2 x y <-> union _ R3 R4 x y).
Proof.
  intros A R1 R2 R3 R4 R1_equiv_R3 R2_equiv_R4 x y.
  split;intro H;case H.
  rewrite R1_equiv_R3;intro H';left;exact H'.
  rewrite R2_equiv_R4;intro H';right;exact H'.
  rewrite <- R1_equiv_R3;intro H';left;exact H'.
  rewrite <- R2_equiv_R4;intro H';right;exact H'.
Qed.

Lemma union_sym : forall A R1 R2 x y, union A R1 R2 x y <-> union A R2 R1 x y.
Proof.
  intros A R1 R2 x y.
  split;  (inversion_clear 1;[right|left];assumption).
Qed.

Lemma union_assoc :
  forall A R1 R2 R3 x y, union A (union A R1 R2) R3 x y <-> union A R1 (union A R2 R3) x y.
Proof.
  intros A R1 R2 R3 x y.
  split.
  intro H.
  case H;clear H;intro H.
  case H;clear H;intro H.
  left;assumption.
  right;left;assumption.
  right;right;assumption.
  intro H.
  case H;clear H;intro H.
  left;left;assumption.
  case H;clear H;intro H.
  left;right;assumption.
  right;assumption.
Qed.

Lemma union_idem : forall A R x y, union A R R x y <-> R x y.
Proof.
  intros A R x y.
  split.
  inversion_clear 1;assumption.
  intro H;left;assumption.
Qed.

Lemma union_idem_strong : forall A (R R': A -> A -> Prop) (H:forall x y, R x y -> R' x y) x y, (union A R R' x y <-> R' x y).
Proof.
  intros A R R' H x y.
  split.
  inversion_clear 1. apply H;assumption.
  assumption.
  intro H';right;assumption.
Qed.

Section star.
Unset Implicit Arguments.
Variable A:Type.
Variable R : A -> A -> Prop.
Inductive star (x:A) : A -> Prop :=
| star_refl : star x x
| star_step : forall y, star x y -> forall z, R y z -> star x z
.

Lemma star_trans: forall x y z, star x y -> star y z -> star x z.
Proof.
intros x y z H H1;revert x H;
induction H1.

tauto.
intros.
econstructor 2 with y0;auto.
Qed.

Lemma star_R : forall x y, R x y -> star x y.
Proof.
intros x y H;constructor 2 with x;[constructor|assumption].
Qed.

Lemma star_ind2 : forall  x (P:A -> Prop),
  (P x) ->
  (forall y, P y -> forall z, R y z -> P z) ->
  forall a, star x a -> P a.
Proof.
  intros x P H H0 a H1.
  induction H1.
  exact H.
  apply H0 with (y:=y);assumption.
Qed.

End star.

Lemma star_equiv :  forall A (R1 R2: A -> A -> Prop), (forall l r, R1 r l <-> R2 r l) ->
  forall l r, star _ R1 r l <-> star _ R2 r l.
Proof.
  intros A R1 R2 H l r.
  split;induction 1;try constructor.
  constructor 2 with y;auto.
  rewrite H in H1;assumption.
  constructor 2 with y;auto.
  rewrite H;assumption.
Qed.

Set Implicit Arguments.

Inductive product_o A B (R1 : relation A) (R2 : relation B) : relation (A*B)%type :=
	| CaseA : forall a a' b, R1 a a' -> product_o R1 R2 (a,b) (a',b)
	| CaseB : forall a b b', R2 b b' -> product_o R1 R2 (a,b) (a,b').

Lemma acc_and :
   forall A B (R1 : relation A) (R2 : relation B),
   forall a b, Acc R1 a -> Acc R2 b -> Acc (product_o R1 R2) (a,b).
Proof.
intros A B R1 R2 a b Acc_a; generalize b; clear b;
induction Acc_a as [a Acc_a IHa].
intros b Acc_b; generalize a Acc_a IHa; clear a Acc_a IHa;
induction Acc_b as [b Acc_b IHb]; intros a Acc_a IHa;
apply Acc_intro; intros [a' b'] H; inversion H; clear H; subst.
apply IHa; trivial.
apply Acc_intro; trivial.
apply IHb; trivial.
Defined.

Definition nf A (R : relation A) t := forall s, R s t -> False.

Lemma acc_nf : forall A (R : relation A) FB, (forall t s, In s (FB t) <-> R s t) ->
                          forall t, Acc R t -> { s : A | nf R s /\ (s = t \/ trans_clos R s t)}.
Proof.
intros A R FB red_dec t Acc_t; induction Acc_t as [t Acc_t IH].
case_eq (FB t).
intro H; exists t; split.
intros s H'; rewrite <- red_dec in H';  rewrite H in H'; trivial.
left; trivial.
intros a l H; destruct (IH a) as [a' [nf_a'  H']].
rewrite <- red_dec; rewrite H; left; trivial.
exists a'; split; trivial.
destruct H' as [a'_eq_a | H'].
subst; right; apply t_step; rewrite <- red_dec; rewrite H; left; trivial.
right; apply trans_clos_is_trans with a; trivial.
apply t_step; rewrite <- red_dec; rewrite H; left; trivial.
Defined.

Lemma dec_nf : forall A (R : relation A) FB, (forall t s, In s (FB t) <-> R s t) ->
                          forall t, {nf R t}+{~nf R t}.
Proof.
intros A R FB red_dec t.
case_eq (FB t).
intro H; left; unfold nf; intros s H'; rewrite <- red_dec in H'; rewrite H in H'; contradiction.
intros a l H.
right; intro H'; apply H' with a.
rewrite <- red_dec; rewrite H; left; trivial.
Defined.

Lemma cycle_not_acc : forall A (R : relation A) (a : A), R a a -> ~Acc R a.
Proof.
intros A R a H Acc_a; generalize H; clear H;
induction Acc_a as [a Acc_a IH].
intro H; apply (IH a); trivial.
Qed.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Logic.Classical_Prop.

Require Import Category.

Definition set_hom {U : Type} (X Y : Ensemble U) : Type :=
    {f : U -> U | forall x : U, In U X x -> In U Y (f x)}.

Definition set_hom_fn {U : Type} {X Y : Ensemble U} (hom : set_hom X Y) : U -> U :=
    match hom with exist f _ => f end.

Theorem set_hom_eq {U : Type} {X Y : Ensemble U} (f g : set_hom X Y) : set_hom_fn f = set_hom_fn g -> f = g.
    destruct f as [f pF]; destruct g as [g pG].
    simpl.
    intro H.
    subst f.
    assert (pF = pG) by (apply proof_irrelevance).
    rewrite H.
    reflexivity.
Qed.

Definition id_set {U : Type} (X : Ensemble U) : set_hom X X.
    refine (exist _ (fun u => u) _).
    trivial.
Defined.

Definition comp_set
        {U : Type} {X Y Z: Ensemble U}
        (f : set_hom Y Z) (g : set_hom X Y)
            : set_hom X Z.
    refine (match f with
        | exist f' pf =>
            match g with
                | exist g' pg =>
                    exist _ (fun (x : U) => f' (g' x)) _
                end
       end).
    unfold In in *.
    intuition.
Defined.

Instance SetIsCat (U : Type) : Category id_set (@comp_set U).
    Hint Unfold comp_set set_hom_fn id_set.
    split; intros; apply set_hom_eq;
        try (
            (*left/right identity*)
            destruct f;
            reflexivity
        ).
        (*composition*)
        destruct x.
        destruct y.
        destruct z.
        reflexivity.
Qed.

Definition SetCat (U : Type) : Cat :=
    cons_cat (Ensemble U) set_hom id_set (@comp_set U) (SetIsCat U).


Require Import XR_Rabs.
Require Import XR_Rabs_right.
Require Import XR_Rabs_R0.
Require Import XR_Rabs_Ropp.
Require Import XR_IZR.
Require Import XR_pos_INR.

Local Open Scope R_scope.

Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Z.abs z).
Proof.
  intros z.
  destruct z as [  | z | z ].
  {
    simpl.
    rewrite Rabs_R0.
    reflexivity.
  }
  {
    simpl.
    rewrite Rabs_right.
    { reflexivity. }
    { apply pos_INR. }
  }
  {
    simpl.
    rewrite Rabs_Ropp.
    rewrite Rabs_right.
    { reflexivity. }
    { apply pos_INR. }
  }
Qed.


Require Export D.

(** **** Exercise: 2 stars, optional (t_update_shadow)  *)
(** If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  intros. unfold t_update. apply functional_extensionality.
  intros. destruct (beq_id x x0).
  - reflexivity.
  - reflexivity.
Qed.


Require Import HoTT.
Local Open Scope path_scope.
Local Open Scope equiv_scope.

(* Exercise 3.1 *)

Theorem ex3_1 : forall A B, Equiv A B -> IsHSet A -> IsHSet B.
  intros A B eq h.
  destruct eq as [f i].

  (* There is a very important fact to remember about ap and equivalences! You
     will have a hard time solving this question without remembering it. *)
  SearchAbout ap IsEquiv.

  (* Annoyingly enough, this seems to be the idiomatic way to construct
     an IsHSet. Just cargo-cult it. *)
  intros x y; apply hprop_allpath; intros p q.

  (* Intuitively, the proof uses the equivalence to ferry an appropriate equality
     from the known set to the unknown set.  Of course, the details are a little touchy. *)

  assert (ap f^-1 p = ap f^-1 q) as H by (apply h).
  exact ((ap (ap f^-1))^-1 H).
Qed.

(* A generalized version of this statement is proved in the library. *)
Theorem ex3_1_library : forall A B, Equiv A B -> IsHSet A -> IsHSet B.
  intros A B e h.
  exact (trunc_equiv (equiv_fun _ _ e)).
Qed.

(* Here is a different proof that utilizes univalence.  Because it requires
   an axiom, it might be considered an inferior proof, but it is quite simple! *)
Theorem ex3_1_ua `{Univalence} : forall A B, Equiv A B -> IsHSet A -> IsHSet B.
  intros A B eq h.
  exact (transport IsHSet (equiv_path_universe _ _ eq) h).
Qed.

(* Exercise 3.2 *)

Theorem ex3_2 : forall A B, IsHSet A -> IsHSet B -> IsHSet (A + B).
  intros A B g h.
  (* Intuitively, this proof is all about the codes. Analyzing the path space
     over A + B otherwise is difficult.  In Chapter 2, we re-did the codes;
     here, we'll use a code provided by the standard library. *)
  SearchAbout sum paths.

  intros x y; apply hprop_allpath; intros p q.

  assert ((path_sum x y)^-1 p = (path_sum x y)^-1 q) as H.
    pose proof ((path_sum x y)^-1 p). (* just a little trick to make contradiction work *)
    destruct x; destruct y; try apply g; try apply h; try contradiction.

  exact ((ap (path_sum x y)^-1)^-1 H).
Qed.

(* The HoTT library has rather sophisticated type-class machinery for
   generating proofs of set-likeness, and this can be used to automatically
   dispatch the appropriate already existing lemma. *)
Theorem ex3_2_library : forall A B, IsHSet A -> IsHSet B -> IsHSet (A + B).
  typeclasses eauto.
Qed.

(* Exercise 3.3 *)

(* Warmup: *)
Example thm3_1_5 : forall A B, IsHSet A -> IsHSet B -> IsHSet (A * B).
  intros A B h g.
  intros x y; apply hprop_allpath; intros p q.
  assert (path_prod _ _ (ap fst p) (ap snd p) = p) as a by apply eta_path_prod.
  assert (path_prod _ _ (ap fst q) (ap snd q) = q) as b by apply eta_path_prod.
  assert (path_prod _ _ (ap fst p) (ap snd p) = path_prod _ _ (ap fst q) (ap snd q)) as c.
    f_ap. apply h. apply g.
  exact (a^ @ c @ b).
Qed.

Theorem ex3_3 : forall A B, IsHSet A -> (forall x : A, IsHSet (B x)) -> IsHSet (sigT B).
  intros A B h g.
  intros x y; apply hprop_allpath; intros p q.
  assert (path_sigma_uncurried _ _ _ (p..1; p..2) = p) as a by apply eta_path_sigma_uncurried.
  assert (path_sigma_uncurried _ _ _ (q..1; q..2) = q) as b by apply eta_path_sigma_uncurried.
  assert (p..1 = q..1) as sa by apply h.
  assert (path_sigma_uncurried _ _ _ (p..1; p..2) = path_sigma_uncurried _ _ _ (q..1; q..2)) as c.
    f_ap. (* f_ap seems to not know to do path_sigma_uncurried *)
    apply path_sigma_uncurried. exists sa. apply g. (* NB: we don't have to worry about transport! Try simpl *)
  exact (a^ @ c @ b).
Qed.

(* XXX Despite its simplicity, I think this exercise is quite hard (much like exercise 2.7),
because the added dependence makes many plausible approaches not work.  Here are some
approaches that no longer work:

 * 'p..2 = q..2' does not typecheck (the direct approach). More generally, things
   which you would like to have the same type don't, and inserting transports yourself
   don't seem to help things (similarly, consider eta_path_sigma)
 * You cannot 'destruct' the term 'sa : p..1 = q..2' on account of dependence (the "oh
   let's try path induction willy-nilly)
 * Using the curried path_sigma function means you cannot apply f_ap to take
   advantage of the structure of the path space revealed by path_sigma (the "surely
   the shorter name is better crowd")

The key insight of this problem is that the path space of a sigma type... is a sigma
type itself, which is witnessed by the equivalence path_sigma_uncurried (note the
uncurried: the sigma does NOT show up when things are curried; it's an implicit phenomenon
due to dependence in that case). So if we need to analyze a complicated path like
p = q, we turn it into a path of sigma types, and then use standard techniques (path_sigma
/again/) to finally crack it.

I suspect the lessons learned here also may provide some clues for how to improve f_ap
further, in the face of dependence and multiple arguments (model them as sigmas!)

*)

Theorem ex3_3_library : forall A B, IsHSet A -> (forall x : A, IsHSet (B x)) -> IsHSet (sigT B).
  typeclasses eauto.
Qed.

(* Exercise 3.4 *)
Lemma ex3_4_right `{Funext} : forall A, IsHProp A -> Contr (A -> A).
  intros A h. refine (BuildContr _ (fun x => x) _).
  intro f. apply path_forall. intro x. apply h. (* NB: tc resolution seems to defeat auto *)
Qed.

Lemma ex3_4_left : forall A, Contr (A -> A) -> IsHProp A.
  intros A [center h]. apply hprop_allpath; intros x y.
  SearchAbout pointwise_paths.
  pose proof (ap10 (h (fun _ => x)) x) ^ as p.
  pose proof (ap10 (h (fun _ => y)) x) as q.
  transitivity (center x); auto.
Qed.

Hint Resolve ex3_4_left ex3_4_right.
Theorem ex3_4 `{Funext} : forall A, IsHProp A <-> Contr (A -> A).
  constructor; auto.
Qed.

(* Exercise 3.5 *)

Definition ex3_5_f A (h : IsHProp A) := fun x => BuildContr _ x (fun y => allpath_hprop x y).
Definition ex3_5_inverse A (g : A -> Contr A) := hprop_allpath A (fun x y => let H := g x in path_contr x y).
Definition ex3_5_inverse' A (g : A -> Contr A) := fun x y => let H := g x in contr_paths_contr x y.

Theorem ex3_5 `{Funext} : forall A, Equiv (IsHProp A) (A -> Contr A).
  intro A.
  apply (equiv_adjointify (ex3_5_f A) (ex3_5_inverse A)); unfold Sect, ex3_5_f, ex3_5_inverse.
  intro f. apply path_forall. intro x. assert (IsHProp (Contr_internal A)) as X by typeclasses eauto. apply X.
  intro h. assert (IsHProp (IsHProp A)) as X by typeclasses eauto. apply X.
Qed.

Theorem ex3_5_library `{Funext} : forall A, Equiv (IsHProp A) (A -> Contr A).
  intros; apply equiv_hprop_inhabited_contr.
Qed.

(* Exercise 3.6 *)

Theorem ex3_6 `{Funext} : forall A, IsHProp A -> IsHProp (A + ~A).
  intros A h.
  apply hprop_allpath; intros x y.
  destruct x; destruct y; try contradiction; f_ap.
    apply h.
    apply path_forall; intro. contradiction. (* honestly, this should be a lemma *)
Qed.
(* NB: you can't do it without extensionality! *)

(* Exercise 3.7 *)

Theorem ex3_7 : forall A B, IsHProp A -> IsHProp B -> ~ (A * B) -> IsHProp (A + B).
  intros A B h g e.
  apply hprop_allpath; intros x y.
  destruct x; destruct y; try contradiction (e (a,b)); f_ap.
    apply h. apply g.
Qed.

(* Exercise 3.8 *)

Require Import Truncations.
Check Truncation.
Notation Squash A := (Truncation minus_one A).

Definition qinv {A B} (f : A -> B) := {g : B -> A & ((f o g = idmap) * (g o f = idmap))}.

Definition squash_qinv `{Funext} {A B} (f : A -> B) : Squash (qinv f) -> IsEquiv f.
  assert (IsHProp (IsEquiv f)) as t by typeclasses eauto.
  intro sq.
(*  Set Typeclasses Debug. *)
(*  refine (@Truncation_rect_nondep _ _ (IsEquiv f) _ (fun q => _) sq). *)
(*  infinite loops?
Debug: 1.1: exact t on (IsHProp (IsEquiv f))
Debug: 1.1: eapply cancelL_isequiv on (IsEquiv f)
Debug: 1.1.1.1: apply isequiv_path on (IsEquiv ?1060)
Debug: 1.1.2.1: apply @isequiv_compose on
(IsEquiv (transport idmap ?1065 o f))
Debug: 1.1.2.1.1.1: eapply cancelL_isequiv on (IsEquiv f)
Debug: 1.1.2.1.1.1.1.1: apply isequiv_path on (IsEquiv ?1107)
Debug: 1.1.2.1.1.1.2.1: apply @isequiv_compose on
(IsEquiv (transport idmap ?1112 o f))
*)
Abort.

(* Exercise 3.9 *)

(* oops, HoTT library doesn't seem to have LEM, see https://github.com/HoTT/HoTT/issues/299 *)
Class LEM :=
  { lem :> forall (A : Type), IsHProp A -> A + ~A }.

(* computation rules *)
Lemma lem_unit `{LEM} : lem Unit _ = inl tt.
  destruct (lem Unit _). destruct u. auto.
  contradiction (n tt).
Qed.
Lemma lem_empty `{LEM} `{Funext} : lem Empty _ = inr idmap.
  destruct (lem Empty _). contradiction. f_ap. apply ap10^-1. intro x. contradiction.
Qed.

Definition ex3_9_f `{LEM} : sigT IsHProp -> Bool.
  intro x.
  destruct (lem x.1 x.2).
  exact true.
  exact false.
Defined.

Definition ex3_9_inverse : Bool -> sigT IsHProp.
  intro b.
  destruct b.
  exists Unit; typeclasses eauto.
  exists Empty; typeclasses eauto.
Defined.

Theorem ex3_9 `{LEM} `{Univalence} : sigT IsHProp <~> Bool.
  apply (equiv_adjointify ex3_9_f ex3_9_inverse); unfold Sect, ex3_9_f, ex3_9_inverse.
    destruct x; simpl.
      (* meh, too difficult to do the rewrite *)
      destruct (lem Unit _); auto. contradiction (n tt).
      destruct (lem Empty _); auto. contradiction.
    destruct x as [A h]; simpl. destruct (lem A h).
      pose proof (contr_inhabited_hprop A a).
      pose proof equiv_contr_unit as g'.
      pose proof ((path_universe g') ^) as g.
      try apply (path_sigma IsHProp (Unit; trunc_succ) (A; h) g).
      (* universe inconsistency *)
Abort.

(* Exercise 3.10 *)

(* Exercise 3.11 *)

Definition thm3_2_2_e : Bool <~> Bool.
  apply (equiv_adjointify negb negb); unfold Sect; destruct x; trivial.
Defined.

Theorem thm3_2_2 `{Univalence} `{Funext} : ~ (forall A, ~~A -> A).
  intro f.
  (* NB: happly is called apD10 *)
  (* to work around universe inconsistency, you cannot path_universe in a Definition *)
  pose proof (fun u => apD10 (apD f (path_universe thm3_2_2_e)) u) as h.
  (* NB: lemma 2.9.4 is transport_arrow *)
  pose proof (fun u => @transport_arrow _ (fun A => ~~A) (fun A => A) _ _ (path_universe thm3_2_2_e) (f Bool) u) as g.
  assert (forall (u v : ~~Bool), u = v) as eq.
    intros; apply path_forall; intro x; contradiction (u x).
  assert (forall (u : ~~Bool), transport (fun A => ~~A) (path_universe thm3_2_2_e)^ u = u) as i.
    intros; apply eq.
  pose proof (fun u => (h u)^ @ g u @ ap (fun z => transport idmap (path_universe thm3_2_2_e) (f Bool z)) (i u)) as j.
  (* NB: 2.10 discussion is transport_path_universe *)
  pose proof (fun u => j u @ transport_path_universe thm3_2_2_e (f Bool u)) as k.
  assert (forall x : Bool, ~(thm3_2_2_e x = x)) as X.
    destruct x; unfold thm3_2_2_e; simpl. apply false_ne_true. apply true_ne_false.
  apply (X (f Bool (fun k => k true)) (k (fun k => k true))^).
Qed.

Corollary thm3_2_7 `{Univalence} `{Funext} : ~ (forall A, A + ~A).
  intro g.
  refine (thm3_2_2 (fun A => _)).
  intro u.
  destruct (g A). trivial. contradiction (u n).
Qed.

(* This is a copy-paste of Theorem 3.2.2, but with ~~ replaced with Squash and relevant proof terms adjusted *)
Theorem ex3_11 `{Univalence} `{Funext} : ~ (forall A, Squash A -> A).
  intro f.
  pose proof (fun u => apD10 (apD f (path_universe thm3_2_2_e)) u) as h.
  pose proof (fun u => @transport_arrow _ (fun A => Squash A) (fun A => A) _ _ (path_universe thm3_2_2_e) (f Bool) u) as g.
  assert (forall (u v : Squash Bool), u = v) as eq.
    intros. pose proof (istrunc_truncation minus_one Bool) as X. apply X.
  assert (forall (u : Squash Bool), transport (fun A => Squash A) (path_universe thm3_2_2_e)^ u = u) as i.
    intros; apply eq.
  pose proof (fun u => (h u)^ @ g u @ ap (fun z => transport idmap (path_universe thm3_2_2_e) (f Bool z)) (i u)) as j.
  pose proof (fun u => j u @ transport_path_universe thm3_2_2_e (f Bool u)) as k.
  assert (forall x : Bool, ~(thm3_2_2_e x = x)) as X.
    destruct x; unfold thm3_2_2_e; simpl. apply false_ne_true. apply true_ne_false.
  apply (X (f Bool (truncation_incl true)) (k (truncation_incl true))^).
Qed.

(* The result of this exercise is a generalization of Theorem 3.2.2, in
the following sense: *)
Theorem thm3_2_2' `{Univalence} `{Funext} : ~ (forall A, ~~A -> A).
  intro f.
  refine (ex3_11 (fun A => _)). intro sa. apply f.
  refine (Truncation_rect_nondep (fun a p => p a) sa).
Qed.
(* NB: typeclasses automatically resolved the proof that ~~A is an HProp *)
(* We will consider how to go the other direction in a later exercise. *)

(* jgross suggests an alternate proof uses HITs (observing that the circle
   is connected (squash) but not contractible (not squashed)). The basic idea
   is the same: here, we use univalence to construct a nontrivial path space,
   in the alternate proof, the circle provides the nontrivial path space. *)

(* Exercise 3.12 *)

Theorem ex3_12 `{LEM} : forall A, Squash (Squash A -> A).
  intro.
  apply truncation_incl. (* This can't be right. *)
Abort.

(* Exercise 3.13 *)

Theorem ex3_13 : (forall A, A + ~A) -> (forall X Y, IsHSet X -> (forall (x : X), IsHSet (Y x)) -> (forall x, Squash (Y x)) -> Squash (forall x, Y x)).
  intros lemi X Y xset yset h.
  destruct (lemi X).
  refine (Truncation_rect_nondep (fun syx => truncation_incl (fun x' => _)) (h x)).
Abort.


Set Warnings "-notation-overridden,-parsing".
Require Import Coq.omega.Omega.
Require Import Maps.
Require Import Imp.

Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b evaluates to true *)
    apply IHE1. assumption.
  - (* b evaluates to false (contradiction) *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* b evaluates to false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b evaluates to false *) reflexivity.
  - (* b evaluates to true (contradiction) *) rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0).
    { (* Proof of assertion *) apply IHE1_1. assumption. }
    subst st'0. apply IHE1_2. assumption. Qed.

(* The auto tactic *)

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

Example auto_example_1' : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

Example auto_example_2: forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P -> Q) -> (P -> S)) ->
  T ->
  P ->
  U.
Proof.
  auto.
Qed.

Example auto_example_3 : forall (P Q R S T U: Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  (* When it cannot solve the goal, auto does nothing *)
  auto.
  (* Optional argument says how deep to search (default is 5) *)
  auto 6.
Qed.

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof. auto. Qed.

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> (n = m).
Proof. intros. omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

Hint Resolve le_antisym.

Example auto_example_6' : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto.
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto. (* does nothing *)
Abort.

Hint Unfold is_fortytwo.

Example auto_example_7': forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
    induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0. auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *) rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *) rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *) rewrite H in H2; inversion H2.
  - (* E_WhileTrue *)
    + (* b evaluates to false (contradiction) *) rewrite H in H4; inversion H4.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1 by auto.
      subst st'. auto.
Qed.

Theorem ceval_deterministic'_alt: forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
      intros; inv E2...
  - (* E_Seq *)
    assert (st' = st'0) as EQ1...
    subst st'0...
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *) rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *) rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *) rewrite H in H2; inversion H2.
  - (* E_WhileTrue *)
    + (* b evaluates to false (contradiction) *) rewrite H in H4; inversion H4.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1...
      subst st'...
Qed.

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2...
  - (* E_Seq *)
    assert (st' = st'0) as EQ1...
    subst st'0...
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *) rwinv H H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *) rwinv H H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *) rwinv H H2.
  - (* E_WhileTrue *)
    + (* b evaluates to false (contradiction) *) rwinv H H4.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1...
      subst st'...
Qed.

Ltac find_rwinv :=
  match goal with
    H1 : ?E = true,
    H2 : ?E = false
    |- _ => rwinv H1 H2
  end.

Theorem ceval_deterministic''': forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1...
    subst st'0...
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1...
      subst st'0...
Qed.

Theorem ceval_deterministic'''' : forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    rewrite (IHE1_1 st'0 H1) in *. auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      rewrite (IHE1_1 st'0 H3) in *. auto.
Qed.

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

Theorem ceval_deterministic''''': forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.

Module Repeat.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall st st' st'' c1 c2,
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall b c1 c2 st st',
      beval st b = true ->
      ceval st c1 st' ->
      ceval st (IFB b THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall b c1 c2 st st',
      beval st b = false ->
      ceval st c2 st' ->
      ceval st (IFB b THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : forall b c st,
      beval st b = false ->
      ceval st (WHILE b DO c END) st
  | E_WhileTrue : forall b c st st' st'',
      beval st b = true ->
      ceval st c st' ->
      ceval st' (WHILE b DO c END) st'' ->
      ceval st (WHILE b DO c END) st''
  | E_RepeatEnd : forall b c st st',
      ceval st c st' ->
      beval st b = true ->
      ceval st (CRepeat c b) st'
  | E_RepeatLoop : forall b c st st' st'',
      ceval st c st' ->
      beval st b = false ->
      ceval st' (CRepeat c b) st'' ->
      ceval st (CRepeat c b) st''.

Notation "c1 '|' st '\\' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

Theorem ceval_deterministic: forall c st st1 st2,
  c / st \\ st1 ->
  c / st \\ st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
  repeat find_eqn; auto.
Qed.

End Repeat.

Example ceval_example1:
  (X ::= 2;;
   IFB X <= 1
    THEN Y ::= 3
    ELSE Z ::= 4
   FI)
  / { --> 0 }
  \\ { X --> 2 ; Z --> 4 }.
Proof.
  (* We supply the intermediate state st'... *)
  apply E_Seq with { X --> 2 }.
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

Example ceval'_example1:
  (X ::= 2;;
   IFB X <= 1
    THEN Y ::= 3
    ELSE Z ::= 4
   FI)
  / { --> 0 }
  \\ { X --> 2 ; Z --> 4 }.
Proof.
  eapply E_Seq. (* 1 *)
  - apply E_Ass. (* 2 *)
    reflexivity. (* 3 *)
  - (* 4 *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Definition st12 := { X --> 1 ; Y --> 2 }.
Definition st21 := { X --> 2 ; Y --> 1 }.

Example eauto_example : exists s',
  (IFB X <= Y
     THEN Z ::= Y - X
     ELSE Y ::= X + Z
   FI) / st21 \\ s'.
Proof. eauto. Qed.