Require Import List Morphisms Lia.
Require Import Undecidability.Synthetic.DecidabilityFacts Undecidability.Synthetic.EnumerabilityFacts Undecidability.Shared.partial Undecidability.Shared.embed_nat Undecidability.Synthetic.FinitenessFacts.
Export EmbedNatNotations.

(** ** Semi-decidability  *)

Definition equiv_sdec {X} := fun (f g : X -> nat -> bool) => forall x, (exists n, f x n = true) <-> exists n, g x n = true.

Instance Proper_semi_decider {X} :
  Proper (@equiv_sdec X ==> pointwise_relation X iff ==> iff ) (@semi_decider X).
Proof.
  intros f g H1 p q H2. red in H1, H2.
  unfold semi_decider.
  split; intros H x; cbn in H1.
  - now rewrite <- H2, H, H1.
  - now rewrite H2, H, H1.
Qed.

Instance Proper_semi_decidable {X} :
  Proper (pointwise_relation X iff ==> iff) (@semi_decidable X).
Proof.
  intros p q H2.
  split; intros [f H]; exists f; red.
  - intros x. now rewrite <- (H2 x).
  - intros x. now rewrite H2.
Qed.

Lemma semi_decider_ext {X} {p q : X -> Prop} {f g} :
  semi_decider f p -> semi_decider g q -> equiv_sdec f g -> p ≡{_} q.
Proof.
  unfold semi_decider. cbn.
  intros Hp Hq E x. red in E.
  now rewrite Hp, E, Hq.
Qed.

Lemma semi_decidable_part_iff {X} {p : X -> Prop} {Part : partiality}:
  semi_decidable p <-> exists Y (f : X -> part Y), forall x, p x <-> exists y, f x =! y.
Proof.
  split.
  - intros [f Hf].
    exists nat, (fun x => mu_tot (f x)). intros x.
    rewrite (Hf x). split; intros [n H].
    + eapply mu_tot_ter in H as [y H]. eauto.
    + eapply mu_tot_hasvalue in H as [H _]. eauto.
  - intros (Y & f & Hf). exists (fun x n => if seval (f x) n is Some _ then true else false).
    intros x. rewrite Hf. split.
    + intros [y H]. eapply seval_hasvalue in H as [n H].
      exists n. now rewrite H.
    + intros [n H]. destruct seval eqn:E; inversion H.
      eexists. eapply seval_hasvalue. eauto.
Qed.

Lemma forall_neg_exists_iff (f : nat -> bool) :
  (forall n, f n = false) <-> ~ exists n, f n = true.
Proof.
  split.
  - intros H [n Hn]. rewrite H in Hn. congruence.
  - intros H n. destruct (f n) eqn:E; try reflexivity.
    destruct H. eauto.
Qed.

Lemma semi_decider_co_semi_decider {X} (p : X -> Prop) f :
  semi_decider f p -> co_semi_decider f (complement p).
Proof.
  intros Hf.
  red in Hf. unfold complement. intros x. rewrite Hf.
  now rewrite forall_neg_exists_iff.
Qed.

Lemma semi_decidable_co_semi_decidable {X} (p : X -> Prop) :
  semi_decidable p -> co_semi_decidable (complement p).
Proof.
  intros [f Hf]. eapply ex_intro, semi_decider_co_semi_decider, Hf.
Qed.

Lemma co_semi_decidable_stable :
  forall X (p : X -> Prop), co_semi_decidable p -> stable p.
Proof.
  intros X p [f Hf] x Hx.
  eapply Hf. eapply forall_neg_exists_iff. red in Hf. rewrite Hf, forall_neg_exists_iff in Hx.
  tauto.
Qed.

Lemma decider_semi_decider  {X} {p : X -> Prop} f :
  decider f p -> semi_decider (fun x n => f x) p.
Proof.
  intros H x.
  unfold decider, reflects in H.
  rewrite H. now firstorder; econstructor.
Qed.

Lemma decider_co_semi_decider {X} {p : X -> Prop} f :
  decider f p -> co_semi_decider (fun x n => negb (f x)) p.
Proof.
  intros H x.
  unfold decider, reflects in H.
  rewrite H. split.
  - now intros -> _.
  - intros H0. destruct (f x); cbn in *; now try rewrite (H0 0).
Qed.

Lemma decidable_semi_decidable {X} {p : X -> Prop} :
  decidable p -> semi_decidable p.
Proof.
  intros [f H]. eapply ex_intro, decider_semi_decider, H.
Qed.

Lemma decidable_compl_semi_decidable {X} {p : X -> Prop} :
  decidable p -> semi_decidable (complement p).
Proof.
  intros H.
  now eapply decidable_semi_decidable, decidable_complement.
Qed.

Lemma decidable_co_semi_decidable {X} {p : X -> Prop} :
  decidable p -> co_semi_decidable p.
Proof.
  intros [f H]. eapply ex_intro, decider_co_semi_decider, H.
Qed.

Lemma semi_decidable_projection_iff X (p : X -> Prop) :
  semi_decidable p <-> exists (q : nat * X -> Prop), decidable q /\ forall x, p x <-> exists n, q (n, x).
Proof.
  split.
  - intros [d Hd].
    exists (fun '(n, x) => d x n = true). split.
    + exists (fun '(n,x) => d x n). intros [n x]. firstorder congruence.
    + intros x. eapply Hd.
  - intros (q & [f Hf] & Hq).
    exists (fun x n => f (n, x)). unfold semi_decider, decider, reflects in *.
    intros x. rewrite Hq. now setoid_rewrite Hf.
Qed.

Lemma semi_decider_and {X} {p q : X -> Prop} f g :
  semi_decider f p -> semi_decider g q -> semi_decider (fun x n => andb (existsb (f x) (seq 0 n)) (existsb (g x) (seq 0 n))) (fun x => p x /\ q x).
Proof.
  intros Hf Hg x.
  red in Hf, Hg |- *. rewrite Hf, Hg.
  setoid_rewrite Bool.andb_true_iff.
  setoid_rewrite existsb_exists.
  repeat setoid_rewrite in_seq. cbn.
  clear.
  split.
  - intros [[n1 Hn1] [n2 Hn2]].
    exists (1 + n1 + n2). firstorder lia.
  - firstorder.
Qed.

Lemma semi_decidable_and {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> semi_decidable (fun x => p x /\ q x).
Proof.
  intros [f Hf] [g Hg]. eapply ex_intro, semi_decider_and; eauto.
Qed.

Lemma reflects_cases {P} {b} :
  reflects b P -> b = true /\ P \/ b = false /\ ~ P.
Proof.
  destruct b; firstorder congruence.
Qed.

Lemma semi_decider_or {X} {p q : X -> Prop} f g :
  semi_decider f p -> semi_decider g q -> semi_decider (fun x n => orb (f x n) (g x n)) (fun x => p x \/ q x).
Proof.
  intros Hf Hg.
  red in Hf, Hg |- *. intros x.
  rewrite Hf, Hg.
  setoid_rewrite Bool.orb_true_iff.
  clear. firstorder.
Qed.

Lemma semi_decidable_or {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> semi_decidable (fun x => p x \/ q x).
Proof.
  intros [f Hf] [g Hg]. eapply ex_intro, semi_decider_or; eauto.
Qed.

Lemma semi_decidable_ex {X} {p : nat -> X -> Prop} :
  semi_decidable (fun pa => p (fst pa) (snd pa)) -> semi_decidable (fun x => exists n, p n x).
Proof.
  intros [f Hf].
  eapply semi_decidable_projection_iff.
  exists (fun '(n,x) => (fun! ⟨n1,n2⟩ => f (n1, x) n2 = true) n).
  split.
  - eapply dec_decidable. intros (n, x).
    destruct unembed. exact _.
  - intros x. setoid_rewrite (Hf (_, x)).
    split.
    + intros (n1 & n2 & H). exists ⟨n1, n2⟩. now rewrite embedP.
    + intros (n & H). destruct unembed as [n1 n2].
      exists n1, n2. eauto.
Qed.

Lemma co_semi_decider_and {X} {p q : X -> Prop} f g :
  co_semi_decider f p -> co_semi_decider g q -> co_semi_decider (fun x n => orb (f x n) (g x n)) (fun x => p x /\ q x).
Proof.
  intros Hf Hg x. red in Hf, Hg. rewrite Hf, Hg.
  setoid_rewrite Bool.orb_false_iff.
  clear. firstorder.
Qed.

Lemma co_semi_decidable_and {X} {p q : X -> Prop} :
  co_semi_decidable p -> co_semi_decidable q -> co_semi_decidable (fun x => p x /\ q x).
Proof.
  intros [f Hf] [g Hg]. eapply ex_intro, co_semi_decider_and; eauto.
Qed.

Lemma semi_decider_AC X g (R : X -> nat -> Prop) :
  semi_decider g (uncurry R) ->
  (forall x, exists y, R x y) ->
  ∑ f : X -> nat, forall x, R x (f x).
Proof.
  intros Hg Htot'. red in Hg. unfold uncurry in *.
  pose (R' x := fun! ⟨n,m⟩ => g (x,n) m = true).
  assert (Htot : forall x, exists n, R' x n). {
    subst R'. intros x. destruct (Htot' x) as (n & [m H] % (Hg (_, _))).
    exists ⟨n,m⟩. now rewrite embedP.
  }
  assert (Hdec : decider (fun '(x, nm) => let (n, m) := unembed nm in g (x, n) m) (uncurry R')). {
    unfold R'. unfold uncurry. intros (x, nm). destruct (unembed nm) as (n, m).
    destruct g; firstorder congruence.
  }
  eapply (decider_AC _ _ _ Hdec) in Htot as [f' Hf'].
  exists (fun x => (fun! ⟨n, m⟩ => n) (f' x)).
  intros x. subst R'. specialize (Hf' x). cbn in Hf'.
  destruct (unembed (f' x)). eapply (Hg (_, _)). eauto.
Qed.

(* Lemma sdec_compute_lor {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> (forall x, p x \/ q x) -> exists f : X -> bool, forall x, if f x then p x else q x.
Proof.
  intros [f_p Hp] [f_q Hq] Ho.
  unshelve eexists.
  - refine (fun x => let (n, H) := mu_nat (P := fun n => orb (f_p x n) (f_q x n) = true) (ltac:(cbn; decide equality)) _ in f_p x n).
    destruct (Ho x) as [[n H] % Hp | [n H] % Hq].
    + exists n. now rewrite H.
    + exists n. rewrite H. now destruct f_p.
  - intros x. cbn -[mu_nat]. destruct mu_nat.
    specialize (Hp x). specialize (Hq x).
    destruct (f_p) eqn:E1. eapply Hp. eauto.
    destruct (f_q) eqn:E2. eapply Hq. eauto.
    inversion e.
Qed.

 *)

(* ** Other  *)

Lemma d_semi_decidable_impl {X} {p q : X -> Prop} :
  decidable p -> semi_decidable q -> semi_decidable (fun x => p x -> q x).
Proof.
  intros [f Hf] [g Hg].
  exists (fun x n => if f x then g x n else true).
  intros x. split.
  - intros H. destruct (reflects_cases (Hf x)) as [ [-> H2] | [-> H2] ].
    + firstorder.
    + now exists 0.
  - intros [n H]. revert H.
    destruct (reflects_cases (Hf x)) as [ [-> H2] | [-> H2]]; intros H.
    + firstorder.
    + firstorder.
Qed.

Lemma d_co_semi_decidable_impl {X} {p q : X -> Prop} :
  decidable p -> semi_decidable (complement q) -> semi_decidable (complement (fun x => p x -> q x)).
Proof.
  intros [f Hf] [g Hg].
  exists (fun x n => if f x then g x n else false).
  intros x. split.
  - intros H. destruct (reflects_cases (Hf x)) as [ [-> H2] | [-> H2] ].
    + red in H. firstorder.
    + firstorder.
  - intros [n H]. revert H.
    destruct (reflects_cases (Hf x)) as [ [-> H2] | [-> H2]]; intros H.
    + firstorder.
    + firstorder congruence.
Qed.

Lemma co_semi_decidable_impl {X} {p q : X -> Prop} :
  (* (forall x, ~~ p x -> p x) -> *)
  semi_decidable (complement (complement p)) -> decidable q -> semi_decidable (complement (fun x => p x -> q x)).
Proof.
  intros [f Hf] [g Hg].
  exists (fun x n => if g x then false else f x n).
  intros x. split.
  - intros H. destruct (reflects_cases (Hg x)) as [ [-> H2] | [-> H2] ].
    + firstorder.
    + eapply Hf. firstorder.
  - intros [n H]. revert H.
    destruct (reflects_cases (Hg x)) as [ [-> H2] | [-> H2]]; intros H.
    + congruence.
    + intros ?. firstorder.
Qed.

Lemma semi_decidable_impl {X} {p q : X -> Prop} :
  semi_decidable (complement p) -> decidable q -> semi_decidable (fun x => p x -> q x).
Proof.
  intros [f Hf] [g Hg].
  exists (fun x n => if g x then true else f x n).
  intros x. split.
  - intros H. destruct (reflects_cases (Hg x)) as [ [-> H2] | [-> H2] ].
    + now exists 0.
    + eapply Hf. firstorder.
  - intros [n H]. revert H.
    destruct (reflects_cases (Hg x)) as [ [-> H2] | [-> H2]]; intros H.
    + eauto.
    + intros. firstorder.
Qed.

Lemma enumerator_semi_decider {X} {p : X -> Prop} d f :
  decider d (eq_on X) -> enumerator f p -> semi_decider (fun x n => if f n is Some y then d (x,y) else false) p.
Proof.
  intros Hd Hf x. red in Hf. rewrite Hf. split.
  - intros [n Hn]. exists n.
    rewrite Hn. now eapply Hd.
  - intros [n Hn]. exists n.
    destruct (f n); inversion Hn.
    eapply Hd in Hn. now subst.
Qed.

Lemma enumerable_semi_decidable {X} {p : X -> Prop} :
  discrete X -> enumerable p -> semi_decidable p.
Proof.
  unfold enumerable, enumerator.
  intros [d Hd] [f Hf].
  eexists. eapply enumerator_semi_decider; eauto.
Qed.

Lemma semi_decider_enumerator {X} {p : X -> Prop} e f :
  enumeratorᵗ e X -> semi_decider f p ->
  enumerator (fun! ⟨n,m⟩ => if e n is Some x then if f x m then Some x else None else None) p.
Proof.
  intros He Hf x. rewrite (Hf x). split.
  - intros [n Hn]. destruct (He x) as [m Hm].
    exists (embed (m,n)). now rewrite embedP, Hm, Hn.
  - intros [mn Hmn]. destruct (unembed mn) as (m, n).
    destruct (e m) as [x'|]; try congruence.
    destruct (f x' n) eqn:E; inversion Hmn. subst.
    exists n. exact E.
Qed.

Lemma semi_decidable_enumerable {X} {p : X -> Prop} :
  enumerableᵗ X -> semi_decidable p -> enumerable p.
Proof.
  unfold semi_decidable, semi_decider.
  intros [e He] [f Hf].
  now eapply ex_intro, semi_decider_enumerator.
Qed.


From QuickChick Require Import QuickChick.

Require Import List. Import ListNotations.
Require Import String. Open Scope string.

Inductive Tree :=
| Leaf : Tree
| Node : nat -> Tree -> Tree -> Tree.

Inductive Foo (A : Type) :=
| Foo1 : Foo A
| Foo2 : A -> Foo A -> Foo A -> Foo A.

Arguments Foo1 {A}.
Arguments Foo2 {A}.

Inductive NoParam : Foo nat -> Prop :=
| NoParam1 : NoParam Foo1
| NoParam2 : forall a f, NoParam f -> NoParam (Foo2 a f f).

Inductive Good {A : Type} : Foo A -> Prop :=
| Good1 : Good Foo1
| Good2 : forall a f, Good (Foo2 a f f).

QuickChickDebug Debug On.
MergeTest (fun x => NoParam x).
MergeTest (fun x => Good x).

Inductive bst : nat -> nat -> Tree -> Prop :=
| bst_leaf : forall lo hi, bst lo hi Leaf
| bst_node : forall lo hi x l r,
    le (S lo) x ->  le (S x) hi ->
    bst lo x l -> bst x hi r ->
    bst lo hi (Node x l r).

Inductive bal : nat -> Tree -> Prop :=
| bal_leaf0 : bal 0 Leaf
| bal_leaf1 : bal 1 Leaf
| bal_node : forall n t1 t2 m,
    bal n t1 -> bal n t2 -> bal (S n) (Node m t1 t2).

Derive (Arbitrary, Show) for Tree.

Merge (fun t => bst lo hi t) With (fun t => bal n t)
      As bst_bal.

Print bst_bal.

Fixpoint size (t : Tree) : nat :=
  match t with
  | Leaf => 0
  | Node x l r => 1 + max (size l) (size r)
  end.

(*
Inductive bstbal : nat -> nat -> nat -> Tree -> Prop :=
| leafleaf0 : forall lo hi, bstbal lo hi 0 Leaf
| leafleaf1 : forall lo hi, bstbal lo hi 1 Leaf
| nodenode : forall lo hi n x l r,
    le (S lo) x -> le (S x) hi ->
    bstbal lo hi n l -> bstbal x hi n r -> bstbal lo hi (S n) (Node x l r).

Derive ArbitrarySizedSuchThat for (fun t => bal n t).
Derive DecOpt for (bal n t).
Derive EnumSizedSuchThat for (fun n => bal n t).

Definition Empty {A} (e : E A) (n : nat) : bool :=
  match (Enumerators.run e n) with
  | LazyList.lnil => false
  | LazyList.lcons _ _ => true
  end.

Derive DecOpt for (le x y).

Derive ArbitrarySizedSuchThat for (fun x => le y x).

QuickChickWeights [ (bst_leaf, 1) ; (bst_node, size) ].
Derive ArbitrarySizedSuchThat for (fun t => bst lo hi t).

Derive ArbitrarySizedSuchThat for (fun t => bstbal a b c t).

Sample (@arbitrarySizeST _ (fun t => bst 0 10 t) _ 5).

Print GenSizedSuchThatbst.

Sample (@arbitrarySizeST _ (fun t => bst 0 42 t) _ 10).

Derive DecOpt for (bst lo hi t).

Check @decOpt.
Check GenSizedSuchThatbst.

Compute (@decOpt (bal 0 Leaf) _ 5).

Definition balBst_any_test :=
  forAllMaybe (@arbitrarySizeST _ (fun t => bst 0 42 t) _ 10)
              (fun t =>
                 if Empty (@enumSizeST _ (fun n => bal n t) _ 10) 10
                 then (collect (size t) (checker true)) else (checker tt)).

(*QuickChick balBst_any_test.*)

Definition balBst_merged :=
  forAllMaybe (@arbitrarySizeST _ (fun t => bstbal 0 42 3 t) _ 10)
              (fun t => checker true).

(* QuickChick balBst_merged. *)

(*An issue is that these two aren't really comparing the same thing.
Ideally, we should generate trees for which all three parameters can be
anything.*)

Inductive foo : nat -> Prop :=
| Foo1 : foo O
| Foo2 : forall n, foo n -> foo (S n)
| Foo3 : forall n1 n2, foo 0 -> foo (S n1) -> foo (S n2).

(*
Merge (fun t => bst lo hi t) With (fun t => bal n t)
      As bstbalmerged.
*)

 *)

(*Same variable name test:*)

Inductive P : nat -> Prop :=
| bla_P : forall n, P n.

Inductive Q : nat -> Prop :=
| bla_Q : forall n, Q (S n).

Merge (fun n => P n) With (fun n => Q n) As doesntgetusedanyway.

(*This should have a constructor!*)
Print doesntgetusedanyway.

(*Simple definition test*)
Definition naaat := nat.

Inductive P3 : naaat -> Prop:=.
Inductive Q3 : naaat -> Prop:=.

Merge (fun n => P3 n) With (fun n => Q3 n) As PQ3.

Print PQ3.

Inductive Term : Type :=
| var : nat -> Term
| app : Term -> Term -> Term
| lam : Term -> Term
| const : nat -> Term
| add : Term -> Term -> Term.

Inductive Ty : Type :=
| arr : Ty -> Ty -> Ty
| number : Ty.

(*
Definition Context := list Ty.
 *)

Inductive Var : list Ty -> Ty -> nat -> Prop :=
| zero : forall t g, Var (cons t g) t 0
| suc : forall a b g n, Var g a n -> Var (cons b g) a (S n).

Inductive typed : list Ty -> Ty -> Term -> Prop :=
| t_var : forall g n t, Var g t n -> typed g t (var n)
| t_app : forall a b g e1 e2, typed g (arr a b) e1 -> typed g a e2
                              -> typed g b (app e1 e2)
| t_lam : forall a b g e, typed (cons a g) b e -> typed g (arr a b) (lam e)
| t_const : forall n g, typed g number (const n)
| t_add : forall e1 e2 g, typed g number e1 -> typed g number e2 -> typed g number (add e1 e2).

Theorem falses : nat -> list bool.
Proof.
  intros n.
  induction n.
  - apply nil.
  - apply cons. apply false. apply IHn.
Defined.

Inductive nand : bool -> bool -> bool -> Prop :=
| nand_ff : nand false false true
| nand_ft : nand false true true
| nand_tf : nand true false true
| nand_tt : nand true true false.

Inductive combine : list bool -> list bool -> list bool -> Prop :=
| combine_nil : combine nil nil nil
| combine_cons : forall as1 as2 as3 a1 a2 a3, nand a1 a2 a3
      -> combine as1 as2 as3 -> combine (cons a1 as1) (cons a2 as2) (cons a3 as3).

Inductive var_linear : list bool -> nat -> Prop :=
| zero_lin : forall n, var_linear (true :: falses n) 0
| suc_lin : forall u n, var_linear u n -> var_linear (cons false u) (S n).

(*
Inductive linear : list bool -> Term -> Prop :=
| l_var : forall u n, var_linear u n -> linear u (var n)
| l_app : forall u1 u2 u3 e1 e2, linear u1 e1 -> linear u2 e2
                                 -> combine u1 u2 u3 -> linear u3 (app e1 e2)
| l_con  : forall len n, linear (falses len) (const n)
| l_lam : forall u e, linear (true :: u) e -> linear u (lam e)
| l_add : forall u1 u2 u3 e1 e2, linear u1 e1 -> linear u2 e2
                                 -> combine u1 u2 u3 -> linear u3 (add e1 e2).
*)

Inductive linear : list bool -> Term -> Prop :=
| l_var : forall u_ n_, var_linear u_ n_ -> linear u_ (var n_)
| l_app : forall u1_ u2_ u3_ e1_ e2_, linear u1_ e1_ -> linear u2_ e2_
                                 -> combine u1_ u2_ u3_ -> linear u3_ (app e1_ e2_)
| l_con  : forall len_ n_, linear (falses len_) (const n_)
| l_lam : forall u_ e_, linear (true :: u_) e_ -> linear u_ (lam e_)
| l_add : forall u1_ u2_ u3_ e1_ e2_, linear u1_ e1_ -> linear u2_ e2_
                                 -> combine u1_ u2_ u3_ -> linear u3_ (add e1_ e2_).

Merge (fun t => typed gamma ty t) With (fun t => linear used t) As typed_and_linear.
Print typed_and_linear.

Axiom sub : Term -> Term -> Term.

Inductive Even : nat -> Prop :=
| Z_Even : Even 0
| SS_Even : forall n, Even n -> Even (S (S n)).

Inductive Odd : nat -> Prop :=
| SZ_Odd : Odd 1
| SS_Odd : forall n, Odd n -> Odd (S (S n)).

Merge (fun n => Even n) With (fun n => Odd n) As EO.

Print EO.

Inductive step : Term -> Term -> Prop :=
| beta_step : forall e1 e2,
    step (app (lam e1) e2) (sub e1 e2).

Print typed.

Merge (fun t => typed gamma ty t) With (fun t => step t t2) As steptype.

Print steptype.

Inductive less : nat -> nat -> Prop :=
| less_n : forall n, less n n
| less_S : forall m n, less n m -> less n (S m).

Merge (fun y => less x y) With (fun y => less y z) As between.
Print between.


(* Notes on tactics *)
Require Import Merges.Tactics.LibTactics.

(* false / tryfalse: subsumes all these I think *)
  (* contradict H: proof by not H *)
  (* discriminate: proof by absurd assumption on equality of different constructors *)
  (* exfalso: proof by deriving False *)
Theorem eg_false
  (H: 0 = 1): False.
Proof. false. Qed.

(* destruct_all t: forall (x : t) in context, destruct *)

(* injects t *)
Theorem eg_injects n m
  (H : S (S n) = S m):
    S n = m.
Proof.
 injects~ H.
Qed.

(* Higher-order tactic notation *)
Tactic Notation "!" tactic(t) := t; easy'.
Theorem eg_now (xs : list nat): length xs > 0 -> xs <> nil.
Proof.
  !destruct xs.
Qed.

(* Destruct and remember *)
Theorem eg_destruct_eqn (xs : list nat): length xs > 0 -> xs <> nil.
Proof.
  destruct xs eqn:x.
  (* x : xs = nil *)
  easy.
  (* x : xs = (n :: l) *)
  easy.
Qed.

(* Induct and generalize *)
Theorem eg_induction_in (n m : nat) : n + m = m + n.
Proof.
  induction n in m |- *.
  (* equivalent to 'gen m; induction n; intros.' *)
  (* however only works for single thing *)
  auto.
  simpl. rewrite IHn. auto.
Qed.

(* decompose [and or] H; assumption *)

(* tauto can prove some things auto can't *)
(* intuition E splits the proof tree down to small goals and solves each with E. *)
(* "intuition auto" is better than "auto". *)
(* is "firstorder E" better than "intuition E"? *)

(* iauto := intuition with eauto *)
(* jauto and iauto destruct conjunction hypotheses before running auto.
   jauto also destructs existentials.
   iauto destructs disjunctions, but this can be slow if there are many branches. *)

(* congruence can solve a lot of things on equalities.
   I think it subsumes f_equal etc *)

(* psatz can solve some things omega can't, but requires a tool called csdp *)
(* https://coq.inria.fr/refman/Reference-Manual025.html *)

(* ring and field don't seem to be as powerful as omega, but can be extended to work on arbitrary rings *)
(* https://coq.inria.fr/refman/Reference-Manual028.html *)

(* rewrite, reflexivity, transitivity etc can be generalised to work on relations other than eq *)
(* this is probably useful for dealing with equivalence relations for example equivalence of evaluation *)
(* https://coq.inria.fr/refman/Reference-Manual030.html *)


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_A.

Coq < Goal forall f x p t:Prop, (((~f \/ x) -> (p \/ t)) /\ (f -> p) /\ ~p) -> t.
1 subgoal

  ============================
   forall f x p t : Prop, (~ f \/ x -> p \/ t) /\ (f -> p) /\ ~ p -> t

Unnamed_thm < intros.
1 subgoal

  f : Prop
  x : Prop
  p : Prop
  t : Prop
  H : (~ f \/ x -> p \/ t) /\ (f -> p) /\ ~ p
  ============================
   t

Unnamed_thm < elim H.
1 subgoal

  f : Prop
  x : Prop
  p : Prop
  t : Prop
  H : (~ f \/ x -> p \/ t) /\ (f -> p) /\ ~ p
  ============================
   (~ f \/ x -> p \/ t) -> (f -> p) /\ ~ p -> t

Unnamed_thm < intro.
1 subgoal

  f : Prop
  x : Prop
  p : Prop
  t : Prop
  H : (~ f \/ x -> p \/ t) /\ (f -> p) /\ ~ p
  H0 : ~ f \/ x -> p \/ t
  ============================
   (f -> p) /\ ~ p -> t

Unnamed_thm < intro.
1 subgoal

  f : Prop
  x : Prop
  p : Prop
  t : Prop
  H : (~ f \/ x -> p \/ t) /\ (f -> p) /\ ~ p
  H0 : ~ f \/ x -> p \/ t
  H1 : (f -> p) /\ ~ p
  ============================
   t

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder.

Unnamed_thm is defined

Coq <

*)

Section Exercise_A.
Goal forall f x p t:Prop, (((~f \/ x) -> (p \/ t)) /\ (f -> p) /\ ~p) -> t.
intros.
elim H.
intro.
intro.
firstorder.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable ltA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_8_2_1 : (forall A B C : Universe, (per_ A B C -> per_ C B A)).
Variable defrightangle_2 : (forall A B C : Universe, (exists X : Universe, (per_ A B C -> (betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C)))))).
Variable defrightangle2_3 : (forall A B C X : Universe, ((betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C))) -> per_ A B C)).
Variable lemma_rightangleNC_4 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable deftriangle_5 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_6 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable lemma_collinearorder_7 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable proposition_16_8 : (forall A B C D : Universe, ((triangle_ A B C /\ betS_ B C D) -> (ltA_ B A C A C D /\ ltA_ C B A A C D))).
Variable defcollinear_9 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_10 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_11 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_12 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_13 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_14 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_15 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_betweennotequal_16 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_ray4_1_17 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_18 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_19 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable cn_congruencereflexive_20 : (forall A B : Universe, cong_ A B A B).
Variable lemma_doublereverse_21 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable lemma_inequalitysymmetric_22 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinear4_23 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable defequalangles_24 : (forall A B C Ca Cb Cc : Universe, (exists U V Su Sv : Universe, (congA_ A B C Ca Cb Cc -> (out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C))))))))))).
Variable defequalangles2_25 : (forall A B C Ca Cb Cc U V Su Sv : Universe, ((out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C)))))))) -> congA_ A B C Ca Cb Cc)).
Variable lemma_equalanglessymmetric_26 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_angleorderrespectscongruence_27 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ congA_ P Q R D E F) -> ltA_ A B C P Q R)).
Variable proposition_19_28 : (forall A B C : Universe, ((triangle_ A B C /\ ltA_ B C A A B C) -> lt_ A B A C)).
Variable lemma_ABCequalsCBA_29 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_angleorderrespectscongruence2_30 : (forall A B C D E F Xa Xb Xc : Universe, ((ltA_ A B C D E F /\ congA_ Xa Xb Xc A B C) -> ltA_ Xa Xb Xc D E F)).
Variable cn_equalityreverse_31 : (forall A B : Universe, cong_ A B B A).
Variable lemma_lessthancongruence2_32 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ A B E F) -> lt_ E F C D)).
Variable lemma_lessthancongruence_33 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ C D E F) -> lt_ A B E F)).

Theorem lemma_legsmallerhypotenuse_34 : (forall A B C : Universe, (per_ A B C -> (lt_ A B A C /\ lt_ B C A C))).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import List.
Import ListNotations.
Set Implicit Arguments.

Section map.
Variable X : Type.
Hypothesis Xeq_dec : forall x x':X, {x = x'} + {x <> x'}.

(* Total and partial maps *)
Definition total_map (Y : Type) := X -> Y.

Definition t_empty {Y} (v : Y) : total_map Y :=
  (fun _ => v).

Definition t_update {Y : Type} (m : total_map Y) (x : X) (v : Y) :=
fun x' => match Xeq_dec x x' with
  | left _ => v
  | right _ => m x'
  end.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Definition partial_map (Y : Type) := total_map (option Y).

Definition add_mapping {Y : Type} (m : partial_map Y)
           (x : X) (v : Y) :=
  (x !-> Some v ; m).

Fixpoint add_mappings {Y : Type} (m : partial_map Y) (xs : list X) (ys : list Y) :=
  match xs, ys with
  | x :: xs', y :: ys' => add_mapping (add_mappings m xs' ys') x y
  | _, _ => m
  end.

Definition empty {Y : Type} : partial_map Y :=
  t_empty None.

End map.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                   Solange Coupet-Grimal & Line Jakubiec                  *)
(*                                                                          *)
(*                                                                          *)
(*              Laboratoire d'Informatique de Marseille                     *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lim.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              May 30th 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                           Factorization_Verif.v                          *)
(****************************************************************************)

Require Export Linear_Structures.
Require Export Factorization.

Section Factorization_for_Verification.

  Variable A : Set.
  Variable BASE : BT.
  Let b := base BASE.
  Let Num := num BASE.
  Let Digit := digit BASE.
  Let Val_bound := val_bound BASE.

  Variable R : forall n : nat, A -> inf n -> inf n -> A -> Prop.

  Definition Connection := connection A Digit Digit (R b).

  Notation Factorizable := (factorizable _) (only parsing).
  Notation Proper := (proper _) (only parsing).

  Theorem factorization_for_verification :
   factorizable _ R ->
   proper _ BASE R ->
   forall (n : nat) (X Y : Num n) (a a' : A),
   Connection n a X Y a' -> R (exp b n) a (Val_bound n X) (Val_bound n Y) a'.
    intros F P.
    simple induction 1.
    unfold proper in P; auto.
    clear H X Y n a a'.
    intros n a a1 a' d d' D D' H C H_rec.
    simpl in |- *.
    apply F with d d' (Val_bound n D) (Val_bound n D') a1;
     try trivial; unfold Diveucl in |- *;
     split; simpl in |- *.
    elim (mult_comm (exp (base BASE) n) (val BASE d)); unfold val in |- *;
     unfold val_inf in |- *; auto.
    unfold b in |- *; apply upper_bound.
    elim (mult_comm (exp (base BASE) n) (val BASE d')); unfold val in |- *;
     unfold val_inf in |- *; auto.
    unfold b in |- *; apply upper_bound.
    Qed.

End Factorization_for_Verification.

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


Require Import Arith Lib.Word Lib.Nlia Lia.

Set Asymmetric Patterns.
Set Implicit Arguments.
Local Open Scope word_scope.

Lemma wordToNat_eq1: forall sz (a b: word sz), a = b -> wordToNat a = wordToNat b.
Proof.
  intros; subst; reflexivity.
Qed.

Lemma wordToNat_eq2: forall sz (a b: word sz), wordToNat a = wordToNat b -> a = b.
Proof.
  intros.
  rewrite <- natToWord_wordToNat with (w := a).
  rewrite <- natToWord_wordToNat with (w := b).
  rewrite H.
  reflexivity.
Qed.

Lemma wordToN_to_nat sz: forall (w: word sz), BinNat.N.to_nat (wordToN w) = wordToNat w.
Proof.
  intros.
  rewrite wordToN_nat.
  rewrite Nnat.Nat2N.id.
  reflexivity.
Qed.

Lemma wordToNat_lt1: forall sz (a b: word sz), a < b -> (wordToNat a < wordToNat b)%nat.
Proof.
  intros.
  pre_nlia.
  repeat rewrite wordToN_to_nat in H.
  assumption.
Qed.

Lemma wordToNat_lt2: forall sz (a b: word sz), (wordToNat a < wordToNat b)%nat -> a < b.
Proof.
  intros.
  pre_nlia.
  repeat rewrite wordToN_to_nat.
  assumption.
Qed.

Lemma wordToNat_gt1: forall sz (a b: word sz), a > b -> (wordToNat a > wordToNat b)%nat.
Proof.
  intros.
  pre_nlia.
  repeat rewrite wordToN_to_nat in H.
  assumption.
Qed.

Lemma wordToNat_gt2: forall sz (a b: word sz), (wordToNat a > wordToNat b)%nat -> a > b.
Proof.
  intros.
  pre_nlia.
  repeat rewrite wordToN_to_nat.
  assumption.
Qed.

Lemma wordToNat_le1: forall sz (a b: word sz), a <= b -> (wordToNat a <= wordToNat b)%nat.
Proof.
  intros.
  pre_nlia.
  repeat rewrite wordToN_to_nat in H.
  assumption.
Qed.

Lemma wordToNat_le2: forall sz (a b: word sz), (wordToNat a <= wordToNat b)%nat -> a <= b.
Proof.
  intros.
  pre_nlia.
  repeat rewrite wordToN_to_nat.
  assumption.
Qed.

Lemma wordToNat_ge1: forall sz (a b: word sz), a >= b -> (wordToNat a >= wordToNat b)%nat.
Proof.
  intros.
  pre_nlia.
  repeat rewrite wordToN_to_nat in H.
  assumption.
Qed.

Lemma wordToNat_ge2: forall sz (a b: word sz), (wordToNat a >= wordToNat b)%nat -> a >= b.
Proof.
  intros.
  pre_nlia.
  repeat rewrite wordToN_to_nat.
  assumption.
Qed.

Lemma wordToNat_neq1: forall sz (a b: word sz), a <> b -> wordToNat a <> wordToNat b.
Proof.
  unfold not.
  intros.
  apply wordToNat_eq2 in H0.
  tauto.
Qed.

Lemma wordToNat_neq2: forall sz (a b: word sz), wordToNat a <> wordToNat b -> a <> b.
Proof.
  unfold not.
  intros.
  subst.
  tauto.
Qed.

Lemma wordNotNot: forall sz (a b: word sz), (a <> b -> False) -> a = b.
Proof.
  intros.
  destruct (weq a b); subst; tauto.
Qed.

Ltac pre_word_lia :=
  unfold wzero, wone in *;
  repeat match goal with
           | H: @eq ?T ?a ?b |- _ =>
             match T with
               | word ?sz =>
                 apply (@wordToNat_eq1 sz a b) in H;
                   rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one in H;
                   simpl in H
             end
           | |- @eq ?T ?a ?b =>
             match T with
               | word ?sz =>
                 apply (@wordToNat_eq2 sz a b);
                   rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one;
                   simpl
             end
           | H: ?a < ?b |- _ =>
             apply wordToNat_lt1 in H;
               rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one in H;
               simpl in H
           | |- ?a < ?b =>
             apply wordToNat_lt2;
               rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one;
               simpl
           | H: ?a > ?b |- _ =>
             apply wordToNat_gt1 in H;
               rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one in H;
               simpl in H
           | |- ?a > ?b =>
             apply wordToNat_gt2;
               rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one;
               simpl
           | H: ?a <= ?b |- _ =>
             apply wordToNat_le1 in H;
               rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one in H;
               simpl in H
           | |- ?a <= ?b =>
             apply wordToNat_le2;
               rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one;
               simpl
           | H: ?a > ?b -> False |- _ =>
             apply wordToNat_le1 in H;
               rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one in H;
               simpl in H
           | |- ?a > ?b -> False =>
             apply wordToNat_le2;
               rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one;
               simpl
           | H: ?a < ?b -> False |- _ =>
             apply wordToNat_ge1 in H;
               rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one in H;
               simpl in H
           | |- ?a < ?b -> False =>
             apply wordToNat_ge2;
               rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one;
               simpl
           | H: not (@eq ?T ?a ?b) |- _ =>
             match T with
               | word ?sz =>
                 apply (@wordToNat_neq1 sz a b) in H;
                   rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one in H;
                   simpl in H
             end
           | |- not (@eq ?T ?a ?b) =>
             match T with
               | word ?sz =>
                 apply (@wordToNat_neq2 sz a b);
                   rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one;
                   simpl
             end
           | H: @eq ?T ?a ?b -> False |- _ =>
             match T with
               | word ?sz =>
                 apply (@wordToNat_neq1 sz a b) in H;
                   rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one in H;
                   simpl in H
             end
           | |- @eq ?T ?a ?b -> False =>
             match T with
               | word ?sz =>
                 apply (@wordToNat_neq2 sz a b);
                   rewrite ?roundTrip_0, ?roundTrip_1, ?wones_pow2_minus_one;
                   simpl
             end
           | H: (@eq ?T ?a ?b -> False) -> False |- _ =>
             match T with
               | word ?sz =>
                 apply (@wordNotNot sz a b) in H
             end
           | H: (not (@eq ?T ?a ?b)) -> False |- _ =>
             match T with
               | word ?sz =>
                 apply (@wordNotNot sz a b) in H
             end
           | H: not (@eq ?T ?a ?b -> False) |- _ =>
             match T with
               | word ?sz =>
                 apply (@wordNotNot sz a b) in H
             end
           | H: not (not (@eq ?T ?a ?b)) |- _ =>
             match T with
               | word ?sz =>
                 apply (@wordNotNot sz a b) in H
             end
         end.

Ltac word_lia := pre_word_lia; lia.

Lemma word_le_ge_eq sz (w1 w2: word sz): w1 <= w2 -> w1 >= w2 -> w1 = w2.
Proof.
  intros; word_lia.
Qed.

Lemma word_le_zero sz (w: word sz): w <= wzero sz -> w = wzero sz.
Proof.
  intros;
  word_lia.
Qed.


(** * paterson: Equivalence of two flowchart schemes, due to Paterson
   cf. "Mathematical theory of computation", Manna, 1974
   cf. "Kleene algebra with tests and program schematology", A. Angus and D. Kozen, 2001
*)

From RelationAlgebra Require Import kat normalisation rewriting move kat_tac comparisons rel.
Set Implicit Arguments.

(** * Memory model  *)

(** we need only five memory locations: the [y_i] are temporary
   variables and [io] is used for input and output *)
Inductive loc := y1 | y2 | y3 | y4 | io.
Record state := { v1: nat; v2: nat; v3: nat; v4: nat; vio: nat }.

(** getting the content of a memory cell *)
Definition get x := match x with y1 => v1 | y2 => v2 | y3 => v3 | y4 => v4 | io => vio end.

(** setting the content of a memory cell *)
Definition set x n m :=
  match x with
    | y1 => {| v1:=n; v2:=v2 m; v3:=v3 m; v4:=v4 m; vio:=vio m |}
    | y2 => {| v1:=v1 m; v2:=n; v3:=v3 m; v4:=v4 m; vio:=vio m |}
    | y3 => {| v1:=v1 m; v2:=v2 m; v3:=n; v4:=v4 m; vio:=vio m |}
    | y4 => {| v1:=v1 m; v2:=v2 m; v3:=v3 m; v4:=n; vio:=vio m |}
    | io => {| v1:=v1 m; v2:=v2 m; v3:=v3 m; v4:=v4 m; vio:=n |}
  end.

(** basic properties of [get] and [set] *)
Lemma get_set x v m: get x (set x v m) = v.
Proof. now destruct x. Qed.

Lemma get_set' x y v m: x<>y -> get x (set y v m) = get x m.
Proof. destruct y; destruct x; simpl; trivial; congruence. Qed.

Lemma set_set x v v' m: set x v (set x v' m) = set x v m.
Proof. now destruct x. Qed.

Lemma set_set' x y v v' m: x<>y -> set x v (set y v' m) = set y v' (set x v m).
Proof. destruct y; destruct x; simpl; trivial; congruence. Qed.

(** comparing locations *)
Definition eqb x y :=
  match x,y with
    | y1,y1 | y2,y2 | y3,y3 | y4,y4 | io,io => true
    | _,_ => false
  end.
Lemma eqb_spec: forall x y, reflect (x=y) (eqb x y).
Proof. destruct x; destruct y; simpl; try constructor; congruence. Qed.
Lemma eqb_false x y: x<>y -> eqb x y = false.
Proof. case eqb_spec; congruence. Qed.
Lemma neqb_spec x y: negb (eqb x y) <-> x<>y.
Proof. case eqb_spec; intuition; congruence. Qed.

(** * Arithmetic and Boolean expressions *)

Section s.

(** we assume arbitrary functions to interpret symbols [f], [g], and [p]  *)
Variable ff: nat -> nat.
Variable gg: nat -> nat -> nat.
Variable pp: nat -> bool.

(** we use a single inductive to represent Arithmetic and Boolean
   expressions: this allows us to share code about evaluation, free
   variables and so on, through polymorphism *)
Inductive expr: Set -> Set :=
  | e_var: loc -> expr nat
  | O: expr nat
  | f': expr nat -> expr nat
  | g': expr nat -> expr nat -> expr nat
  | p': expr nat -> expr bool
  | e_cap: expr bool -> expr bool -> expr bool
  | e_cup: expr bool -> expr bool -> expr bool
  | e_neg: expr bool -> expr bool
  | e_bot: expr bool
  | e_top: expr bool.

Coercion e_var: loc >-> expr.

(** ** evaluation of expressions  *)
Fixpoint eval A (e: expr A) (m: state): A :=
  match e with
    | e_var x => get x m
    | O => 0%nat
    | f' e => ff (eval e m)
    | g' e f => gg (eval e m) (eval f m)
    | p' e => pp (eval e m)
    | e_cap e f => eval e m &&& eval f m
    | e_cup e f => eval e m ||| eval f m
    | e_neg e => negb (eval e m)
    | e_bot => false
    | e_top => true
  end.

(** ** Free variables *)

Fixpoint free y A (e: expr A): bool :=
  match e with
    | e_var x => negb (eqb x y)
    | f' e | p' e | e_neg e => free y e
    | g' e f | e_cap e f | e_cup e f => free y e &&& free y f
    | _ => true
  end.

(** ** Substitution *)

Fixpoint subst x v A (f: expr A): expr A :=
  match f with
    | e_var y => if eqb x y then v else e_var y
    | O => O
    | f' e => f' (subst x v e)
    | p' e => p' (subst x v e)
    | g' e f => g' (subst x v e) (subst x v f)
    | e_cup e f => e_cup (subst x v e) (subst x v f)
    | e_cap e f => e_cap (subst x v e) (subst x v f)
    | e_neg e => e_neg (subst x v e)
    | e_bot => e_bot
    | e_top => e_top
  end.

Lemma subst_free x v A (e: expr A): free x e -> subst x v e = e.
Proof.
  induction e; simpl; trivial.
   rewrite neqb_spec. case eqb_spec; congruence.
   intro. now rewrite IHe.
   rewrite landb_spec. intros [? ?]. now rewrite IHe1, IHe2.
   intro. now rewrite IHe.
   rewrite landb_spec. intros [? ?]. now rewrite IHe1, IHe2.
   rewrite landb_spec. intros [? ?]. now rewrite IHe1, IHe2.
   intro. now rewrite IHe.
Qed.

Lemma free_subst x e A (f: expr A): free x e -> free x (subst x e f).
Proof.
  intro. induction f; simpl; rewrite ?IHf1; auto.
  case eqb_spec; trivial. simpl. rewrite neqb_spec. congruence.
Qed.

(** * Programs *)
(** We just use KAT expressions, since any gflowchat scheme can be encoded as such an expression *)
Inductive prog :=
| p_tst(t: expr bool)
| p_aff(x: loc)(e: expr nat)
| p_str(p: prog)
| p_dot(p q: prog)
| p_pls(p q: prog).

(** * Bigstep semantics *)

(** updating the memory, according to the assignment [x<-e] *)
Definition update x e m := set x (eval e m) m.
(** relational counterpart of this function *)
Notation upd x e := (frel (update x e)).

(** Bigstep semantics, as a fixpoint *)
Fixpoint bstep (p: prog): hrel state state :=
  match p with
    | p_tst p => [eval p: dset state]
    | p_aff x e => upd x e
    | p_str p => (bstep p)^*
    | p_dot p q => bstep p ⋅ bstep q
    | p_pls p q => bstep p + bstep q
  end.

(** auxiliary lemma relating the evaluation of expressions, the
   assignments to the memory, and subsitution of expressions *)
Lemma eval_update x v A (e: expr A) m: eval e (update x v m) = eval (subst x v e) m.
Proof.
  induction e; simpl; try congruence.
   unfold update. case eqb_spec. intros <-. apply get_set.
   intro. apply get_set'. congruence.
  now rewrite IHe1, IHe2.
  now rewrite IHe1, IHe2.
Qed.

(** Now we make the set of programs a Kleene algebra with tests: we
   declare canonical structures for Boolean expressions (tests),
   programs (Kleene elements), and the natural injection of the former
   into the latter *)

Canonical Structure expr_lattice_ops: lattice.ops := {|
  car := expr bool;
  leq := fun x y => eval x ≦ eval y;
  weq := fun x y => eval x ≡ eval y;
  cup := e_cup;
  cap := e_cap;
  bot := e_bot;
  top := e_top;
  neg := e_neg
|}.

Canonical Structure prog_lattice_ops: lattice.ops := {|
  car := prog;
  leq := fun x y => bstep x ≦ bstep y;
  weq := fun x y => bstep x ≡ bstep y;
  cup := p_pls;
  cap := assert_false p_pls;
  bot := p_tst e_bot;
  top := assert_false (p_tst e_bot);
  neg := assert_false id
|}.

Canonical Structure prog_monoid_ops: monoid.ops := {|
  ob  := unit;
  mor n m := prog_lattice_ops;
  dot n m p := p_dot;
  one n := p_tst e_top;
  itr n := (fun x => p_dot x (p_str x));
  str n := p_str;
  cnv n m := assert_false id;
  ldv n m p := assert_false (fun _ => id);
  rdv n m p := assert_false (fun _ => id)
|}.

Canonical Structure prog_kat_ops: kat.ops := {|
  kar := prog_monoid_ops;
  tst n := expr_lattice_ops;
  inj n := p_tst
|}.

Notation prog' := (prog_kat_ops tt tt).
Notation test := (@tst prog_kat_ops tt).

(** proving that the laws of KAT are satisfied is almost trivial,
   since the model faithfully embeds in the relational model *)

Instance expr_lattice_laws: lattice.laws BL expr_lattice_ops.
Proof.
  apply laws_of_injective_morphism with (@eval bool: expr bool -> dset state); trivial.
  split; simpl; tauto.
Qed.

Instance prog_monoid_laws: monoid.laws BKA prog_monoid_ops.
Proof.
  apply laws_of_faithful_functor with (fun _ => state) (fun _ _: unit => bstep); trivial.
  split; simpl; try discriminate; try tauto. 2: firstorder.
  split; simpl; try discriminate; try tauto. firstorder auto with bool.
Qed.
Instance prog_lattice_laws: lattice.laws BKA prog_lattice_ops := lattice_laws tt tt.

Instance prog_kat_laws: kat.laws prog_kat_ops.
Proof.
  constructor; simpl; eauto with typeclass_instances. 2: tauto.
  split; try discriminate; try (simpl; tauto).
  intros x y H. apply inj_leq. intro m. apply H.
  intros x y H. apply inj_weq. intro m. apply H.
  intros _ x y. apply (inj_cup (X:=hrel_kat_ops)).
  intros _ x y. apply (inj_cap (X:=hrel_kat_ops)).
Qed.

(** ** variables read by a program *)

(** [dont_read y p] holds if [p] never reads [y] *)
Fixpoint dont_read y (p: prog'): bool :=
  match p with
    | p_str p => dont_read y p
    | p_dot p q | p_pls p q => dont_read y p &&& dont_read y q
    | p_aff x e => free y e
    | p_tst t => free y t
  end.

(** ** Additional notation  *)

Infix " ;" := (dot _ _ _) (left associativity, at level 40): ra_terms.
Definition aff x e: prog' := p_aff x e.
Notation "x <- e" := (aff x e) (at level 30).
Notation del y := (y<-O).

(** * Laws of schematic KAT *)

Arguments hrel_monoid_ops : simpl never.
Arguments hrel_lattice_ops : simpl never.

(** (the numbering corresponds to Angus and Kozen's paper)  *)
Lemma eq_6 (x y: loc) (s t: expr nat):
  negb (eqb x y) &&& free y s -> x<-s;y<-t ≡ y<-subst x s t; x<-s.
Proof.
  rewrite landb_spec, neqb_spec. intros [D H]. cbn.
  rewrite 2frel_comp. apply frel_weq. intro m.
  unfold update at 1 2 3. rewrite set_set' by congruence. f_equal.
  now rewrite eval_update, subst_free.
  unfold update. now rewrite <-eval_update.
Qed.

Lemma eq_7 (x y: loc) (s t: expr nat):
  negb (eqb x y) &&& free x s -> x<-s;y<-t ≡ x<-s;y<-subst x s t.
Proof.
  rewrite landb_spec, neqb_spec. intros [D H]. cbn.
  rewrite 2frel_comp. apply frel_weq. intro m.
  unfold update at 1 3. f_equal.
  rewrite 2eval_update. symmetry. rewrite subst_free. reflexivity.
  now apply free_subst.
Qed.

Lemma eq_8 (x: loc) (s t: expr nat): x<-s;x<-t ≡ x<-subst x s t.
Proof.
  cbn. rewrite frel_comp. apply frel_weq. intro m.
  unfold update. rewrite set_set. f_equal. apply eval_update.
Qed.

Lemma eq_9 (x: loc) (t: expr nat) (phi: test): [subst x t phi: test];x<-t ≡ x<-t;[phi].
Proof.
  Transparent hrel_lattice_ops. intros m m'. split. Opaque hrel_lattice_ops.
   intros [m0 [<- H] ->]. eexists. reflexivity. split; trivial. now rewrite eval_update.
   intros [m0 -> [<- H]]. eexists. 2: reflexivity. split; trivial. now rewrite <-eval_update.
Qed.

Lemma eq_6' (x y: loc) (s t: expr nat): free x t &&& negb (eqb x y) &&& free y s ->
  x<-s;y<-t ≡ y<-t; x<-s.
Proof. rewrite landb_spec. intros [? ?]. now rewrite eq_6, subst_free. Qed.

Lemma eq_9' (x: loc) (t: expr nat) (phi: test): free x phi -> [phi];x<-t ≡ x<-t;[phi].
Proof. intro. now rewrite <-eq_9, subst_free. Qed.

Transparent hrel_lattice_ops.
Arguments hrel_lattice_ops : simpl never.

Lemma same_value (f: state -> state) (p: prog') (a b: test):
  bstep p ≡ frel f -> (forall m, eval a (f m) = eval b (f m)) ->
  p;[a ⊓ !b ⊔ !a ⊓ b] ≦ 0.
Proof.
  intros Hp H. cbn. rewrite Hp.
   intros m m' [? -> [<- E]].
  exfalso. rewrite lorb_spec, 2landb_spec, 2negb_spec, H in E. intuition congruence.
Qed.

(** * Garbage-collecting assignments to unread variables *)

(** (i.e., Lemma 4.5 in Angus and Kozen's paper)  *)
Fixpoint gc y (p: prog'): prog' :=
  match p with
    | p_str p => (gc y p)^*
    | p_tst _ => p
    | p_aff x e => if eqb x y then 1 else x<-e
    | p_dot p q => gc y p ; gc y q
    | p_pls p q => gc y p + gc y q
  end.

Arguments prog_monoid_ops : simpl never.
Arguments prog_lattice_ops : simpl never.
Arguments prog_kat_ops : simpl never.

Lemma gc_correct y p: dont_read y p -> gc y p; del y ≡ p; del y.
Proof.
  intro H. transitivity (del y; gc y p).
  induction p; cbn.
   now apply eq_9'.
   case eqb_spec. ra. intro. apply eq_6'. now rewrite eqb_false.
   symmetry. apply str_move. symmetry. now auto.
   apply landb_spec in H as [? ?]. mrewrite IHp2. 2: assumption. now mrewrite IHp1.
   apply landb_spec in H as [? ?]. ra_normalise. now apply cup_weq; auto.
  symmetry. induction p; cbn.
   now apply eq_9'.
   case eqb_spec. intros <-. rewrite eq_8. ra. intro D. apply eq_6'. now rewrite eqb_false.
   symmetry. apply str_move. symmetry. now auto.
   apply landb_spec in H as [? ?]. mrewrite IHp2. 2: assumption. now mrewrite IHp1.
   apply landb_spec in H as [? ?]. ra_normalise. now apply cup_weq; auto.
Qed.

Ltac solve_rmov ::=
  first
    [ eassumption
    | symmetry; eassumption
    | eapply rmov_x_dot
    | apply rmov_x_pls
    | apply rmov_x_str
    | apply rmov_x_itr
    | apply rmov_x_cap
    | apply rmov_x_cup
    | apply rmov_x_neg
    | apply rmov_inj
    | apply rmov_x_1
    | apply rmov_x_0 ];
    match goal with |- ?x ≡ ?y => solve_rmov end.

(** * Paterson's equivalence *)
Theorem Paterson:
  let a1 := p' y1: test in
  let a2 := p' y2: test in
  let a3 := p' y3: test in
  let a4 := p' y4: test in
  let clr := del y1; del y2; del y3; del y4 in
  let x1 := y1<-io in
  let s1 := y1<-f' io in
  let s2 := y2<-f' io in
  let z1 := io<-y1; clr in
  let z2 := io<-y2; clr in
  let p11 := y1<-f' y1 in
  let p13 := y1<-f' y3 in
  let p22 := y2<-f' y2 in
  let p41 := y4<-f' y1 in
  let q222 := y2<-g' y2 y2 in
  let q214 := y2<-g' y1 y4 in
  let q211 := y2<-g' y1 y1 in
  let q311 := y3<-g' y1 y1 in
  let r11 := y1<-f' (f' y1) in
  let r12 := y1<-f' (f' y2) in
  let r13 := y1<-f' (f' y3) in
  let r22 := y2<-f' (f' y2) in
  let rhs := s2;[a2];q222;([!a2];r22;[a2];q222)^*;[a2];z2 in
  x1;p41;p11;q214;q311;([!a1];p11;q214;q311)^*;[a1];p13;
  (([!a4]+[a4];([!a2];p22)^*;[a2 ⊓ !a3];p41;p11);q214;q311;([!a1];p11;q214;q311)^*;[a1];p13)^*;
  [a4];([!a2];p22)^*;[a2 ⊓ a3];z2  ≡  rhs.
Proof.
  intros.
  (** simple commutation hypotheses, to be exploited by [hkat] *)
  assert (a1p22:  [a1];p22  ≡ p22;[a1])  by now apply eq_9'.
  assert (a1q214: [a1];q214 ≡ q214;[a1]) by now apply eq_9'.
  assert (a1q211: [a1];q211 ≡ q211;[a1]) by now apply eq_9'.
  assert (a1q311: [a1];q311 ≡ q311;[a1]) by now apply eq_9'.
  assert (a2p13:  [a2];p13  ≡ p13;[a2])  by now apply eq_9'.
  assert (a2r12:  [a2];r12  ≡ r12;[a2])  by now apply eq_9'.
  assert (a2r13:  [a2];r13  ≡ r13;[a2])  by now apply eq_9'.
  assert (a3p13:  [a3];p13  ≡ p13;[a3])  by now apply eq_9'.
  assert (a3p22:  [a3];p22  ≡ p22;[a3])  by now apply eq_9'.
  assert (a3r12:  [a3];r12  ≡ r12;[a3])  by now apply eq_9'.
  assert (a3r13:  [a3];r13  ≡ r13;[a3])  by now apply eq_9'.
  assert (a4p13:  [a4];p13  ≡ p13;[a4])  by now apply eq_9'.
  assert (a4p11:  [a4];p11  ≡ p11;[a4])  by now apply eq_9'.
  assert (a4p22:  [a4];p22  ≡ p22;[a4])  by now apply eq_9'.
  assert (a4q214: [a4];q214 ≡ q214;[a4]) by now apply eq_9'.
  assert (a4q211: [a4];q211 ≡ q211;[a4]) by now apply eq_9'.
  assert (a4q311: [a4];q311 ≡ q311;[a4]) by now apply eq_9'.
  assert (p41p11: p41;p11;[a1 ⊓ !a4 ⊔ !a1 ⊓ a4] ≦ 0).
   eapply same_value. apply frel_comp. reflexivity.
  assert (q211q311: q211;q311;[a2 ⊓ !a3 ⊔ !a2 ⊓ a3] ≦ 0).
   eapply same_value. apply frel_comp. reflexivity.
  assert (r12p22: r12;p22;p22;[a1 ⊓ !a2 ⊔ !a1 ⊓ a2] ≦ 0).
   eapply same_value. simpl bstep. rewrite 2frel_comp. reflexivity. reflexivity.
  (** this one cannot be used by [hkat], it's used by [rmov1]  *)
  assert (p13p22: p13;p22 ≡ p22;p13) by now apply eq_6'.

  (** here starts the proof; the numbers in the comments refer to the
     equation numbers in Angus and Kozen's paper proof *)

  (** (19) *)
  transitivity (
    x1;p41;p11;q214;q311;
    ([!a1 ⊓ !a4];p11;q214;q311 +
     [!a1 ⊓  a4];p11;q214;q311 +
     [ a1 ⊓ !a4];p13;[!a4];q214;q311 +
     [a1 ⊓ a4];p13;([!a2];p22)^*;[a2 ⊓ !a3];p41;p11;q214;q311)^*;
    [a1];p13;([!a2];p22)^*;[a2 ⊓ a3 ⊓ a4];z2).
  clear -a4p13 a4p22. hkat.
  do 2 rmov1 p13.
  (** (23+) *)
  transitivity (
    x1;p41;p11;q214;q311;
    ([!a1 ⊓ !a4];p11;q214;q311 +
     [!a1 ⊓  a4];p11;q214;q311 +
     [ a1 ⊓ !a4];p13;[!a4];q214;q311 +
     [a1 ⊓ a4];p13;([!a2];p22)^*;[a2 ⊓ !a3];p41;p11;q214;q311)^*;
    ([!a2];p22)^*;[a1 ⊓ a2 ⊓ a3 ⊓ a4];(p13;z2)).
  clear -a1p22; hkat.
  setoid_replace (p13;z2) with z2
     by (unfold z2, clr; mrewrite <-(gc_correct y1); [ simpl gc; kat | reflexivity ]).
  (** (24) *)
  transitivity (x1;p41;p11;q214;q311;
    ([a1 ⊓ a4];p13;([!a2];p22)^*;[a2 ⊓ !a3];p41;p11;q214;q311)^*;
    ([!a2];p22)^*;[a1 ⊓ a2 ⊓ a3 ⊓ a4];z2).
  clear -p41p11 a1p22 a1q214 a1q311 a4p11 a4p13 a4p22 a4q214 a4q311; hkat.
  (** big simplification w.r.t the paper proof here... *)

  (** (27) *)
  assert (p41p11q214: p41;p11;q214 ≡ p41;p11;q211).
  change (upd y4 (f' y1) ; upd y1 (f' y1) ; upd y2 (g' y1 y4) ≡ upd y4 (f' y1) ; upd y1 (f' y1) ; upd y2 (g' y1 y1)).
  now rewrite 3frel_comp.
  do 2 mrewrite p41p11q214. clear p41p11q214.
  (** (29) *)
  transitivity (x1;(p41;(p11;q211;q311;[a1];p13;([!a2];p22)^*;[a2 ⊓ !a3]))^*;
                p41;p11;q211;q311;([!a2];p22)^*;[a1 ⊓ a2 ⊓ a3];z2).
  clear -p41p11 a1p22 a1q211 a1q311 a4p22 a4q211 a4q311; hkat.
  (** (31) *)
  transitivity (x1;(p11;q211;q311;[a1];p13;([!a2];p22)^*;[a2 ⊓ !a3])^*;
                p11;q211;q311;([!a2];p22)^*;[a1 ⊓ a2 ⊓ a3];z2).
  unfold z2, clr. mrewrite <-(gc_correct y4). 2: reflexivity. simpl gc. kat.
  (** (32) *)
  rmov1 p13.
  transitivity ((x1;p11);(q211;q311;([!a2];p22)^*;[a1 ⊓ a2 ⊓ !a3];(p13;p11))^*;
                q211;q311;([!a2];p22)^*;[a1 ⊓ a2 ⊓ a3];z2).
  clear -a1p22 a2p13 a3p13; hkat.
  (** big simplification w.r.t the paper proof here... *)

  (** (33) *)
  setoid_replace (x1;p11) with s1 by apply eq_8.
  setoid_replace (p13;p11) with r13 by apply eq_8.
  (** (34) *)
  transitivity (s1;(q211;q311;(([!a2];p22)^*;([a1];r13));[a2 ⊓ !a3])^*;
                q211;q311;([!a2];p22)^*;[a1 ⊓ a2 ⊓ a3];z2).
  clear -a2r13 a3r13; hkat.
  setoid_replace (([!a2];p22)^*;([a1];r13)) with ([a1];r13;([!a2];p22)^*)
   by (assert (r13;p22 ≡ p22;r13) by (now apply eq_6'); rmov1 r13; clear -a1p22; hkat).
  transitivity (s1;([a1];(q211;q311;r13);([!a2];p22)^*;[a2 ⊓ !a3])^*;
                q211;q311;([!a2];p22)^*;[a1 ⊓ a2 ⊓ a3];z2).
  clear -a1q311 a1q211; hkat.
  (** (35) *)
  setoid_replace (q211;q311;r13) with (q211;q311;r12).
  2: change (upd y2 (g' y1 y1) ; upd y3 (g' y1 y1) ; upd y1 (f' (f' y3)) ≡ upd y2 (g' y1 y1) ; upd y3 (g' y1 y1) ; upd y1 (f' (f' y2))); now rewrite 3frel_comp.
  (** (36) *)
  transitivity (s1;([a1];(q211;q311);[!a2];r12;([!a2];p22)^*;[a2])^*;
                (q211;q311);[a2];([!a2];p22)^*;[a1 ⊓ a2];z2).
  clear -a3p22 a3r12 q211q311. hkat.
  (** (37) *)
  transitivity (s1;([a1];q211;[!a2];r12;([!a2];p22)^*;[a2])^*;
                q211;[a2];([!a2];p22)^*;[a1 ⊓ a2];z2).
  unfold z2, clr. mrewrite <-(gc_correct y3). 2: reflexivity. simpl gc. kat.
  (** (38) *)
  transitivity (s1;[a1];q211;([!a2];r12;[a1];p22;[a2];q211 +
                              [!a2];r12;[a1];p22;[!a2];(p22;q211))^*;[a2];z2).
  clear -a1p22 a1q211 a2r12 r12p22 a1p22. hkat.
  (** big simplification w.r.t the paper proof here... *)

  (** (43) *)
  assert (p22q211: p22;q211 ≡ q211) by apply eq_8. rewrite p22q211.
  transitivity (s1;[a1];q211;([!a2];r12;[a1];(p22;q211))^*;[a2];z2). kat.
  rewrite p22q211. clear p22q211.
  (** (44) *)
  unfold s1, a1, q211, r12, a2. rewrite <-eq_9. mrewrite eq_7. 2: reflexivity.
  mrewrite <-eq_9. mrewrite (eq_7 y1 y2 (f' (f' y2))). 2: reflexivity.
  unfold z2, clr. mrewrite <-(gc_correct y1). 2: reflexivity.
  unfold rhs, z2, clr, s2, a2. rewrite <-eq_9.
  unfold q222. mrewrite eq_7. 2: reflexivity.
  unfold r22. mrewrite <-eq_9. do 2 mrewrite eq_8.
  simpl gc. kat.
  (** (47) *)
Qed.

End s.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial ssralg finset fingroup finalg matrix.
Require Import Reals Fourier.
Require Import Rssr Reals_ext log2 Rbigop proba entropy aep typ_seq source_code.

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

Local Open Scope source_code_scope.
Local Open Scope entropy_scope.
Local Open Scope reals_ext_scope.

Section source_coding_converse'.

Variable A : finType.
Variable P : dist A.
Variables num den : nat.
Let r := INR num / INR den.+1.
Hypothesis Hr : 0 < r < `H P.

Variable n : nat.
Variable k : nat.
Variable sc : scode_fl A k.+1 n.
Hypothesis r_sc : r = SrcRate sc.

Variable epsilon : R.
Hypothesis Hepsilon : 0 < epsilon < 1.

Notation "'max(' x ',' y ')'" := (Rmax x y) : reals_ext_scope.

Definition lambda := min((1 - epsilon) / 2, (`H P - r) / 2).
Definition delta := min((`H P - r) / 2, lambda / 2).

Definition SrcConverseBound := max(max(
  aep_bound P delta, - ((log delta) / (`H P - r - delta))), INR n / r).

Hypothesis Hk : SrcConverseBound <= INR k.+1.

Lemma Hr1 : 0 < (`H P - r) / 2.
Proof.
apply Rlt_mult_inv_pos; last by fourier.
case: Hr => ? ?; fourier.
Qed.

Lemma Hepsilon1 : 0 < (1 - epsilon) / 2.
Proof.
apply Rlt_mult_inv_pos; last by fourier.
case: Hepsilon => ? ? ;fourier.
Qed.

Lemma Hlambda : 0 < lambda.
Proof. rewrite /lambda; apply P_Rmin => //; [exact Hepsilon1 | exact Hr1]. Qed.

Lemma Hdelta : 0 < delta.
Proof.
rewrite /delta.
apply Rmin_pos.
case: Hr => ? ?; apply Rlt_mult_inv_pos; fourier.
apply Rlt_mult_inv_pos; [exact Hlambda | fourier].
Qed.

Definition e0 := `H P - r.

Lemma e0_delta : e0 <> delta.
Proof.
rewrite /e0 /delta /lambda -/r.
apply Rmin_case_strong => H1.
- apply neq_Rdiv.
  case: Hr => ? ? ?; fourier.
  move=> ?; fourier.
  move=> ?; fourier.
- apply Rmin_case_strong => H2.
  + apply nesym, Rlt_not_eq.
    eapply Rle_lt_trans.
    * eapply Rle_trans; last by apply H2.
      apply Rdiv_le; last by fourier.
      by apply Rlt_le, Hepsilon1.
    * apply Rdiv_lt; last by fourier.
      case: Hr => ? ?; fourier.
  + rewrite /Rdiv -mulRA (_ : ( _ * / 2 ) = / 4); last by field.
    apply neq_Rdiv.
    case: Hr => ? ? ?; fourier.
    move=> ?; fourier.
    move=> ?; fourier.
Qed.

Definition no_failure := [set x : 'rV[A]_k.+1 | dec sc (enc sc x) == x].

Lemma no_failure_sup : INR #| no_failure | <= exp2 (INR k.+1 * (`H P - e0)).
Proof.
apply Rle_trans with (exp2 (INR n)).
  rewrite /no_failure.
  have Hsubset : [set x | dec sc (enc sc x) == x] \subset dec sc @: (enc sc @: [set: 'rV[A]_k.+1]).
    apply/subsetP => x.
    rewrite inE => Hx.
    apply/imsetP.
    exists (enc sc x).
    - apply mem_imset; by rewrite inE.
    - by move/eqP in Hx.
  apply Rle_trans with (INR #| dec sc @: (enc sc @: [set: 'rV[A]_k.+1]) |).
    apply/le_INR/leP.
    by case/subset_leqif_cards : Hsubset.
  apply Rle_trans with (INR #| dec sc @: [set: 'rV[bool]_n] |).
    apply/le_INR/leP/subset_leqif_cards/imsetS.
    apply/subsetP => x Hx.
    by rewrite inE.
  apply Rle_trans with (INR #| [set: 'rV[bool]_n] |).
    apply/le_INR/leP/leq_imset_card.
    rewrite cardsT card_matrix /= card_bool exp2_pow2 mul1n; by apply Rle_refl.
apply exp2_le_increasing.
rewrite /e0 [X in _ <= _ * X](_ : _ = r); last by field.
apply Rmult_le_reg_r with (1 / r) => //.
apply Rlt_mult_inv_pos; [fourier | tauto].
rewrite -mulRA {2}/Rdiv mul1R Rinv_r; last first.
  case: Hr => ? ? ?; fourier.
rewrite mulR1 /Rdiv mul1R; exact: proj2 (Rmax_Rle_in Hk).
Qed.

Local Open Scope proba_scope.

Lemma step1 : (1 - esrc(P , sc)) = \rsum_(x in no_failure) P `^ k.+1 x.
Proof.
rewrite /SrcErrRate /no_failure /Pr.
set a := \rsum_(_ | _) _.
set b := \rsum_(_ | _) _.
suff : 1 = a + b by move=> ->; field.
rewrite /a {a}.
have -> : b = \rsum_(i in [set i | dec sc (enc sc i) == i]) TupleDist.f P i.
  apply eq_big => // i /=; by rewrite inE.
rewrite -(pmf1 (P `^ k.+1)).
rewrite (bigID [pred a | a \in [set i0 | dec sc (enc sc i0) == i0]]) /= addRC.
f_equal.
apply eq_bigl => t /=; by rewrite !inE.
Qed.

Local Open Scope typ_seq_scope.

Lemma step2 : 1 - (esrc(P , sc)) =
  \rsum_(x in 'rV[A]_k.+1 | x \in no_failure :&: ~: `TS P k.+1 delta) P `^ k.+1 x +
  \rsum_(x in 'rV[A]_k.+1 | x \in no_failure :&: `TS P k.+1 delta) P `^ k.+1 x.
Proof.
rewrite step1 (bigID [pred x | x \in `TS P k.+1 delta]) /= addRC.
f_equal.
- apply eq_bigl => x; by rewrite in_setI in_setC.
- apply eq_bigl => x; by rewrite in_setI.
Qed.

Lemma step3 : 1 - (esrc(P , sc)) <=
  \rsum_(x in 'rV[A]_k.+1 | x \in ~: `TS P k.+1 delta) P `^ k.+1 x +
  \rsum_(x in 'rV[A]_k.+1 | x \in no_failure :&: `TS P k.+1 delta) P `^ k.+1 x.
Proof.
rewrite step2.
apply Rplus_le_compat_r, Rle_big_P_Q_f_X => [a | i].
- by apply (Rle0f (P `^ k.+1) a).
- rewrite in_setI; by case/andP.
Qed.

Lemma step4 : 1 - (esrc(P , sc)) <= delta +
  INR #| no_failure :&: `TS P k.+1 delta| * exp2 (- INR k.+1 * (`H P - delta)).
Proof.
eapply Rle_trans; first by apply step3.
apply Rplus_le_compat.
- move: (Pr_TS_1 Hdelta (proj1 (Rmax_Rle_in (proj1 (Rmax_Rle_in Hk))))) => H2.
  set p1 := Pr _ _ in H2.
  rewrite -/(Pr (P `^ k.+1) _) Pr_to_cplt /= (_ : Pr _ _ = p1); last first.
    rewrite /p1; apply Pr_ext; apply/setP => i /=; by rewrite !inE negbK.
  fourier.
- apply Rle_trans with
  (\rsum_(x in 'rV[A]_k.+1 | x \in no_failure :&: `TS P k.+1 delta)
    exp2 (-INR k.+1 * (`H P - delta))).
    apply Rle_big_P_f_g => i.
    rewrite in_setI.
    case/andP => _ /andP [] i_B i_TS.
    move: (typ_seq_definition_equiv2 i_TS) => [H1 _].
    apply log_le_inv.
    + rewrite /`TS inE /typ_seq in i_TS.
      case/andP : i_TS.
      move/RleP => i_TS _.
      eapply Rlt_le_trans; by [apply exp2_pos | apply i_TS].
    + by apply exp2_pos.
    + rewrite log_exp2.
      apply Rmult_le_reg_l with (1 / INR k.+1) => //.
      * rewrite /Rdiv.
        apply Rlt_mult_inv_pos => //; first by fourier.
        by apply/lt_0_INR/ltP.
      * apply Rge_le.
        rewrite -mulRA mul1R mulRA Ropp_mult_distr_r_reverse -Rinv_l_sym;
          last by apply not_0_INR.
        apply Rle_ge, Ropp_le_cancel.
        rewrite -Ropp_mult_distr_l_reverse (_ : - -1 = 1); last by field.
        by rewrite mul1R -Ropp_mult_distr_l_reverse.
  rewrite big_const iter_Rplus; by apply Rle_refl.
Qed.

Lemma step5 : 1 - (esrc(P , sc)) <= delta + exp2 (- INR k.+1 * (e0 - delta)).
Proof.
apply Rle_trans with (delta + INR #| no_failure | * exp2 (- INR k.+1 * (`H P - delta))).
- eapply Rle_trans; first by apply step4.
  apply Rplus_le_compat_l, Rmult_le_compat_r.
  by apply Rlt_le, exp2_pos.
  by apply/le_INR/leP/subset_leqif_cards/subsetIl.
- apply Rplus_le_compat_l.
  apply Rle_trans with (exp2 (INR k.+1 * (`H P - e0)) * exp2 (- INR k.+1 * (`H P - delta)));
    last first.
    rewrite -exp2_plus.
    apply exp2_le_increasing, Req_le; by field.
  apply Rmult_le_compat_r; [by apply Rlt_le, exp2_pos | exact no_failure_sup].
Qed.

Lemma step6 : (esrc(P , sc)) >= 1 - 2 * delta.
Proof.
have H : exp2 (- INR k.+1 * (e0 - delta)) <= delta.
  apply log_le_inv.
  - by apply exp2_pos.
  - exact Hdelta.
  - rewrite log_exp2.
    apply Rmult_le_reg_r with (1 / (e0 - delta)) => //.
    + apply Rlt_mult_inv_pos; first by fourier.
      rewrite /e0 /delta /r.
      apply Rlt_Rminus.
      have H1 : (`H P - r) / 2 < `H P - r.
        rewrite -[X in _ < X]mulR1.
        apply Rmult_lt_compat_l.
        case: Hr => ? ?; fourier.
        fourier.
      apply Rmin_case_strong => H2 //.
      eapply Rle_lt_trans; [by apply H2 | exact H1].
    + rewrite -mulRA /Rdiv mul1R Rinv_r; last first.
        apply Rminus_eq_contra; exact e0_delta.
      apply Ropp_le_cancel, Rge_le.
      rewrite -Ropp_mult_distr_l_reverse Ropp_involutive.
      apply Rle_ge.
      rewrite mulR1 /e0.
      by move: (proj2 (Rmax_Rle_in (proj1 (Rmax_Rle_in Hk)))).
suff : 1 - (esrc(P , sc)) <= delta + delta by move=> *; fourier.
eapply Rle_trans; by [apply step5 | apply Rplus_le_compat_l].
Qed.

Theorem source_coding_converse' : esrc(P , sc) >= epsilon.
Proof.
eapply Rge_trans; first by apply step6.
apply Rle_ge, Ropp_le_cancel.
rewrite Ropp_minus_distr.
apply Rplus_le_reg_l with 1.
rewrite addRC (_ : 2 * delta - _ + _ = 2 * delta); last by field.
rewrite (_ : 1 + - epsilon = 1 - epsilon); last by field.
apply Rmult_le_reg_l with (/ 2); first by fourier.
rewrite mulRA Rinv_l; last by move=> ?; fourier.
rewrite mul1R /delta.
have H1 : lambda / 2 <= / 2 * (1 - epsilon).
  apply Rle_trans with lambda.
  apply Rdiv_le; [apply Rlt_le; exact Hlambda | fourier].
  - rewrite /lambda mulRC; by apply Rmin_l.
apply Rmin_case_strong => ? //.
by apply Rle_trans with (lambda / 2).
Qed.

End source_coding_converse'.

Section source_coding_converse.

Variable A : finType.
Variable P : dist A.

(** * Source coding theorem (converse part) #<a name="label_source_coding_converse"> </a># *)

Theorem source_coding_converse : forall epsilon, 0 < epsilon < 1 ->
  forall r : Qplus, 0 < r < `H P ->
    forall n k (sc : scode_fl A k.+1 n),
      SrcRate sc = r ->
      SrcConverseBound P (num r) (den r) n epsilon <= INR k.+1 ->
      esrc(P , sc) >= epsilon.
Proof.
move=> epsilon Hespilon r r_HP n k sc r_sc Hk_bound.
by apply source_coding_converse' with (num := num r) (den := den r).
Qed.

End source_coding_converse.

Check source_coding_converse.


(*===========================================================================
  Basic representation of n-bit words

  We use n.-tuples of bools, as this gives decidable equality and finiteness
  for free.

  Tuples are practical for evaluation inside Coq, and so all operations on
  words can be evaluated using compute, cbv, etc.

  Proofs of various properties of bitvectors can be found in bitsprops.v
  Definitions of operations on bitvectors can be found in bitsops.v
  Proofs of properties of operations can be found in bitsopsprops.v
  ===========================================================================*)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple fintype zmodp.
Require Import Coq.ZArith.ZArith Coq.Strings.String.

(* We represent n-bit words by a tuple of booleans, least-significant bit at the head *)
(* DWORDorBYTE is especially useful for multi-mode instructions *)
(*=BITS *)
Definition BITS n := n.-tuple bool.
(** We define aliases for various numbers, to speed up proofs.  We use [.+1] to ensure convertibility after adding or subtracting 1. *)
Definition n3 := 3.
Definition n7 := 7.
Definition n15 := 15.
Definition n31 := 31.
Definition n63 := 63.
Arguments n3 : simpl never.
Arguments n7 : simpl never.
Arguments n15 : simpl never.
Arguments n31 : simpl never.
Arguments n63 : simpl never.
Opaque n3 n7 n15 n31 n63.
Notation n4 := n3.+1.
Notation n8 := n7.+1.
Notation n16 := n15.+1.
Notation n32 := n31.+1.
Notation n64 := n63.+1.
Definition n24 := 24.
Arguments n24 : simpl never.
Opaque n24.
Definition NIBBLE := BITS n4.
Definition BYTE   := BITS n8.
Definition WORD   := BITS n16.
Definition DWORD  := BITS n32.
Definition QWORD  := BITS n64.
Definition DWORDorBYTE (d: bool) := BITS (if d then n32 else n8).
(*=End *)

Identity Coercion DWORDtoBITS32 : DWORD >-> BITS.
Identity Coercion BYTEtoBITS8 : BYTE >-> BITS.
Identity Coercion WORDtoBITS16 : WORD >-> BITS.

(* Construction *)
Notation "'nilB'" := (nil_tuple _).
Definition consB {n} (b:bool) (p: BITS n) : BITS n.+1 := cons_tuple b p.
Definition joinlsb {n} (pair: BITS n*bool) : BITS n.+1 := cons_tuple pair.2 pair.1.

(* Destruction *)
Definition splitlsb {n} (p: BITS n.+1): BITS n*bool := (behead_tuple p, thead p).
Definition droplsb {n} (p: BITS n.+1) := (splitlsb p).1.

(*---------------------------------------------------------------------------
    Conversion to and from natural numbers.

    For large naturals, be careful to use ssrnat's Num and [Num of] constructs
    for creating and printing naturals.
  ---------------------------------------------------------------------------*)
Fixpoint fromNat {n} m : BITS n :=
  if n is _.+1
  then joinlsb (fromNat m./2, odd m)
  else nilB.
Notation "# m" := (fromNat m) (at level 0).
Arguments fromNat n m : simpl never.

Definition toNat {n} (p: BITS n) := foldr (fun (b:bool) n => b + n.*2) 0 p.

Coercion natAsDWORD := @fromNat _ : nat -> DWORD.
Coercion natAsWORD := @fromNat _ : nat -> WORD.
Coercion natAsBYTE := @fromNat _ : nat -> BYTE.

(*---------------------------------------------------------------------------
    All bits identical
  ---------------------------------------------------------------------------*)
Definition copy n b : BITS n := nseq_tuple n b.
Definition zero n := copy n false.
Definition ones n := copy n true.

(*---------------------------------------------------------------------------
    Concatenation and splitting of bit strings
  ---------------------------------------------------------------------------*)

(* Most and least significant bits, defaulting to 0 *)
Definition msb {n} (b: BITS n) := last false b.
Definition lsb {n} (b: BITS n) := head false b.

Definition catB {n1 n2} (p1: BITS n1) (p2: BITS n2) : BITS (n2+n1) :=
  cat_tuple p2 p1.
Notation "y ## x" := (catB y x) (right associativity, at level 60).

(* The n high bits *)
Fixpoint high n {n2} : BITS (n2+n) -> BITS n :=
  if n2 is _.+1 then fun p => let (p,b) := splitlsb p in high _ p else fun p => p.

(* The n low bits *)
Fixpoint low {n1} n : BITS (n+n1) -> BITS n :=
  if n is _.+1 then fun p => let (p,b) := splitlsb p in joinlsb (low _ p, b)
               else fun p => nilB.

(* n1 high and n2 low bits *)
Definition split2 n1 n2 p := (high n1 p, low n2 p).

Definition split3 n1 n2 n3 (p: BITS (n3+n2+n1)) : BITS n1 * BITS n2 * BITS n3 :=
  let (hi,lo) := split2 n1 _ p in
  let (lohi,lolo) := split2 n2 _ lo in (hi,lohi,lolo).

Definition split4 n1 n2 n3 n4 (p: BITS (n4+n3+n2+n1)): BITS n1 * BITS n2 * BITS n3 * BITS n4 :=
  let (b1,rest) := split2 n1 _ p in
  let (b2,rest) := split2 n2 _ rest in
  let (b3,b4)   := split2 n3 _ rest in (b1,b2,b3,b4).

(* Sign extend by {extra} bits *)
Definition signExtend extra {n} (p: BITS n.+1) := copy extra (msb p) ## p.

(* Truncate a signed integer by {extra} bits; return None if this would overflow *)
Definition signTruncate extra {n} (p: BITS (n.+1 + extra)) : option (BITS n.+1) :=
  let (hi,lo) := split2 extra _ p in
  if msb lo && (hi == ones _) || negb (msb lo) && (hi == zero _)
  then Some lo
  else None.

(* Zero extend by {extra} bits *)
Definition zeroExtend extra {n} (p: BITS n) := zero extra ## p.

Coercion WORDtoDWORD := zeroExtend (n:=16) 16 : WORD -> DWORD.
Coercion BYTEtoDWORD := zeroExtend (n:=8) 24 : BYTE -> DWORD.

(* Take m least significant bits of n-bit argument and fill with zeros if m>n *)
Fixpoint lowWithZeroExtend m {n} : BITS n -> BITS m :=
  if n is _.+1
  then fun p => let (p,b) := splitlsb p in
                if m is m'.+1 then joinlsb (@lowWithZeroExtend m' _ p, b)
                else zero 0
  else fun p => zero m.

(* Truncate an unsigned integer by {extra} bits; return None if this would overflow *)
Definition zeroTruncate extra {n} (p: BITS (n + extra)) : option (BITS n) :=
  let (hi,lo) := split2 extra _ p in
  if hi == zero _ then Some lo else None.

(* Special case: split at the most significant bit.
   split 1 n doesn't work because it requires BITS (n+1) not BITS n.+1 *)
Fixpoint splitmsb {n} : BITS n.+1 -> bool * BITS n :=
  if n is _.+1
  then fun p => let (p,b) := splitlsb p in let (c,r) := splitmsb p in (c,joinlsb(r,b))
  else fun p => let (p,b) := splitlsb p in (b,p).
Definition dropmsb {n} (p: BITS n.+1) := (splitmsb p).2.

(* Extend by one bit at the most significant bit. Again, signExtend 1 n does not work
   because BITS (n+1) is not definitionally equal to BITS n.+1  *)
Fixpoint joinmsb {n} : bool * BITS n -> BITS n.+1 :=
  if n is _.+1
  then fun p => let (hibit, p) := p in
                let (p,b) := splitlsb p in joinlsb (joinmsb (hibit, p), b)
  else fun p => joinlsb (nilB, p.1).
Definition joinmsb0 {n} (p: BITS n) : BITS n.+1 := joinmsb (false,p).

Fixpoint zeroExtendAux extra {n} (p: BITS n) : BITS (extra+n) :=
  if extra is e.+1 then joinmsb0 (zeroExtendAux e p) else p.

Definition joinNibble {n}  (p:NIBBLE) (q: BITS n) : BITS (n.+4) :=
  let (p1,b0) := splitlsb p in
  let (p2,b1) := splitlsb p1 in
  let (p3,b2) := splitlsb p2 in
  let (p4,b3) := splitlsb p3 in
   joinmsb (b3, joinmsb (b2, joinmsb (b1, joinmsb (b0, q)))).

Notation "y ## x" := (catB y x) (right associativity, at level 60).

(*---------------------------------------------------------------------------
    Single bit operations
  ---------------------------------------------------------------------------*)

(* Booleans are implicitly coerced to one-bit words, useful in combination with ## *)
Coercion singleBit b : BITS 1 := joinlsb (nilB, b).

(* Get bit i, counting 0 as least significant *)
(* For some reason tnth is not efficiently computable, so we use nth *)
Definition getBit {n} (p: BITS n) (i:nat) := nth false p i.

(* Set bit i to b *)
Fixpoint setBitAux {n} i b : BITS n -> BITS n :=
  if n is _.+1
  then fun p => let (p,oldb) := splitlsb p in
                if i is i'.+1 then joinlsb (setBitAux i' b p, oldb) else joinlsb (p,b)
  else fun p => nilB.

Definition setBit {n} (p: BITS n) i b := setBitAux i b p.

(*---------------------------------------------------------------------------
    Efficient conversion to and from Z
  ---------------------------------------------------------------------------*)

Definition toPosZ {n} (p: BITS n) :=
  foldr (fun b z => if b then Zsucc (Zdouble z) else Zdouble z) Z0 p.

Definition toNegZ {n} (p: BITS n) :=
  foldr (fun b z => if b then Zdouble z else Zsucc (Zdouble z)) Z0 p.

Definition toZ {n} (bs: BITS n.+1) :=
  match splitmsb bs with
  | (false, bs') => toPosZ bs'
  | (true, bs') => Zopp (Zsucc (toNegZ bs'))
  end.

Fixpoint fromPosZ {n} (z: Z): BITS n :=
  if n is _.+1
  then joinlsb (fromPosZ (Zdiv2 z), negb (Zeven_bool z))
  else nilB.

Fixpoint fromNegZ {n} (z: Z): BITS n :=
  if n is _.+1
  then joinlsb (fromNegZ (Zdiv2 z), Zeven_bool z)
  else nilB.

Definition fromZ {n} (z:Z) : BITS n :=
  match z with
  | Zpos _ => fromPosZ z
  | Zneg _ => fromNegZ (Zpred (Zopp z))
  | _ => zero _
  end.

(*---------------------------------------------------------------------------
    Conversion to and from 'Z_(2^n)
  ---------------------------------------------------------------------------*)

Definition toZp {n} (p: BITS n) : 'Z_(2^n) := inZp (toNat p).
Definition fromZp {n} (z: 'Z_(2^n)) : BITS n := fromNat z.

Definition bool_inZp m (b:bool): 'Z_m := inZp b.
Definition toZpAux {m n} (p:BITS n) : 'Z_(2^m) := inZp (toNat p).

(*---------------------------------------------------------------------------
    Support for hexadecimal notation
  ---------------------------------------------------------------------------*)
Section HexStrings.
Import Ascii.

Definition charToNibble c : NIBBLE :=
  fromNat (findex 0 (String c EmptyString) "0123456789ABCDEF0123456789abcdef").
Definition charToBit c : bool := ascii_dec c "1".

(*=fromBin *)
Fixpoint fromBin s : BITS (length s) :=
  if s is String c s
  then joinmsb (charToBit c, fromBin s) else #0.
(*=End *)

(*=fromHex *)
Fixpoint fromHex s : BITS (length s * 4) :=
  if s is String c s
  then joinNibble (charToNibble c) (fromHex s) else #0.
(*=End *)

Fixpoint fromString s : BITS (length s * 8) :=
  if s is String c s return BITS (length s * 8)
  then fromString s ## fromNat (n:=8) (nat_of_ascii c) else nilB.

Definition nibbleToChar (n: NIBBLE) :=
  match String.get (toNat n) "0123456789ABCDEF" with None => " "%char | Some c => c end.

Definition appendNibbleOnString n s :=
  (s ++ String.String (nibbleToChar n) EmptyString)%string.

End HexStrings.

Fixpoint toHex {n} :=
  match n return BITS n -> string with
  | 0 => fun bs => EmptyString
  | 1 => fun bs => appendNibbleOnString (zero 3 ## bs) EmptyString
  | 2 => fun bs => appendNibbleOnString (zero 2 ## bs) EmptyString
  | 3 => fun bs => appendNibbleOnString (zero 1 ## bs) EmptyString
  | _ => fun bs => let (hi,lo) := split2 _ 4 bs in appendNibbleOnString lo (toHex hi)
  end.

Import Ascii.
(*Fixpoint bytesToHex (b: seq BYTE) :=
  if b is b::bs then
  String.String (nibbleToChar (high (n2:=4) 4 b)) (
             String.String (nibbleToChar (low 4 b)) (
             String.String (" "%char) (
             bytesToHex bs)))
  else ""%string.
*)

Fixpoint bytesToHexAux (b: seq BYTE) res :=
  match b with b::bs =>
    bytesToHexAux bs (String.String (nibbleToChar (high (n2:=4) 4 b)) (
             String.String (nibbleToChar (low 4 b)) (
             String.String (" "%char) res)))
  | nil => res end.

Definition bytesToHex b := bytesToHexAux (rev b) ""%string.

(* Convert an ASCII character (from the standard Coq library) to a BYTE *)
Definition charToBYTE (c: ascii) : BYTE :=
  let (a0,a1,a2,a3,a4,a5,a6,a7) := c in
  [tuple a0;a1;a2;a3;a4;a5;a6;a7].

(* Convert an ASCII string to a tuple of BYTEs... *)
Fixpoint stringToTupleBYTE (s: string) : (length s).-tuple BYTE :=
  if s is String c s then cons_tuple (charToBYTE c) (stringToTupleBYTE s)
  else nil_tuple _.

(* ...which is easily coerced to a sequence *)
Definition stringToSeqBYTE (s: string) : seq BYTE :=
  stringToTupleBYTE s.

(* Notation for hex, binary, and character/string *)
Notation "#x y" := (fromHex y) (at level 0).
Notation "#b y" := (fromBin y) (at level 0).
Notation "#c y" := (fromString y : BYTE) (at level 0).

(*=fortytwo *)
Example fortytwo  := #42 : BYTE.
Example fortytwo1 := #x"2A".
Example fortytwo2 := #b"00101010".
Example fortytwo3 := #c"*".
(*=End *)


Require Export Setoid Coq.Classes.Morphisms.
Require Export Sets SetInterface SetConstructs SetProperties CSetComputable.
Require Import EqDec CSetNotation Util CSetTac.

Section theorems.
  Variable X : Type.
  Context `{OrderedType X}.

  Lemma single_spec_neq (x y:X)
    : x ∈ {{ y }} -> x === y.
  Proof.
    cset_tac.
  Qed.

  Lemma neq_not_in_single (x y:X)
    :  x =/= y -> ~x ∈ {{y}}.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_empty (s:set X)
    : s \ ∅ [=] s.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_in_in s t (x:X)
    : x ∈ (s \ t) -> x ∈ s /\ ~x ∈ t.
  Proof.
    cset_tac.
  Qed.

  Lemma in_in_minus s t (x:X)
    : x ∈ s -> ~x ∈ t -> x ∈ (s \ t).
  Proof.
    cset_tac.
  Qed.

  Lemma union_comm (s t:set X)
    : s ∪ t [=] t ∪ s .
  Proof.
    cset_tac.
  Qed.

  Lemma minus_inane_set (s t:set X)
    : s ∩ t [=] ∅ -> (s \ t) [=] s.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_union_set (s t:set X)
    : s ∩ t [=] ∅ -> ((s ∪ t) \ t) [=] s.
  Proof.
    cset_tac.
  Qed.

  Lemma in_minus_neq s (x y:X)
    : x =/= y -> x ∈ s
    -> x ∈ (s\{{y}}).
  Proof.
    cset_tac.
  Qed.

  Lemma add_inane s (x:X)
    : x ∈ s
    -> s [=] ({{x}} ∪ s).
  Proof.
    cset_tac.
  Qed.

  Lemma in_single_union s (y:X)
    : y ∈ {{y}} ∪ s.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_union (s t u:set X)
    : (s \ t \ u) [=] s \ (t ∪ u).
  Proof.
    cset_tac.
  Qed.

  Lemma incl_empty (s:set X)
    : ∅ ⊆ s.
  Proof.
    cset_tac.
  Qed.

  Lemma incl_singleton (x:X) (s:set X)
    : x ∈ s -> singleton x ⊆ s.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_incl (s t:set X)
    : (s\t) ⊆ s.
  Proof.
    cset_tac.
  Qed.

  Lemma empty_neutral_union (s:set X)
    : ∅ ∪ s [=] s.
  Proof.
    cset_tac.
  Qed.

  Lemma incl_add s (x:X)
    :  s ⊆ ({{x}} ∪ s).
  Proof.
    cset_tac.
  Qed.

  Lemma incl_refl (s:set X)
  : s ⊆ s.
  Proof.
    reflexivity.
  Qed.

  Lemma incl_right (s t:set X)
    :  s ⊆ (t ∪ s).
  Proof.
    cset_tac.
  Qed.

  Lemma incl_add' (s:set X) x
    :  s ⊆ {x; s}.
  Proof.
    cset_tac.
  Qed.

  Lemma in_add' (s:set X) x
    :  x ∈ {x; s}.
  Proof.
    cset_tac.
  Qed.

  Lemma incl_minus (s t : set X)
    :  (s \ t) ⊆ s.
  Proof.
    cset_tac.
  Qed.

  Lemma union_assoc (s t u : set X)
    : s ∪ t ∪ u [=] s ∪ (t ∪ u).
  Proof.
    cset_tac.
  Qed.

  Lemma union_minus_incl (s t:set X)
    : ((t ∪ s) \ t) ⊆ s.
  Proof.
    cset_tac.
  Qed.

  Lemma incl_minus_lr (s s' t t':set X)
    : s ⊆ s' -> t ⊆ t' -> s \ t' ⊆ s' \ t.
  Proof.
    cset_tac.
  Qed.

  Lemma union_idem (s:set X)
    : s ∪ s [=] s.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_in s t (x:X)
    : x ∉ s -> x ∉ t -> x ∉ (s ∪ t).
  Proof.
    cset_tac.
  Qed.

  Lemma union_cases s t (x:X)
    : x ∈ (s ∪ t) -> x ∈ s \/ x ∈ t.
  Proof.
    cset_tac.
  Qed.

  Lemma not_in_union_comp  (s t : set X) x :
    ~x ∈ s /\ ~x ∈ t -> ~x ∈ (s ∪ t).
  Proof.
    cset_tac.
  Qed.

  Lemma not_in_union_decomp s t (x:X)
    : x ∉ (s ∪ t) -> x ∉ s /\ x ∉ t.
  Proof.
    cset_tac.
  Qed.

  Lemma union_left s t (x:X)
    : x ∈ s -> x ∈ (s ∪ t).
  Proof.
    cset_tac.
  Qed.

  Lemma union_right s t (x:X)
    : x ∈ t -> x ∈ (s ∪ t).
  Proof.
    cset_tac.
  Qed.

  Lemma set_fact_2 s t (x:X)
    : (s \ ({{x}} ∪ t)) \ {{x}} [=] s \ ({{x}} ∪ t).
  Proof.
    cset_tac.
  Qed.

  Lemma incl_union_absorption (s t:set X)
    : s ⊆ t -> s ∪ t [=] t.
  Proof.
    cset_tac.
  Qed.

  Lemma incl_union_lr (s s' t t':set X)
    : s ⊆ s' -> t ⊆ t' -> s ∪ t ⊆ s' ∪ t'.
  Proof.
    cset_tac.
  Qed.

  Lemma incl_left (s t:set X)
    : s ⊆ (s ∪ t).
  Proof.
    cset_tac.
  Qed.

  Lemma in_meet (s t:set X) (x:X)
    : x ∈ s -> x ∈ t -> x ∈ s ∩ t.
  Proof.
    cset_tac.
  Qed.

  Lemma meet_in (s t:set X) (x:X)
    : x ∈ s ∩ t -> x ∈ s /\ x ∈ t.
  Proof.
    cset_tac.
  Qed.

  Lemma meet_incl (s t u:set X)
    : s ⊆ u -> s ∩ t ⊆ u.
  Proof.
    cset_tac.
  Qed.

  Lemma meet_comm (s t:set X)
    : s ∩ t [=] t ∩ s.
  Proof.
    cset_tac.
  Qed.

  Lemma incl_meet (s t:set X)
    : s ⊆ t -> s [=] s ∩ t.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_meet (s t u:set X)
    : (s \ t) ∩ u [=] s ∩ u \ t.
  Proof.
    cset_tac.
  Qed.

  Lemma set_incl (s t: set X)
    : s ⊆ t -> t ⊆ s -> t [=] s.
  Proof.
    cset_tac.
  Qed.

  Lemma elements_nil_eset (s : set X) :
    s [=] ∅ <-> elements s = nil.
  Proof.
    rewrite <- elements_Empty. cset_tac.
  Qed.

  Lemma union_meet_distr_r (s t u : set X) :
    (s ∪ t) ∩ u [=] (s ∩ u) ∪ (t ∩ u).
  Proof.
    cset_tac.
  Qed.

  Lemma union_is_empty (s t : set X) :
    s ∪ t [=] ∅ -> (s [=] ∅ /\ t [=] ∅).
  Proof.
    cset_tac.
  Qed.

  Lemma smaller_meet_empty (s t u : set X) :
    (s ∪ t) ∩ u [=] ∅ -> t ∩ u [=] ∅.
  Proof.
    cset_tac.
  Qed.

  Lemma empty_intersection_in_one_not_other (s t : set X) x :
    s ∩ t [=] ∅ -> x ∈ s -> ~ x ∈ t.
  Proof.
    cset_tac.
  Qed.

  Lemma meet_assoc (s t u : set X)
    : s ∩ t ∩ u [=] s ∩ (t ∩ u).
  Proof.
    cset_tac.
  Qed.

  Lemma incl_meet_lr (s s' t t':set X)
    : s ⊆ s' -> t ⊆ t' -> s ∩ t ⊆ s' ∩ t'.
  Proof.
    cset_tac.
  Qed.

  Lemma meet_in_union (s t : set X)
    : s ∩ t ⊆ s ∪ t.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_dist_union (s t u:set X)
    : (s ∪ t) \ u [=] (s \ u) ∪ (t \ u).
  Proof.
    cset_tac.
  Qed.

  Lemma minus_dist_intersection (s t u:set X)
    : (s ∩ t) \ u [=] (s \ u) ∩ (t \ u).
  Proof.
    cset_tac.
  Qed.

  Lemma incl_not_member (s t:set X) x
    : s ⊆ t -> ~x ∈ t -> ~x ∈ s.
  Proof.
    cset_tac.
  Qed.

  Lemma incl_meet_empty (s t u:set X)
    : s ⊆ t -> u ∩ t [=] empty -> u ∩ s [=] empty.
  Proof.
    cset_tac.
  Qed.

  Lemma union_incl_split (s t u : set X)
    : s ⊆ u -> t ⊆ u -> s ∪ t ⊆ u.
  Proof.
    cset_tac.
  Qed.

  Lemma union_minus_remove (a b : set X)
        : (a ∪ b) \ a [=] b \ a.
  Proof.
    cset_tac.
  Qed.

  Lemma minus_incl_meet_special2 (c c' d : set X)
    : c ⊆ d
    -> c ⊆ c'
    -> c ∩ (c' \ (c \ d)) [=] c.
  Proof.
    cset_tac.
  Qed.

  Lemma meet_minus (s t : set X)
    : s ∩ (t \ s) [=] ∅.
  Proof.
    cset_tac.
  Qed.

  Lemma meet_in_left (s t : set X)
    : s ∩ t ⊆ s.
  Proof.
    cset_tac.
  Qed.

  Lemma not_in_meet_empty (D:set X) x
    : ~ x ∈ D
    -> D ∩ {{x}} [=] ∅.
  Proof.
    cset_tac.
  Qed.

  Lemma incl_eq (s t:set X)
    : s ⊆ t -> t ⊆ s -> t [=] s.
  Proof.
    cset_tac.
  Qed.

  End theorems.

  Section moretheorems.

  Require Import List.
  Variable X : Type.
  Context `{OrderedType X}.

  Hypothesis equiv_is_eq : _eq = eq.

End moretheorems.

Definition addf {X} `{OrderedType X} {Y} `{OrderedType Y} (f:X->Y) :=
  (fun x t => add (f x) t).

Add Parametric Morphism {X} `{OrderedType X} {Y} `{OrderedType Y} (f:X->Y)
  `{Proper _ (_eq ==> _eq) f}
  : (addf f)
  with signature
    _eq ==> Equal ==> Equal as addf_morphism.
Proof.
  intros. unfold addf. rewrite H2. rewrite H3. reflexivity.
Qed.

Add Parametric Morphism {X} `{OrderedType X} {Y} `{OrderedType Y} (f:X->Y)
  : (addf f)
  with signature
    eq ==> Equal ==> Equal as addf_morphism2.
Proof.
  intros. unfold addf. rewrite H1. reflexivity.
Qed.

Lemma addf_transpose {X} `{OrderedType X} {Y} `{OrderedType Y} (f:X->Y)
 : transpose Equal (addf f).
Proof.
  hnf; intros.
  unfold addf. hnf. intros. rewrite add_add. split; eauto.
Qed.

Lemma minus_union_both X `{OrderedType X} (s t: set X) x
  : x ∉ s -> s \ t [=] (s ∪ {{x}}) \ (t ∪ {{x}}).
Proof.
  cset_tac; firstorder.
Qed.

Lemma list_eq_eq {X} {L L':list X}
  : list_eq eq L L' <-> L = L'.
Proof.
  split; intros. eapply list_eq_ind; intros; subst; f_equal; eauto.
  general induction L; econstructor; eauto.
Qed.

Lemma minus_idem X `{OrderedType X} (s t:set X)
: s \ t [=] (s \ t) \ t.
Proof.
  cset_tac; intuition.
Qed.

Lemma meet_incl_eq {X} `{OrderedType X} (s s' t t':set X)
: t' ⊆ t -> s ∩ t [=] s' ∩ t -> s ∩ t' [=] s' ∩ t'.
Proof.
  cset_tac.
Qed.

Lemma InA_in {X} `{OrderedType X} x L
 : InA _eq x L <-> x ∈ of_list L.
Proof.
  split; intros.
  general induction L; cset_tac.
  general induction L; cset_tac.
Qed.

Smpl Add 50
     match goal with
      | [ H : @SetInterface.In _ (@SOT_as_OT _ _ _ ) _ ?x (of_list ?l), I : InA eq ?x ?l -> False |- _ ]
        => exfalso; eapply InA_in in H; simpl in H; eapply I; eapply H
     end : cset.

Lemma minus_minus_eq {X} `{OrderedType X} (s t : set X)
  : s [=] s \ (t \ s).
Proof.
  cset_tac.
Qed.

Lemma union_incl_left {X} `{OrderedType X} (s t u: set X)
: s ⊆ t -> s ⊆ t ∪ u.
Proof.
  cset_tac.
Qed.

Lemma incl_set_left X `{OrderedType X} (s t : set X)
: s [=] t -> s [<=] t.
Proof.
  cset_tac.
Qed.

Lemma minus_inter_empty X `{OrderedType X} s t u
: s ∩ t [=] s ∩ u
  -> s \ t [=] s \ u.
Proof.
  cset_tac.
Qed.

Lemma union_eq_decomp X `{OrderedType X} s s' t t'
: s [=] s' -> t [=] t' -> s ∪ t [=] s' ∪ t'.
Proof.
  intros A B; rewrite A, B; eauto.
Qed.

Lemma add_struct_incl X `{OrderedType X} x s t
: s ⊆ t
  -> {x; s} ⊆ {x; t}.
Proof.
  cset_tac.
Qed.

Lemma add_struct_incl' X `{OrderedType X} x y s t
  : x === y
    -> s ⊆ t
    -> {x; s} ⊆ {y; t}.
Proof.
  cset_tac.
Qed.

Hint Resolve add_struct_incl add_struct_incl' : cset.

Lemma add_struct_eq X `{OrderedType X} x s t
: s [=] t
  -> {x; s} [=] {x; t}.
Proof.
  cset_tac.
Qed.

Lemma add_struct_eq' X `{OrderedType X} x y s t
  : x === y
     -> s [=] t
  -> {x; s} [=] {y; t}.
Proof.
  cset_tac.
Qed.

Hint Resolve add_struct_eq add_struct_eq' : cset.

Lemma union_struct_eq_1 X `{OrderedType X} s t u
: s [=] t
  ->  s ∪ u [=] t ∪ u.
Proof.
  cset_tac.
Qed.

Lemma union_struct_eq_2 X `{OrderedType X} s t u
: s [=] t
  ->  u ∪ s [=] u ∪ t.
Proof.
  cset_tac.
Qed.

Lemma not_in_minus X `{OrderedType X} (s t: set X) x
: x ∉ s
  -> x ∉ s \ t.
Proof.
  cset_tac.
Qed.

Lemma equal_minus_empty X `{OrderedType X} s t
  : s [=] t
    -> s [=] t \ {}.
Proof.
  cset_tac.
Qed.

Lemma incl_minus_empty X `{OrderedType X} s t
  : s ⊆ t
    -> s ⊆ t \ {}.
Proof.
  cset_tac.
Qed.

Lemma incl_minus_change X `{OrderedType X} s t x
  : (s \ t) \ {x; {}}[<=]s \ {x; t}.
Proof.
  cset_tac.
Qed.

Lemma incl_minus_union X `{OrderedType X} s t u
  :  (s \ t) \ u [<=] s \ (u ∪ t).
Proof.
  cset_tac.
Qed.

Lemma incl_union_incl_minus X `{OrderedType X} s t u
  : s \ t ⊆ u
    -> s ⊆ t ∪ u.
Proof.
  cset_tac.
Qed.

Lemma incl_meet_split X `{OrderedType X} s t u
  : s ⊆ t -> s ⊆ u -> s ⊆ t ∩ u.
Proof.
  cset_tac.
Qed.

Lemma equiv_minus_union X `{OrderedType X} s t
  : s ⊆ t -> t [=] t \ s ∪ s.
Proof.
  cset_tac'.
Qed.

Lemma diff_subset_equal' X `{OrderedType X} s s'
  : s \ s' [=] {} -> s ⊆ s'.
Proof.
  intros. hnf; intros. exploit (H0 a).
  cset_tac.
Qed.

Smpl Add
     match goal with
     | [ H : Empty ?s |- _ ] => apply empty_is_empty_1 in H
     end : cset.

Lemma not_incl_exists X `{OrderedType X} s t
  :  (s ⊆ t -> False)
     -> exists x, x ∈ s /\ x ∉ t.
Proof.
  pattern s. eapply set_induction; intros.
  - exfalso. eapply H1. cset_tac.
  - rewrite Add_Equal in H2. rewrite H2 in H3.
    decide (x ∈ t).
    + edestruct H0; eauto.
      * intros. eapply H3. cset_tac.
      * cset_tac.
    + eexists x; cset_tac.
Qed.

Smpl Add
     match goal with
     | [ H : ?s ⊆ ?t -> False |- _ ] => eapply not_incl_exists in H
     end : cset.

Lemma not_incl_element X `{OrderedType X} s
  : forall s', ~ s ⊆ s' -> exists x, x ∈ s /\ x ∉ s'.
Proof.
  pattern s. eapply set_induction; intros.
  - cset_tac.
  - rewrite Add_Equal in H2. cset_tac.
Qed.

Lemma minus_minus X `{OrderedType X} (s t : set X) : s \ (s \ t) [=] s ∩ t.
Proof.
cset_tac.
Qed.

Lemma incl_minus_incl X `{OrderedType X} (s t u : set X) : s ⊆ t -> u \ t ⊆ u \ s.
cset_tac.
Qed.

Lemma incl_add_eq X `{OrderedType X}(s t : set X ) (a : X) : {a; t} ⊆ s <-> a ∈ s /\ t ⊆ s.
Proof.
split; intros H0.
- split.
  + eapply H0. cset_tac.
  + rewrite <- H0. cset_tac.
- destruct H as [ain yx]. decide (a ∈ t); cset_tac.
Qed.

Lemma of_list_elements X `{OrderedType X} (s : set X)
 : of_list (elements s) [=] s.
Proof.
  cset_tac'.
  - apply of_list_1 in H0; rewrite <- elements_iff in H0; eauto.
  - rewrite of_list_1; rewrite <- elements_iff; eauto.
Qed.

Lemma incl_union_incl X `{OrderedType X} s t u w
  : t ∪ u ⊆ w -> s ⊆ t -> s ⊆ w.
  cset_tac.
Qed.

Lemma incl_union_right X `{OrderedType X} s t u
: s ⊆ t -> s ⊆ u ∪ t.
Proof.
  cset_tac.
Qed.

Arguments incl_union_right X [H] s t u _ _ _ .

Lemma incl_union_left X `{OrderedType X} s t u
: s ⊆ t -> s ⊆ t ∪ u.
Proof.
  cset_tac.
Qed.

Arguments incl_union_left X [H] s t u _ _ _ .

Lemma incl_add_right X `{OrderedType X} s t x
: s ⊆ t -> s ⊆ {x; t}.
Proof.
  cset_tac.
Qed.

Lemma in_add_left X `{OrderedType X} s x
: x ∈ {x; s}.
Proof.
  cset_tac.
Qed.

Lemma to_list_nil {X} `{OrderedType X}
  : to_list ∅ = nil.
Proof.
  cset_tac.
Qed.

Lemma add_minus_single_eq X `{OrderedType X} x s
  : x ∈ s
    -> {x; s \ singleton x} [=] s.
Proof.
  cset_tac.
Qed.

Hint Resolve add_minus_single_eq : cset.

Lemma add_union X `{OrderedType X} x s
  : {x; s} [=] singleton x ∪ s.
Proof.
  cset_tac.
Qed.

Lemma minus_incl_incl_union X `{OrderedType X} s t u
  : s \ t ⊆ u
    -> s ⊆ t ∪ u.
Proof.
  intros H1. rewrite <- H1. clear H1.
  cset_tac.
Qed.

Lemma empty_neutral_union_r (X : Type) `{OrderedType X} (s : ⦃X⦄)
  : s ∪ ∅ [=] s.
Proof.
  cset_tac.
Qed.

Lemma union_meet_distr_l (X : Type) `{OrderedType X} (s t u : ⦃X⦄)
  : s ∩ (t ∪ u) [=] (s ∩ t) ∪ (s ∩ u).
Proof.
  cset_tac.
Qed.

Lemma meet_union_distr_r (X : Type) `{OrderedType X} (s t u : ⦃X⦄)
  : (s ∩ t) ∪ u [=] (s ∪ u) ∩ (t ∪ u).
Proof.
  cset_tac.
Qed.

Lemma meet_union_distr_l (X : Type) `{OrderedType X} (s t u : ⦃X⦄)
  : s ∪ (t ∩ u) [=] (s ∪ t) ∩ (s ∪ u).
Proof.
  cset_tac.
Qed.

Lemma minus_minus_add X `{OrderedType X} (s t:set X) x
  : s \ {x;t} [=] s \ t \ singleton x.
Proof.
  cset_tac.
Qed.

Lemma add_incl (X : Type) `{OrderedType X} (x : X) (s t : ⦃X⦄)
  : {x; s} ⊆ t -> x ∈ t /\ s ⊆ t.
Proof.
  cset_tac.
Qed.

Lemma of_list_empty (X : Type) `{OrderedType X} (L : list X)
  : of_list L [=] ∅ <-> L = nil.
Proof.
  destruct L; simpl; eauto.
  - split; eauto.
  - split; intros; isabsurd.
    exfalso. cset_tac.
Qed.

Lemma in_singleton (X : Type) `{OrderedType X} (x : X) (s : ⦃X⦄)
  : singleton x ⊆ s -> x ∈ s.
Proof.
  cset_tac.
Qed.

Lemma union_incl_split2 (X : Type) `{OrderedType X} (s t u : ⦃X⦄)
  : s ∪ t ⊆ u -> s ⊆ u /\ t ⊆ u.
Proof.
  cset_tac.
Qed.

Lemma incl_minus_union' (X:Type) `{OrderedType X} (s t u : ⦃X⦄)
  : t ⊆ u -> s \ t ∪ u [=] s ∪ u.
Proof.
  cset_tac.
Qed.

Lemma cap_special_in X `{OrderedType X} G
  : forall x D, x ∈ D -> {x; G} ∩ D [=] {x; G ∩ D}.
Proof.
  cset_tac.
Qed.

Lemma cap_special_notin X `{OrderedType X} G
  : forall x D, x ∉ D -> {x; G} ∩ D [=] G ∩ D.
Proof.
  cset_tac.
Qed.

Lemma For_all_union X `{OrderedType X} (P:X -> Prop) s t
  : For_all P (s ∪ t) <-> For_all P s /\ For_all P t.
Proof.
  unfold For_all. cset_tac.
Qed.