Require Import Coq.Arith.Arith.
Require Import Coq.Logic.FunctionalExtensionality.
Set Implicit Arguments.

Section Base.

  Variable Var : Set.
  Variable Val : Set.

  Definition State := Var -> Val.
  Definition StateFunc := State -> Val.
  Definition Predicate := State -> Prop.
  Definition Action := State -> State -> Prop.

  Definition unchanged (f : StateFunc) : Action :=
    fun st st' => f st = f st'.

  Definition pred (P : Predicate) : Action :=
    fun st st' => P st.

  Definition prime (P : Predicate) : Action :=
    fun st st' => P st'.

  Inductive Formula :=
  | F_Act : Action -> Formula
  | F_Enabled : Action -> Formula
  | F_Always : Formula -> Formula
  | F_Eventually : Formula -> Formula
  | F_Not : Formula -> Formula
  | F_And : Formula -> Formula -> Formula
  | F_Or : Formula -> Formula -> Formula
  | F_Imp : Formula -> Formula -> Formula
  | F_Iff : Formula -> Formula -> Formula.

  Definition Trace := nat -> State.
  Definition shift (t : Trace) (n : nat) : Trace := fun m => t (n + m).
  Infix "<<" := shift (at level 55, left associativity).

  Section Shift.
    Variable t : Trace.
    (* Make sure we got the precedence and associativity right. *)
    (* Check (t << 10 << 5 + 1 << 2 * 10 << 10 - 9). *)

    Theorem shift_id :
      t << 0 = t.
    Proof.
      reflexivity.
    Qed.

    Theorem shift_add :
      forall n m, t << n << m = t << n + m.
    Proof.
      unfold shift.
      intros n m.
      apply functional_extensionality.
      intros x.
      f_equal.
      apply Nat.add_assoc.
    Qed.

    Theorem shift_app :
      forall n i, (t << n) i = t (n + i).
    Proof.
      intros n i.
      unfold shift.
      reflexivity.
    Qed.

    Lemma shift_app_add :
      forall i j k, (t << i + j) k = (t << i) (j + k).
    Proof.
      intros i j k.
      repeat (rewrite shift_app).
      intuition.
    Qed.

  End Shift.

  Fixpoint satisfies (fm : Formula) (t : Trace) : Prop :=
    match fm with
    | F_Act A => A (t 0) (t 1)
    | F_Enabled A => exists st', A (t 0) st'
    | F_Always p => forall n, satisfies p (t << n)
    | F_Eventually p => exists n, satisfies p (t << n)
    | F_Not p => ~satisfies p t
    | F_And p q => satisfies p t /\ satisfies q t
    | F_Or p q => satisfies p t \/ satisfies q t
    | F_Imp p q => satisfies p t -> satisfies q t
    | F_Iff p q => satisfies p t <-> satisfies q t
    end.

  Notation "~ A" := (F_Not A) : tla_scope.
  Infix "/\" := F_And : tla_scope.
  Infix "\/" := F_Or : tla_scope.
  Infix "==>" := F_Imp (at level 99, right associativity) : tla_scope.
  Infix "<==>" := F_Iff (at level 95, no associativity) : tla_scope.
  Notation "[] F" := (F_Always F) (at level 75, right associativity) : tla_scope.
  Notation "<> F" := (F_Eventually F) (at level 75, right associativity) : tla_scope.

  Delimit Scope tla_scope with tla.

  Definition F_Pred (P : Predicate) : Formula :=
    F_Act (pred P).

  Definition F_Box (A : Action) (f : StateFunc) : Formula :=
    F_Or (F_Act A) (F_Act (unchanged f)).

  Coercion F_Act : Action >-> Formula.
  Coercion F_Pred : Predicate >-> Formula.

  Local Open Scope tla_scope.

  Definition valid (fm : Formula) := forall t, satisfies fm t.

  Theorem STL2 :
    forall F, valid ([]F ==> F).
  Proof.
    intros F t; simpl.
    intros H.
    specialize H with 0.
    assumption.
  Qed.

  Theorem STL3 :
    forall F, valid ([][]F <==> []F).
  Proof.
    intros F t; simpl.
    split; intros H.

    intros n.
    specialize (H n 0).
    assumption.

    intros n m.
    specialize H with (n + m).
    rewrite shift_add.
    assumption.
  Qed.

  Theorem STL4 :
    forall F G, valid (F ==> G) -> valid ([]F ==> []G).
  Proof.
    intros F G.
    unfold valid; simpl.
    intuition.
  Qed.

  Theorem STL5 :
    forall F G,
      valid ( [](F /\ G) <==> []F /\ []G).
  Proof.
    intros F G.
    unfold valid; simpl.
    split; [intros H; split; intros n; specialize (H n) | idtac]; intuition.
  Qed.

  Theorem TLA1 :
    forall (P : Predicate) f,
      valid (P /\ unchanged f ==> prime P) ->
      valid ([]P <==> P /\ []((P ==> prime P) \/ unchanged f)).
  Proof.
    intros P f.
    unfold valid, unchanged; simpl.
    unfold pred, prime; simpl.
    intros H t; split.

    intros Hn; split.
    specialize Hn with 0; assumption.

    left; intros.
    specialize Hn with (n+1).
    rewrite shift_app_add in Hn.
    assumption.

    intros (HP, Hn).
    induction n; try assumption.
    replace (S n) with (n+1) by apply Nat.add_1_r.
    rewrite shift_app_add.
    specialize H with (t << n).
    specialize Hn with n.
    intuition.
  Qed.

  Theorem TLA2 :
    forall (P Q : Predicate) (A B : Action) (f g : StateFunc),
      valid (P /\ (F_Box A f) ==> Q /\ (F_Box B g)) ->
      valid ([]P /\ [](F_Box A f) ==> []Q /\ [](F_Box B g)).
  Proof.
    intros P Q A B f g.
    unfold valid, unchanged; simpl.
    unfold pred; simpl.
    intros Ht t (HP, HA).
    split;
      intros n;
      specialize Ht with (t << n);
      specialize HP with n;
      specialize HA with n;
      intuition.
  Qed.

  Theorem INV1 :
    forall (I : Predicate) (N : Action) (f : StateFunc),
      valid (I /\ (F_Box N f) ==> prime I) ->
      valid (I /\ [](F_Box N f) ==> []I).
  Proof.
    intros I N f.
    unfold valid, unchanged; simpl.
    unfold pred, prime; simpl.
    intros Ht t.
    intros (H0, Hn) n.
    induction n; try assumption.
    replace (S n) with (n+1) by apply Nat.add_1_r.
    rewrite shift_app_add.
    specialize Hn with n.
    intuition.
  Qed.

End Base.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* Course of values induction                                               *)
(* To be integrated in ARITH library                                        *)
(*                                                                          *)
(****************************************************************************)
(*                           Complete_induction.v                           *)
(****************************************************************************)

Require Import Lt.
Require Import Le.

Definition lt_hereditary (P : nat -> Prop) :=
  forall n : nat, (forall m : nat, m < n -> P m) -> P n.

Lemma le_split : forall m n : nat, m <= S n -> m <= n \/ m = S n.
Proof.
intros m n H; elim (le_lt_or_eq m (S n)); auto with arith.
Qed.

Lemma course_of_values :
 forall P : nat -> Prop, lt_hereditary P -> forall n m : nat, m <= n -> P m.
Proof.
unfold lt_hereditary in |- *; simple induction n.
intros; apply H.
elim (le_n_O_eq m); trivial with arith.
intros p abs; elim lt_n_O with p; trivial with arith.
intros p lemp m lemSp; elim le_split with m p; auto with arith.
intro E; rewrite E; auto with arith. (* using lt_n_Sm_le *)
Qed.

Lemma complete_induction :
 forall P : nat -> Prop, lt_hereditary P -> forall n : nat, P n.
Proof.
intros; apply course_of_values with (m := n) (n := n); auto with arith.
Qed.

(* Version Ledinot *)
Lemma nat_wf_ind :
 forall P : nat -> Prop,
 P 0 ->
 (forall k : nat, (forall l : nat, l <= k -> P l) -> P (S k)) ->
 forall n : nat, P n.
Proof.
intros P H0 Hk.
cut (forall n k : nat, k <= n -> P k).
intros HC n.
apply HC with (n := n); auto with arith.
simple induction n.
intros k Def_k.
elimtype (0 = k); auto with arith.
clear n.
intros n Hn k k_le_Sn.
elim (le_split k n); auto with arith.
intro Def_k.
rewrite Def_k.
auto with arith.
Qed.


(* This file contains the definition of the base 2 logarithm function (rounded down) over natural numbers. *)

(* Some of the definitions and theory in this file were added to Coq 8.4, so we should refactor this at some point. *)

Set Implicit Arguments.

Require Import ZArith.

(* log2 is like log_inf except it returns nat, so I don't have to reason about an unnecessary conversion. This function is only used to implement lognat below.*)
Fixpoint log2(n : positive) : nat :=
  match n with
    | xH => 0
    | xO n' | xI n' => (S (log2 n'))
  end.

Lemma log2_prod_sum : forall(a : positive),
  (S (log2 a)) = (log2 (Pmult 2 a)).

  intros. auto.
Qed.

Lemma le_s : forall a b,
  (a <= b) -> S a <= S b.

  intros. omega.
Qed.

Lemma log2_monotonic_b : forall(a : positive),
  (log2 a) <= (log2 (Psucc a)).

  induction a;
  simpl in *; try apply le_s; auto.
Qed.

Lemma log2_ge_monotonic : forall(a : positive),
  (log2 (Psucc a)) >= (log2 a).

  induction a;
  simpl in *; try apply le_s; auto.
Qed.

Definition nat_to_pos (n : nat) : (n <> 0) -> positive :=
  fun _ => (P_of_succ_nat (pred n)).

Lemma double_nat_nz : forall(a : nat)(pf : a <> 0),
  ((2 * a) <> 0).
  intros. omega.
Qed.
Lemma s_nat_nz : forall(a : nat)(pf : a <> 0),
  ((S a) <> 0).
  intros. omega.
Qed.

Lemma factor_s_conv : forall(a : nat)(pf1 : (a <> 0))(pf2 : (S a) <> 0),
  (nat_to_pos (pf2)) = (Psucc (nat_to_pos pf1)).

  intros.
  destruct a.
  congruence.

  unfold nat_to_pos in *.
  simpl in *.
  intros. auto.
Qed.

Lemma add_s_r : forall a b,
  a + (S b) = S (a + b).
  intros. omega.
Qed.

Lemma factor_double_s : forall a,
  (2 * (S a)) = (S (S (2 * a))).

  intros. omega.
Qed.

Lemma factor_double_conv : forall(a : nat)(pf1 : (a <> 0))(pf2 : (2 * a) <> 0),
  (nat_to_pos pf2) = (Pmult 2 (nat_to_pos pf1)).

  induction a; intros; simpl in *.
  congruence.

  destruct (eq_nat_dec a 0).
  subst.
  unfold nat_to_pos.
  auto.

  assert (a + S (a + 0) <> 0) by omega.
  specialize (factor_s_conv H). intros.
  unfold nat_to_pos in *.

  rewrite (H0 pf2). clear H0.  clear pf2.
  assert (a + S (a + 0) = S (a + (a + 0))) by omega.
  rewrite H0.
  assert (a + (a + 0) <> 0) by omega.
  specialize (factor_s_conv H1). intros.

  unfold nat_to_pos in H2.
  rewrite <- H0 in H2.
  rewrite <- H0.
  rewrite (H2 H). clear H. clear H2.

  rewrite (IHa n). clear IHa.
  simpl.
  destruct a. intros. destruct n. auto.

  auto.
  omega.
Qed.

Definition lognat(n : nat) : (n <> 0) -> nat :=
  fun pf => (log2 (nat_to_pos pf)).

Theorem lognat_prod_sum : forall(a : nat)(pf1 : (a <> 0))(pf2: (2 * a) <> 0),
  (S (lognat pf1)) = (lognat pf2).

  intros.
  unfold lognat in *.
  rewrite (factor_double_conv pf1 pf2).
  eapply log2_prod_sum.
Qed.

Theorem lognat_monotonic_b : forall(a : nat)(pf1 : (a <> 0))(pf2: (S a) <> 0),
  (lognat pf1) <= (lognat pf2).

  induction a.
  intros.
  destruct pf1. auto.

  intros.
  unfold lognat in *.
  rewrite (factor_s_conv pf1).
  apply log2_monotonic_b.
Qed.

(* for good measure, we will define exponentiation for nat and prove that lognat is correct *)
Fixpoint expnat(a e : nat) : nat :=
  match e with
    | 0 => 1
    | (S e') => a * (expnat a e')
  end.

Lemma mult_ne : forall a b,
  a <> 0 -> b <> 0 -> a * b <> 0.

  intros.
  destruct a. omega.
  destruct b. omega.
  simpl.
  remember (b + a * (S b)) as c.
  omega.
Qed.

Theorem expnat_nz : forall a e,
  (a <> 0) -> (expnat a e) <> 0.

  induction e.
  simpl. auto.

  simpl.
  intros.
  eapply mult_ne; eauto.
Qed.

Lemma nz_2 : 2 <> 0.
  omega.
Qed.

Theorem expnat_2_nz: forall e,
  (expnat 2 e) <> 0.

  intros.
  apply (expnat_nz e nz_2).
Qed.

Theorem expnat_2_monotonic : forall e1 e2,
  e1 <= e2 ->
  (expnat 2 e1 <= expnat 2 e2).

  induction e1.
  intros.
  simpl.
  specialize (expnat_2_nz e2). intros.
  omega.

  induction e2;
  intros.
  omega.

  simpl.
  specialize (IHe1 e2).
  omega.
Qed.

Theorem lognat_correct_eq : forall(b : nat)(pf : (expnat 2 b) <> 0),
  (lognat pf) = b.

  induction b.
  intros. simpl in *. auto.

  intros.
  specialize (lognat_prod_sum (expnat_2_nz b)). intros.
  specialize (IHb (expnat_2_nz b)).
  rewrite IHb in H.
  symmetry in H.
  simpl in *.
  apply H.
Qed.

Lemma fold_add : forall a,
  a + (a + 0) = 2*a.
  intros. omega.
Qed.

Theorem lognat_ge_monotonic_b : forall(a : nat)(pf1 : (a <> 0))(pf2: (S a) <> 0),
  (lognat pf2) >= (lognat pf1).

  induction a.
  intros.
  destruct pf1. auto.

  intros.
  unfold lognat in *.
  rewrite (factor_s_conv pf1).
  apply log2_monotonic_b.
Qed.

Lemma ge_trans : forall a b c,
  a >= b -> b >= c -> a >= c.
  intuition.
Qed.

Lemma lognat_ge_monotonic_h : forall (c a b : nat)(pfa : a <> 0)(pfb : b <> 0),
    a >= b -> c = (a - b) -> (lognat pfa) >= (lognat pfb).

  induction c.
  intros.
  assert (a = b) by intuition.
  subst. auto.

  intros.
  assert (a >= (S b)) by omega.
  assert (c = a - (S b)) by omega.
  eapply ge_trans.
  apply (IHc a (S b) pfa (s_nat_nz pfb)).
  apply H1.
  apply H2.
  apply lognat_ge_monotonic_b.
Qed.

Lemma lognat_ge_monotonic : forall (a b : nat)(pfa : a <> 0)(pfb : b <> 0),
    a >= b -> (lognat pfa) >= (lognat pfb).

  intros.
  remember (a - b) as c.
  apply (@lognat_ge_monotonic_h c); auto.
Qed.

Lemma lognat_monotonic : forall (a b : nat)(pfa : a <> 0)(pfb : b <> 0),
    a <= b -> (lognat pfa) <= (lognat pfb).

  intros.
  remember (b - a) as c.
  apply (@lognat_ge_monotonic_h c); auto.
Qed.

Theorem mt : forall P Q: Prop, (P -> Q) -> (~Q -> ~P).
  unfold not in *.
  intros.
  apply H0.
  apply H.
  apply H1.
Qed.

Lemma ge_not : forall a b,
  ~(a >= b) -> a < b.
  intuition.
Qed.

Lemma lognat_ge_monotonic_mt : forall (a b : nat)(pfa : a <> 0)(pfb : b <> 0),
    (lognat pfa) < (lognat pfb) -> a < b.

  intros.
  specialize (lognat_ge_monotonic pfa pfb).
  intros.
  specialize (mt H0).
  intros.
  apply ge_not. omega.
Qed.

Lemma lognat_correct2 : forall(a : nat)(pf : a <> 0),
  a < (expnat 2 (S (lognat pf))).

  intros.

  simpl.
  rewrite fold_add.
  assert (expnat 2 (lognat pf) <> 0). apply expnat_nz. auto.
  assert (2 * (expnat 2 (lognat pf)) <> 0). omega.
  eapply (lognat_ge_monotonic_mt pf H0).
  rewrite <- (lognat_prod_sum H).
  rewrite lognat_correct_eq.
  omega.
Qed.

Lemma lognat_odd : forall(a : nat)(pf1 : (2 * a) <> 0)(pf2 : (S (2 * a)) <> 0),
  ((lognat pf2) = (lognat pf1)).

  intros.
  unfold lognat in *.
  rewrite (factor_s_conv pf1 pf2).
  assert (a <> 0). omega.
  rewrite (factor_double_conv H pf1).
  simpl.
  auto.
Qed.

Lemma double_s : forall a, (S (S (2 * a))) = 2 * (S a).
  intros. omega.
Qed.

Lemma lognat_double_eq : forall a b (pf1: 2 * a <> 0)(pf2: 2 * b <> 0)(pf3 : a <> 0) (pf4: b <> 0),
  lognat pf3 = lognat pf4 ->
  lognat pf1 = lognat pf2.

  intros.
  rewrite <- (lognat_prod_sum pf3).
  rewrite <- (lognat_prod_sum pf4).
  omega.
Qed.

Lemma nat_comp : forall(a : nat),
  exists x : nat,
  (a = (2 * x) \/ a = (S (2 * x))).

  induction a.
  exists 0. simpl.  auto.

  elim IHa. clear IHa.
  intros.
  destruct H.
  subst. simpl.
  exists x.
  right. auto.

  subst. simpl.
  exists (S x).
  left.
  simpl.
  omega.
Qed.

Lemma lognat_correct1 : forall(b a : nat)(pf : a <> 0),
  (lognat pf) = b ->
  (expnat 2 b) <= a.

  induction b.

  intros. simpl in *. omega.

  intros.
  elim (nat_comp a). intros.
  destruct H0.
  subst.
  destruct (eq_nat_dec x 0).
  subst. omega.
  rewrite <- (lognat_prod_sum n pf) in H.
  inversion H. clear H.
  rewrite H1.
  apply IHb in H1.
  simpl in *. omega.

  subst.
  destruct (eq_nat_dec x 0).
  subst. unfold lognat in H. simpl in *. omega.
  assert ((2 * x) <> 0). omega.
  rewrite (lognat_odd x H0 pf) in H.

  rewrite <- (lognat_prod_sum n H0) in H.
  inversion H.
  rewrite H2.
  apply IHb in H2.
  simpl.
  omega.
Qed.

Theorem lognat_correct : forall(a : nat)(pf : a <> 0),
  (expnat 2 (lognat pf)) <= a < (expnat 2 (S (lognat pf))).

  intros.
  split.
  remember (lognat pf) as b.
  apply (lognat_correct1 pf). auto.
  apply lognat_correct2.
Qed.

Lemma lognat_prod_sum_gen_h : forall (a' a b: nat)(pf1 : (a <> 0))(pf2 : (b <> 0))(pf3 : a * b <> 0),
  lognat pf1 = a' ->
  a' + lognat pf2 <= lognat pf3.

  induction a'; intros.
  simpl.
  eapply lognat_monotonic.
  induction a.
  congruence.
  simpl.
  intuition.

  destruct (nat_comp a).
  destruct H0.
  subst.
  assert (x <> 0). omega.
  assert (x * b <> 0). destruct x; destruct b; simpl; congruence.
  rewrite <- (lognat_prod_sum H0) in H.
  assert (lognat pf3 = S (lognat H1)).
  generalize pf3.
  rewrite mult_assoc_reverse.
  intros.
  rewrite (lognat_prod_sum _ pf0).
  trivial.

  rewrite H2.
  inversion H.
  specialize (IHa' x b H0 pf2 H1 H4).
  subst.
  omega.

  destruct (eq_nat_dec x 0).
  subst.
  unfold lognat in *.
  simpl in *.
  discriminate.

  assert (2 * x <> 0). omega.
  assert (x * b <> 0). destruct x; destruct b; simpl; congruence.
  assert (2 * x * b <> 0). rewrite mult_assoc_reverse. omega.
  subst.
  rewrite (lognat_odd _ H1) in H.
  rewrite <- (lognat_prod_sum n) in H.
  inversion H.
  subst.
  assert (lognat n = lognat n). trivial.
  specialize (IHa' x b n pf2 H2 H0).

  generalize pf3.
  assert (S (2 * x) * b = b + 2 * x * b). intuition.
  rewrite H4.
  intros.
  eapply le_trans.
  Focus 2.
  eapply (lognat_monotonic H3). intuition.
  generalize H3.
  rewrite mult_assoc_reverse.
  intros.
  rewrite <- (lognat_prod_sum H2).
  omega.
Qed.

Theorem lognat_prod_sum_gen : forall (a b: nat)(pf1 : (a <> 0))(pf2 : (b <> 0))(pf3 : a * b <> 0),
  lognat pf1 + lognat pf2 <= lognat pf3.

  intros.
  eapply lognat_prod_sum_gen_h.
  eauto.
Qed.

Lemma lognat_0_1 : forall n (pf : n <> 0),
  lognat pf = 0 -> n = 1.

  intros.
  destruct n.
  omega.

  destruct n.
  trivial.

  assert (2 <> 0). omega.
  assert (lognat pf >= lognat H0).
  eapply lognat_ge_monotonic.
  omega.

  unfold lognat in *.
  simpl in *.
  omega.
Qed.

Lemma lognat_succ_h : forall a n (pf1 : n <> 0)(pf2: (S n) <> 0),
  a = lognat pf1 ->
    lognat pf2 = a \/
    lognat pf2 = S (a).

  induction a; intros.
  assert (n = 1).
  apply (lognat_0_1 pf1).
  auto.
  subst.
  unfold lognat.
  simpl.
  auto.

  destruct (nat_comp n).
  destruct H0.
  subst.
  assert (x <> 0). omega.
  rewrite <- (lognat_prod_sum H0) in H.
  inversion H.
  subst.
  rewrite (lognat_odd _ pf1).
  rewrite <- (lognat_prod_sum H0).
  auto.

  subst.
  destruct (eq_nat_dec x 0).
  subst.
  unfold lognat in *.
  simpl in *.
  omega.

  generalize pf2.
  assert (S (S (2 * x)) = 2 * (S x)). omega.
  rewrite H0.
  intros.
  assert (S x <> 0). omega.
  assert (2 * x <> 0). omega.
  rewrite (lognat_odd _ H2) in H.
  rewrite <- (lognat_prod_sum n) in H.
  inversion H.
  rewrite <- (lognat_prod_sum H1).
  specialize (IHa x n H1 H4).
  destruct IHa.
  subst.
  rewrite H4.
  auto.
  subst.
  right.
  rewrite H3.
  auto.

Qed.

Lemma lognat_succ : forall n (pf1 : n <> 0)(pf2: (S n) <> 0),
  lognat pf2 = lognat pf1 \/
  lognat pf2 = S (lognat pf1).

  intros.
  eapply lognat_succ_h.
  eauto.
Qed.

Lemma logn_ge_1 : forall n (pf : n <> 0),
  n > 1 -> lognat pf >= 1.

  intros.
  destruct n.
  congruence.

  destruct n.
  omega.

  assert (2 <> 0).
  omega.

  assert (forall n (pf1 : S (S n) <> 0)(pf2 : 2 <> 0), lognat pf1 >= lognat pf2).
  intros.
  eapply lognat_ge_monotonic.
  omega.

  assert (forall (pf : 2 <> 0), 1 = lognat pf).
  intros.
  unfold lognat.
  auto.

  rewrite (H2 H0).
  eauto.

Qed.


Require Import Nat Arith.

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

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

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

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

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

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

Theorem append_nil: forall (l: Lst), append l nil = l.
Proof.
  induction l.
  { simpl. f_equal. assumption. }
  { simpl. reflexivity. }
Qed.

Theorem append_assoc:
  forall (l1 l2 l3: Lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
  induction l1; induction l2; induction l3; try (simpl; reflexivity).
  { simpl. rewrite <- IHl1. f_equal. }
  { simpl. rewrite 2 append_nil. reflexivity. }
  { simpl. rewrite append_nil.  reflexivity. }
  { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem append_rev_cons:
  forall (l1 l2: Lst) (x: Nat),
    rev (append l1 (cons x l2)) = append (rev l2) (cons x (rev l1)).
Proof.
  induction l1; induction l2; try (simpl; reflexivity).
  { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
    f_equal. }
  { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: Lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
  induction l1.
  { induction l2.
    { simpl. rewrite append_rev_cons.
      rewrite <- 2 append_assoc.
      f_equal. }
    { simpl. rewrite append_nil. reflexivity. }
  }
  { intro. simpl. rewrite append_nil. reflexivity. }
Qed.

Theorem theorem0 : forall (x : Lst), eq (rev (rev x)) x.
Proof.
  induction x.
  { simpl. rewrite rev_append. simpl. f_equal.
    assumption. }
  { simpl. reflexivity. }
Qed.


Require Import Arith.

Fixpoint sum_odd(n:nat) : nat :=
  match n with
    | O => O
    | S m => 1 + m + m + sum_odd m
  end.

Goal forall n, sum_odd n = n * n.
Proof.
  intros.
  induction n.
  reflexivity.
  simpl.
  rewrite IHn.
  ring.
Qed.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Omega.
Require Export Zwf.

Ltac caseEq f := generalize (refl_equal f); pattern f at -1; case f.

(* taken from chapter 5 *)

Inductive plane : Set :=
    point : Z->Z->plane.

Inductive htree (A:Set) : nat->Set :=
  | hleaf : A -> htree A 0%nat
  | hnode : forall n:nat, A -> htree A n -> htree A n -> htree A (S n).

Inductive south_west : plane->plane->Prop :=
  south_west_def :
  forall a1 a2 b1 b2:Z, (a1 <= b1)%Z -> (a2 <= b2)%Z ->
        south_west (point a1 a2)(point b1 b2).

Inductive even : nat->Prop :=
  | O_even : even 0
  | plus_2_even : forall n:nat, even n -> even (S (S n)).

Inductive sorted (A:Set)(R:A->A->Prop) : list A -> Prop :=
  | sorted0 : sorted A R nil
  | sorted1 : forall x:A, sorted A R (cons x nil)
  | sorted2 :
      forall (x y:A)(l:list A),
        R x y ->
        sorted A R (cons y l)-> sorted A R (cons x (cons y l)).

Implicit Arguments sorted [A].
Hint Resolve sorted0 sorted1 sorted2 : sorted_base.

Require Export Relations.

Inductive clos_trans (A:Type)(R:relation A) : A->A->Prop :=
  | t_step : forall x y:A, R x y -> clos_trans A R x y
  | t_trans :
    forall x y z:A, clos_trans A R x y -> clos_trans A R y z ->
        clos_trans A R x z.

Theorem sorted_nat_123 : sorted le (1::2::3::nil).
Proof.
 auto with sorted_base arith.
Qed.

Theorem xy_ord :
 forall x y:nat, le x y -> sorted  le (x::y::nil).
Proof.
 auto with sorted_base.
Qed.

Theorem zero_cons_ord :
 forall l:list nat, sorted le l -> sorted le (cons 0 l).
Proof.
 induction 1; auto with sorted_base arith.
Qed.

Theorem sorted1_inv :
 forall (A:Set)(le:A->A->Prop)(x:A)(l:list A),
   sorted  le (cons x l)-> sorted  le l.
Proof.
 inversion 1; auto with sorted_base.
Qed.

Theorem sorted2_inv :
 forall (A:Set)(le:A->A->Prop)(x y:A)(l:list A),
   sorted  le (cons x (cons y l))-> le x y.
Proof.
 inversion 1; auto with sorted_base.
Qed.

Theorem not_sorted_132 :  ~ sorted le (1::3::2::nil).
Proof.
 intros H;assert (H1:sorted le (3::2::nil)).
 apply sorted1_inv with (1:= H).
 assert (H2 : 3<=2).
 apply sorted2_inv with (1:= H1).
 omega.
Qed.

Check True_ind.

Check False_ind.

Check and_ind.

Check or_ind.

Check ex_ind.

Check eq_ind.

Require Import JMeq.

Check JMeq_eq.

Check JMeq_ind.

Inductive ahtree : Set :=
  any_height : forall n:nat, htree nat n -> ahtree.

Theorem any_height_inj2 :
 forall (n1 n2:nat)(t1:htree nat n1)(t2:htree nat n2),
   any_height n1 t1 = any_height n2 t2 -> JMeq t1 t2.
Proof.
 intros n1 n2 t1 t2 H.
 injection H.
 intros H1 H2.
 dependent rewrite <- H1.
 simpl.
 Undo 4.
 change (match any_height n2 t2 with
        | any_height n t => JMeq t1 t
        end);
   rewrite <- H.
 auto.
Qed.

Require Import Bvector.
Require Import List.

Section vectors_and_lists.
 Variable A : Set.
 Fixpoint vector_to_list (n:nat)(v:vector A n){struct v}
  : list A :=
  match v with
  | Vnil => nil
  | Vcons a p tl => cons a (vector_to_list p tl)
  end.

 Fixpoint list_to_vector (l:list A) : vector A (length l) :=
   match l as x return vector A (length x) with
   | nil => Vnil A
   | cons a tl => Vcons A a (length tl)(list_to_vector tl)
   end.

 Theorem keep_length :
  forall (n:nat)(v:vector A n), length (vector_to_list n v) = n.
 Proof.
   intros n v; elim v; simpl; auto.
 Qed.

 Lemma Vconseq :
  forall (a:A)(n m:nat),
   n = m ->
   forall (v:vector A n)(w:vector A m),
     JMeq v w -> JMeq (Vcons A a n v)(Vcons A a m w).
 Proof.
  intros a n m Heq; rewrite Heq.
  intros v w HJeq.
  elim HJeq; reflexivity.
 Qed.

 Theorem vect_to_list_and_back :
  forall n (v:vector A n),
    JMeq v (list_to_vector (vector_to_list n v)).
 Proof.
  intros n v; elim v.
  simpl; auto.
  intros a n' v' HJeq.
  simpl.
  apply Vconseq.
  symmetry; apply keep_length.
  assumption.
 Qed.

End vectors_and_lists.

Theorem structured_intro_example1 : forall A B C:Prop, A/\B/\C->A.
Proof.
 intros A B C [Ha [Hb Hc]].
 auto.
Qed.

Theorem structured_intro_example2 : forall A B:Prop, A \/ B/\(B->A)->A.
Proof.
 intros A B [Ha | [Hb Hi]].
 auto.
 auto.
Qed.

Theorem sum_even : forall n p:nat, even n -> even p -> even (n+p).
Proof.
 intros n; elim n.
 auto.
 intros n' Hrec p Heven_Sn' Heven_p.
Restart.
 intros n p Heven_n; elim Heven_n.
 trivial.
 intros x Heven_x Hrec Heven_p; simpl.
 apply plus_2_even; auto.
Qed.

Check le_ind.

Theorem lt_le : forall n p:nat, n < p -> n <= p.
Proof.
 intros n p H; elim H; repeat constructor; assumption.
Qed.

Open Scope Z_scope.
Inductive Pfact : Z->Z->Prop :=
  Pfact0 : Pfact 0 1
| Pfact1 : forall n v:Z, n <> 0 -> Pfact (n-1) v -> Pfact n (n*v).

Theorem pfact3 : Pfact 3 6.
Proof.
 apply Pfact1 with (n := 3)(v := 2).
 discriminate.
 apply (Pfact1 2 1).
 discriminate.
 apply (Pfact1 1 1).
 discriminate.
 apply Pfact0.
Qed.

Theorem fact_def_pos : forall x y:Z, Pfact x y ->  0 <= x.
Proof.
 intros x y H; elim H.
 auto with zarith.
 intros n v Hneq0 HPfact Hrec.
 omega.
Qed.

Check Zwf_well_founded.

Check well_founded_ind.

Theorem Zle_Pfact : forall x:Z, 0 <= x -> exists y:Z, Pfact x y.
Proof.
 intros x0.
 elim x0 using (well_founded_ind (Zwf_well_founded 0)).
 intros x Hrec Hle.
  elim (Zle_lt_or_eq  _ _ Hle).
 2:intros Heq; rewrite <- Heq; exists 1; constructor.
 intro Hlt; elim (Hrec (x-1)).
 intros x1 Hfact; exists (x*x1); apply Pfact1; auto with zarith.
 unfold Zwf; omega.
 omega.
Qed.

Section little_semantics.
 Variables Var aExp bExp : Set.
 Inductive inst : Set :=
 | Skip : inst
 | Assign : Var->aExp->inst
 | Sequence : inst->inst->inst
 | WhileDo : bExp->inst->inst.

 Variables
  (state : Set)
  (update : state->Var->Z -> option state)
  (evalA : state->aExp -> option Z)
  (evalB : state->bExp -> option bool).

 Inductive exec : state->inst->state->Prop :=
 | execSkip : forall s:state, exec s Skip s
 | execAssign :
    forall (s s1:state)(v:Var)(n:Z)(a:aExp),
     evalA s a = Some n -> update s v n = Some s1 ->
     exec s (Assign v a) s1
 | execSequence :
    forall (s s1 s2:state)(i1 i2:inst),
     exec s i1 s1 -> exec s1 i2 s2 ->
     exec s (Sequence i1 i2) s2
 | execWhileFalse :
    forall (s:state)(i:inst)(e:bExp),
     evalB s e = Some false -> exec s (WhileDo e i) s
 | execWhileTrue :
    forall (s s1 s2:state)(i:inst)(e:bExp),
     evalB s e = Some true ->
     exec s i s1 ->
     exec s1 (WhileDo e i) s2 ->
     exec s (WhileDo e i) s2.

 Theorem HoareWhileRule :
  forall (P:state->Prop)(b:bExp)(i:inst)(s s':state),
    (forall s1 s2:state,
      P s1 -> evalB s1 b = Some true -> exec s1 i s2 -> P s2)->
    P s -> exec s (WhileDo b i) s' ->
    P s' /\ evalB s' b = Some false.
 Proof.
  intros P b i s s' H Hp Hexec; elim Hexec.
 Restart.
  intros P b i s s' H Hp Hexec; generalize H Hp; elim Hexec.
 Restart.
  intros P b i s s' H.
  cut
   (forall i':inst,
     exec s i' s' ->
     i' = WhileDo b i -> P s -> P s' /\ evalB s' b = Some false);
   eauto.
  intros i' Hexec; elim Hexec; try (intros; discriminate).
  intros s0 i0 e Heval Heq; injection Heq; intros H1 H2.
  match goal  with
  | id:(e = b) |- _ => rewrite <- id; auto
  end.
  intros;
   match goal with
   | id:(_ = _) |- _ => injection id; intros H' H''
   end.
    subst i0 b;eauto.
 Qed.

End little_semantics.

Open Scope nat_scope.

Inductive is_0_1 : nat->Prop :=
  is_0 : is_0_1 0 | is_1 : is_0_1 1.

Hint Resolve is_0 is_1 .

Lemma sqr_01 : forall x:nat, is_0_1 x -> is_0_1 (mult x x).
Proof.
  induction 1; simpl; auto.
Qed.

Theorem elim_example : forall n:nat, n <= 1 -> n*n <= 1.
Proof.
 intros n H.
 elim sqr_01.
 auto.
 auto.
 inversion_clear H; auto.
 inversion_clear H0; auto.
Qed.

Print even.

Section bad_proof_for_inversion.

 Theorem not_1_even : ~even 1.
 Proof.
  red; intros H; elim H.
 Abort.

End bad_proof_for_inversion.

Theorem not_even_1 : ~even 1.
Proof.
 unfold not; intros H.
 inversion H.
Qed.

Theorem plus_2_even_inv : forall n:nat, even (S (S n))-> even n.
Proof.
 intros n H; inversion H.
 assumption.
Qed.

Theorem not_even_1' : ~even 1.
Proof.
 intro H.
 generalize (refl_equal 1).
 pattern 1 at -2.
 elim H.
 discriminate.
 discriminate 3.
Qed.

Theorem plus_2_even_inv' : forall n:nat, even (S (S n))-> even n.
Proof.
 intros n H.
 generalize (refl_equal (S (S n))); pattern (S (S n)) at -2.
 elim H.
 intros H1; discriminate H1.
 intros n0 H'0 H' H'1.
 injection H'1; intros H'2; rewrite <- H'2; assumption.
Qed.


Require Import Domino List.
Import ListNotations.

Create HintDb disjoints_hints.

(** des dominos sont « disjoints » s'ils ne recouvrent pas de case en commun *)
Definition disjoints2_dominos (d1 d2:domino) :=
  match d1, d2 with
  | Hauteur c1, Hauteur c2 =>
              c1 <> c2 /\
      dessous c1 <> c2 /\
              c1 <> dessous c2 /\
      dessous c1 <> dessous c2
  | Largeur c1, Largeur c2 =>
              c1 <> c2 /\
       droite c1 <> c2 /\
              c1 <> droite c2 /\
       droite c1 <> droite c2
  | Hauteur c1, Largeur c2
  | Largeur c2, Hauteur c1 =>
              c1 <> c2 /\
              c1 <> droite c2 /\
      dessous c1 <> c2 /\
      dessous c1 <> droite c2
  end.

Infix "#" := (fun a b => disjoints2_dominos a b) (at level 32, left associativity).

(** déduction de la commutativité de [pose_domino] *)
Fixpoint disjoints_dominos_l (d : domino) (dl : list domino) :=
  match dl with
  | [] => True
  | h :: t => disjoints2_dominos d h /\ disjoints_dominos_l d t
  end.

Infix "##" := (fun a b => disjoints_dominos_l a b) (at level 33, left associativity).

Fixpoint disjoints_dominos_lo_aux (d : domino) (dl : list domino) :=
  match dl with
  | [] => True
  | h::t => (d # h /\ disjoints_dominos_lo_aux d t)
  end.

Fixpoint disjoints_dominos (dl : list domino) :=
  match dl with
  | [] => True
  | h::t => disjoints_dominos_lo_aux h t /\ disjoints_dominos t
  end.

(*****************************************************************************************)
(****************************** { Lemmes sur "disjoints" } *******************************)
(*****************************************************************************************)

Lemma simp_disjlo0 : disjoints_dominos [].
Proof.
  unfold disjoints_dominos.
  simpl.
  auto.
Qed.

#[local]
Hint Resolve simp_disjlo0 : disjoints_hints.

Lemma simp_disjlo0b : forall d, d ## [].
Proof.
  simpl.
  auto.
Qed.

#[local]
Hint Resolve simp_disjlo0b : disjoints_hints.

Lemma rw_util_disj : forall a d, d ## [a] <-> d # a.
Proof.
  split.
  - intros H.
    case d, a;
    split;
    try
     (destruct H;
      destruct H;
      assumption).
  - intros H.
    case d, a;
    cbv;
    auto.
Qed.

#[local]
Hint Resolve simp_disjlo0b : disjoints_hints.

Lemma simp_disjlo1 :
  forall d dl,
  disjoints_dominos (d :: dl) ->
  disjoints_dominos dl.
Proof.
  intros d dl.
  revert d.
  induction dl.
  - intros. apply simp_disjlo0.
  - intros d H.
    unfold disjoints_dominos in H.
    unfold disjoints_dominos.
    destruct H.
    destruct H0.
    split; assumption.
Qed.

#[local]
Hint Resolve simp_disjlo1 : disjoints_hints.

Lemma simp_disjlo2 :
  forall d dl,
  disjoints_dominos (d :: dl) ->
  d ## dl.
Proof.
  intros d dl H.
  destruct dl.
  { auto with disjoints_hints. }
  { destruct H.
    split;
    unfold disjoints_dominos_lo_aux in H;
    destruct H;
    assumption. }
Qed.

#[local]
Hint Resolve simp_disjlo2 : disjoints_hints.


Add LoadPath "$COQ_PROOFS" as Path.
Load unit_1_008_rewriting.

Theorem plus_1_neq_0_firsttry : forall n : nat,
  beq_nat (n + 1) 0 = false.
Proof.
  intros n. destruct n as [| n'].
  - reflexivity.
  - reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b.
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative: forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b.
  - destruct c.
    + reflexivity.
    + reflexivity.
  - destruct c.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb_commutative' : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b.
  { destruct c.
    { reflexivity. }
    { reflexivity. } }
  { destruct c.
    { reflexivity. }
    { reflexivity. } }
Qed.

Theorem andb3_exchange:
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b.
  - destruct c.
  {
    destruct d.
    - reflexivity.
    - reflexivity.
  }
  {
    destruct d.
    - reflexivity.
    - reflexivity.
  }
  - destruct c.
  {
    destruct d.
    - reflexivity.
    - reflexivity.
  }
  {
    destruct d.
    - reflexivity.
    - reflexivity.
  }
Qed.

Theorem plus_1_neq_0' : forall n : nat,
  beq_nat (n + 1) 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity. Qed.

Lemma minus_n_O : forall n : nat, n = n - 0.
Proof.
  intros [|n].
  {
    reflexivity.
  }
  {
    reflexivity.
  }
Qed.

Lemma n_plus_0_same_n : forall n : nat, 0 + n = n + 0.
Proof.
  intros.
  Admitted.

Lemma plus_n_O : forall n : nat, n = n + 0.
Proof.
  intros [|n].
  {
    reflexivity.
  }
  {
    simpl. rewrite <- n_plus_0_same_n. reflexivity.
  }
Qed.

Fixpoint beq_bool (n m: bool) : bool :=
  match n with
  | true => match m with
    | true => true
    | false => false
    end
  | false => match m with
    | true => false
    | false => true
    end
  end.

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

Theorem andb_true_elim2': forall b c: bool,
  andb b c = true -> c = true.
Proof.
  intros.
  destruct c.
  - rewrite <- H. simpl. reflexivity.
  - rewrite <- H. rewrite <- andb_commutative. reflexivity.
Qed.

Theorem andb_true_elim2'': forall b c: bool,
  andb b c = true -> c = true.
Proof.
  intros.
  destruct b.
  - rewrite <- H. simpl. reflexivity.
  - rewrite <- H. inversion H.
Qed.

Definition nandb (b1: bool) (b2: bool) : bool :=
  negb (andb b1 b2).

Theorem nandb__negb_andb : forall b1 b2 : bool,
    nandb b1 b2 = negb (andb b1 b2).
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Definition impb (b1: bool) (b2: bool) : bool :=
  orb (negb b1) b2.

Theorem impb_spec : forall b1 b2 : bool,
  impb b1 b2 = orb (negb b1) b2.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem impb_spec' : forall b1 b2 : bool,
  impb b1 b2 = orb (negb b1) b2.
Proof.
  intros. destruct b1.
  - destruct b2. reflexivity. reflexivity.
  - destruct b2. reflexivity. reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros. simpl. destruct n.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros. rewrite -> H. rewrite -> H. reflexivity.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros.
  destruct b.
  - simpl in H. rewrite -> H. reflexivity.
  - simpl in H. rewrite -> H. reflexivity.
Qed.


Require Import Coq.Init.Decimal.
Require Import Coq.ZArith.ZArith.

Inductive positive : Set :=
    xI : positive -> positive | xO : positive -> positive | xH : positive.

Declare Scope local_scope.
Open Scope  local_scope.

Notation "p ~ 1" := (xI p)
 (at level 7, left associativity, format "p '~' '1'") : local_scope.
Notation "p ~ 0" := (xO p)
 (at level 7, left associativity, format "p '~' '0'") : local_scope.

Definition succ :=
fix succ (x : positive) : positive :=
  match x with
  | (p~1) => ((succ p)~0)
  | (p~0) => (p~1)
  | xH => xH~0
  end.

Fixpoint add x y :=
  match x, y with
    | p~1, q~1 => (add_carry p q)~0
    | p~1, q~0 => (add p q)~1
    | p~1, xH => (succ p)~0
    | p~0, q~1 => (add p q)~1
    | p~0, q~0 => (add p q)~0
    | p~0, xH => p~1
    | xH, q~1 => (succ q)~0
    | xH, q~0 => q~1
    | xH, xH => xH~0
  end

with add_carry x y :=
  match x, y with
    | p~1, q~1 => (add_carry p q)~1
    | p~1, q~0 => (add_carry p q)~0
    | p~1, xH => (succ p)~1
    | p~0, q~1 => (add_carry p q)~0
    | p~0, q~0 => (add p q)~1
    | p~0, xH => (succ p)~0
    | xH, q~1 => (succ q)~1
    | xH, q~0 => (succ q)~0
    | xH, xH => xH~1
  end.

Definition mul :=
fix mul (x y : positive) {struct x} : positive :=
  match x with
  | (p~1) => add y (mul p y)~0
  | (p~0) => ((mul p y)~0)
  | xH => y
  end.

Inductive N :=
| O : N
| N_pos : positive -> N.

Definition N_succ(n:N) : N :=
  match n with
   | O => N_pos xH
   | N_pos p => N_pos (succ p)
  end.

Definition N_add(n m:N) : N :=
  match n, m with
   |O, m => m
   |n, O => n
   |N_pos p, N_pos q => N_pos (add p q)
  end.

Definition N_mul(n m:N) : N :=
  match n, m with
   |O, _ => O
   |_, O => O
   |N_pos p, N_pos q => N_pos (mul p q)
  end.

Infix "+" := N_add : local_scope.
Infix "*" := N_mul : local_scope.

Definition one := N_pos xH.
Definition two := N_pos xH~0.
Definition three := N_pos xH~1.
Definition four := N_pos xH~0~0.
Definition five := N_pos xH~0~1.
Definition six := N_pos xH~1~0.
Definition seven := N_pos xH~1~1.
Definition eight := N_pos xH~0~0~0.
Definition nine := N_pos xH~0~0~1.
Definition ten := N_pos xH~0~1~0.
Definition eleven := N_pos xH~0~1~1.
Definition twelve := N_pos xH~1~0~0.
Definition thirteen := N_pos xH~1~0~1.
Definition fourteen := N_pos xH~1~1~0.
Definition fifteen := N_pos xH~1~1~1.
Definition sixteen := N_pos xH~0~0~0~0.

Fixpoint N_uparse_rev (u:Decimal.uint) : N :=
match u with
  |Nil => O
  |D0 k => ten * N_uparse_rev k
  |D1 k => one + ten * N_uparse_rev k
  |D2 k => two + ten * N_uparse_rev k
  |D3 k => three + ten * N_uparse_rev k
  |D4 k => four + ten * N_uparse_rev k
  |D5 k => five + ten * N_uparse_rev k
  |D6 k => six + ten * N_uparse_rev k
  |D7 k => seven + ten * N_uparse_rev k
  |D8 k => eight + ten * N_uparse_rev k
  |D9 k => nine + ten * N_uparse_rev k
end.

Definition N_uparse (n:Decimal.uint) : N := N_uparse_rev (rev n).

Print Hexadecimal.uint.

Fixpoint N_uhparse_rev (u:Hexadecimal.uint) : N :=
match u with
  |Hexadecimal.Nil => O
  |Hexadecimal.D0 k => sixteen * N_uhparse_rev k
  |Hexadecimal.D1 k => one + sixteen * N_uhparse_rev k
  |Hexadecimal.D2 k => two + sixteen * N_uhparse_rev k
  |Hexadecimal.D3 k => three + sixteen * N_uhparse_rev k
  |Hexadecimal.D4 k => four + sixteen * N_uhparse_rev k
  |Hexadecimal.D5 k => five + sixteen * N_uhparse_rev k
  |Hexadecimal.D6 k => six + sixteen * N_uhparse_rev k
  |Hexadecimal.D7 k => seven + sixteen * N_uhparse_rev k
  |Hexadecimal.D8 k => eight + sixteen * N_uhparse_rev k
  |Hexadecimal.D9 k => nine + sixteen * N_uhparse_rev k
  |Hexadecimal.Da k => ten + sixteen * N_uhparse_rev k
  |Hexadecimal.Db k => eleven + sixteen * N_uhparse_rev k
  |Hexadecimal.Dc k => twelve + sixteen * N_uhparse_rev k
  |Hexadecimal.Dd k => thirteen + sixteen * N_uhparse_rev k
  |Hexadecimal.De k => fourteen + sixteen * N_uhparse_rev k
  |Hexadecimal.Df k => fifteen + sixteen * N_uhparse_rev k
end.

Definition N_uhparse (n:Hexadecimal.uint) : N := N_uhparse_rev (Hexadecimal.rev n).

Definition N_parse (n:Number.int) : option N :=
  match n with
   |Number.IntDecimal d => match d with
                     |Decimal.Pos u => Some (N_uparse u)
                     |Decimal.Neg u => None
                    end
   |Number.IntHexadecimal h => match h with
                     |Hexadecimal.Pos u => Some (N_uhparse u)
                     |Hexadecimal.Neg u => None
                    end
  end.

Fixpoint pos_for_pos(p:positive) : BinNums.positive :=
 match p with
 |xH => BinNums.xH
 |p~0 => BinNums.xO (pos_for_pos p)
 |p~1 => BinNums.xI (pos_for_pos p)
 end.

Definition N_print (n:N) : Z :=
 match n with
  | O => Z0
  | N_pos p => Zpos (pos_for_pos p)
 end.

Number Notation N N_parse N_print : local_scope.

Example q : ((14 * 13) + (12 * 11)) = 314.
compute.
trivial.
Defined.

Example q2 : ((fourteen * thirteen) + (twelve * eleven)) = 314.
compute.
trivial.
Defined.

Lemma add_one : forall n:positive, (succ n) = (add n xH).
destruct n.
all: simpl.
all: trivial.
Defined.

Lemma carry_one : forall n m:positive, (add_carry n m) = (add n (succ m)).
induction n.
all: induction m.
all: simpl.
all: try rewrite IHn.
all: try rewrite add_one.
all: try easy.
Defined.

Lemma ringer_pos : forall n m:positive, succ (add n m) = add n (succ m).
induction n.
all: induction m.
all: simpl.
all: try rewrite add_one.
all: try trivial.
3: rewrite <- IHn.
3: rewrite add_one.
3: trivial.
all: try rewrite <- add_one.
all: try rewrite carry_one.
trivial.
rewrite IHn.
trivial.
Defined.

Theorem ringer : forall n m:N, N_succ (n + m) = n + (N_succ m).
intros.
destruct n.
all: destruct m.
all: simpl.
all: try trivial.
all: try rewrite <- add_one.
trivial.
rewrite ringer_pos.
trivial.
Defined.


From mathcomp Require Import ssreflect.
Require Import Classical.
Require Import Coq.Logic.Description.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Sets.Finite_sets.
Require Import Coq.Sets.Finite_sets_facts.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Le.
Require Import Coq.Arith.Lt.

Definition is_max_nat := fun (E : (Ensemble nat)) (m : nat) => (In nat E m) /\ forall x : nat, (In nat E x) -> (x <= m)%nat.

Definition is_min_nat := fun (E : (Ensemble nat)) (m : nat) => (In nat E m) /\ forall x : nat, (In nat E x) -> (x >= m)%nat.

Lemma is_max_nat_unique : forall (E : (Ensemble nat)) (m1 m2 : nat), is_max_nat E m1 -> is_max_nat E m2 -> m1 = m2.
Proof.
move=> E m1 m2 H1 H2.
apply (le_antisym m1 m2).
apply (proj2 H2 m1 (proj1 H1)).
apply (proj2 H1 m2 (proj1 H2)).
Qed.

Lemma is_min_nat_unique : forall (E : (Ensemble nat)) (m1 m2 : nat), is_min_nat E m1 -> is_min_nat E m2 -> m1 = m2.
Proof.
move=> E m1 m2 H1 H2.
apply (le_antisym m1 m2).
apply (proj2 H1 m2 (proj1 H2)).
apply (proj2 H2 m1 (proj1 H1)).
Qed.

Lemma nat_cardinal : forall (n : nat) , cardinal nat (fun x : nat => (x < n)%nat) n.
Proof.
move=> n.
elim n.
suff: (fun x : nat => (x < 0)%nat) = (Empty_set nat).
move=> H1.
rewrite H1.
apply (card_empty nat).
apply (Extensionality_Ensembles nat (fun x : nat => (x < 0)%nat) (Empty_set nat)).
apply conj.
move=> m H1.
apply False_ind.
apply (le_not_lt 0 m).
apply (le_O_n m).
apply H1.
move=> m.
elim.
move=> n0 H1.
suff: (Add nat (fun x : nat => (x < n0)%nat) n0) = (fun x : nat => (x < S n0)%nat).
move=> H2.
rewrite - H2.
apply (card_add nat (fun x : nat => (x < n0)%nat) n0 H1 n0).
move=> H3.
apply (le_Sn_n n0 H3).
apply (Extensionality_Ensembles nat (Add nat (fun x : nat => (x < n0)%nat) n0) (fun x : nat => (x < S n0)%nat)).
apply conj.
move=> x.
elim.
move=> x0 H2.
apply (lt_trans x0 n0 (S n0)).
apply H2.
by [].
move=> x0 H2.
rewrite H2.
by [].
move=> x H2.
elim (le_lt_or_eq (S x) (S n0)).
move=> H3.
apply (Union_introl nat (fun x0 : nat => (x0 < n0)%nat) (Singleton nat n0) x).
apply (lt_S_n x n0 H3).
move=> H3.
apply (Union_intror nat (fun x0 : nat => (x0 < n0)%nat) (Singleton nat n0) x).
rewrite - (Nat.pred_succ n0).
rewrite - (Nat.pred_succ x).
rewrite H3.
by [].
apply H2.
Qed.

Lemma Finite_max_nat_exist : forall (U : Ensemble nat), (Finite nat U) -> (Inhabited nat U) -> exists m : nat, (is_max_nat U m).
Proof.
move=> U H1.
elim H1.
move=> H2.
apply False_ind.
elim H2.
move=> x H3.
elim H3.
move=> A H2 H3 x H4 H5.
move: H3.
elim H2.
exists x.
apply conj.
apply (Union_intror nat (Empty_set nat) (Singleton nat x) x).
apply (In_singleton nat x).
move=> x0.
elim.
move=> x1.
elim.
move=> x1.
elim.
by [].
move=> A0 H6 H7 x0 H8.
elim.
move=> x1.
move=> H9.
exists (max x x1).
apply conj.
apply (Nat.max_case_strong x x1).
move=> H10.
apply (Union_intror nat (Add nat A0 x0) (Singleton nat x) x).
apply (In_singleton nat x).
move=> H10.
apply (Union_introl nat (Add nat A0 x0) (Singleton nat x) x1).
apply (proj1 H9).
move=> x2.
elim.
move=> x3 H10.
apply (le_trans x3 x1 (Init.Nat.max x x1)).
apply (proj2 H9 x3 H10).
apply (Nat.le_max_r x x1).
move=> x3.
elim.
apply (Nat.le_max_l x x1).
exists x0.
apply (Union_intror nat A0 (Singleton nat x0) x0).
apply (In_singleton nat x0).
Qed.

Lemma min_nat_exist : forall (U : Ensemble nat), (Inhabited nat U) -> exists m : nat, (is_min_nat U m).
Proof.
suff: (forall (U : Ensemble nat), (Finite nat U) -> (Inhabited nat U) -> exists m : nat, (is_min_nat U m)).
move=> H1 U.
elim.
move=> n H2.
elim (classic (Inhabited nat (Intersection nat U (fun x:nat => (x < n)%nat)))).
move=> H3.
elim (H1 (Intersection nat U (fun x : nat => (x < n)%nat))).
move=> x H4.
exists x.
apply conj.
elim (proj1 H4).
move=> y H5 H6.
apply H5.
move=> y.
elim (le_or_lt n y).
move=> H5 H6.
apply (le_trans x n y).
apply (le_trans x (S x) n).
apply (le_S x).
apply (le_n x).
elim (proj1 H4).
move=> y0 H7.
apply.
apply H5.
move=> H5 H6.
apply ((proj2 H4) y).
apply (Intersection_intro nat U (fun x0 : nat => (x0 < n)%nat) y H6).
apply H5.
suff: (Finite nat (fun x : nat => (x < n)%nat)).
move=> H4.
apply (Intersection_preserves_finite nat (fun x : nat => (x < n)%nat) H4 U).
apply (cardinal_finite nat (fun x : nat => (x < n)%nat) n (nat_cardinal n)).
apply H3.
move=> H3.
exists n.
apply conj.
apply H2.
move=> x H4.
elim (le_or_lt n x).
apply.
move=> H5.
apply False_ind.
apply H3.
apply (Inhabited_intro nat (Intersection nat U (fun x0 : nat => (x0 < n)%nat)) x).
apply (Intersection_intro nat U (fun x0 : nat => (x0 < n)%nat) x H4 H5).
move=> U H1.
elim H1.
move=> H2.
apply False_ind.
elim H2.
move=> x H3.
elim H3.
move=> A H2 H3 x H4 H5.
suff: (Inhabited nat A -> exists m : nat, is_min_nat A m).
elim H2.
move=> H6.
exists x.
apply conj.
apply (Union_intror nat (Empty_set nat) (Singleton nat x) x).
apply (In_singleton nat x).
move=> x0.
elim.
move=> x1.
elim.
move=> x1.
elim.
by [].
move=> A0 H6 H7 x0 H8.
elim.
move=> x1 H9.
exists (min x x1).
apply conj.
apply (Nat.min_case_strong x x1).
move=> H10.
apply (Union_intror nat (Add nat A0 x0) (Singleton nat x) x).
apply (In_singleton nat x).
move=> H10.
apply (Union_introl nat (Add nat A0 x0) (Singleton nat x) x1).
apply (proj1 H9).
move=> x2.
elim.
move=> x3 H10.
apply (le_trans (min x x1) x1 x3).
apply (Nat.le_min_r x x1).
apply (proj2 H9 x3 H10).
move=> x3.
elim.
apply (Nat.le_min_l x x1).
exists x0.
apply (Union_intror nat A0 (Singleton nat x0) x0).
apply (In_singleton nat x0).
apply H3.
Qed.

Lemma min_nat_get : forall (U : Ensemble nat), (Inhabited nat U) -> {m : nat | is_min_nat U m}.
Proof.
move=> U H1.
apply (constructive_definite_description (fun (m : nat) => is_min_nat U m)).
apply (proj1 (unique_existence (fun (m : nat) => is_min_nat U m))).
apply conj.
elim (min_nat_exist U H1).
move=> n H2.
exists n.
apply H2.
unfold uniqueness.
apply (is_min_nat_unique U).
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) (z : natural) : natural :=
  mult y (Succ x).


Require Import SetoidClass.

(* Standard Setoid Instances *)

(* Pointwise equivalence of pairs *)

Definition prod_equiv {A} {B} { _ : Setoid A } { _ : Setoid B }
  := (fun (x : prod A B) (y : prod A B) => fst x == fst y /\ snd x == snd y).

Instance prod_equiv_Equiv A B ( s : Setoid A ) ( t : Setoid B )
  : Equivalence (prod_equiv (A:=A) (B:=B)).
unfold prod_equiv. split.
  (* Refl *) intuition.
  (* Sym *)  intros x y; destruct x; destruct y; intuition.
  (* Trans *) intros x y z; destruct x; destruct y; destruct z; simpl;
              split; intuition; etransitivity; eauto.
Qed.

Instance setoid_prod A B ( _ : Setoid A ) ( _ : Setoid B ) : Setoid (prod A B)
  := { equiv := prod_equiv }.

(* Pointwise equivalence of functions *)

Program Instance setoid_arrow S T (s : Setoid S) (t : Setoid T) : Setoid (T -> S).

(* Equivalence on option types *)

Definition option_equiv {A} {_ : Setoid A} : option A -> option A -> Prop :=
     fun x y =>
	match x,y with
	| None, None => True
	| Some x,Some y => x==y
	| _,_ => False end.
Instance eq_opt {A} {_ : Setoid A} : Equivalence option_equiv.
split;
compute -[equiv];
intros;
repeat match goal with | H : option _ |- _ => destruct H end;
intuition.
etransitivity; eauto.
Qed.

Instance setoid_option S (s : Setoid S) : Setoid (option S)
  := {equiv := option_equiv}.

Program Instance lift_setoid T : Setoid (T -> Prop).


(** * Rel: Properties of Relations *)

(** This short (and optional) chapter develops some basic definitions
    and a few theorems about binary relations in Coq.  The key
    definitions are repeated where they are actually used (in the
    \CHAPV2{Smallstep} chapter of _Programming Language Foundations_),
    so readers who are already comfortable with these ideas can safely
    skim or skip this chapter.  However, relations are also a good
    source of exercises for developing facility with Coq's basic
    reasoning facilities, so it may be useful to look at this material
    just after the [IndProp] chapter. *)

Set Warnings "-notation-overridden,-parsing".
Require Export IndProp.

(** A binary _relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- i.e., a proposition about
    pairs of elements of [X].  *)

Definition relation (X: Type) := X -> X -> Prop.

(** Confusingly, the Coq standard library hijacks the generic term
    "relation" for this specific instance of the idea. To maintain
    consistency with the library, we will do the same.  So, henceforth
    the Coq identifier [relation] will always refer to a binary
    relation between some set and itself, whereas the English word
    "relation" can refer either to the specific Coq concept or the
    more general concept of a relation between any number of possibly
    different sets.  The context of the discussion should always make
    clear which is meant. *)

(** An example relation on [nat] is [le], the less-than-or-equal-to
    relation, which we usually write [n1 <= n2]. *)

Print le.
(* ====> Inductive le (n : nat) : nat -> Prop :=
             le_n : n <= n
           | le_S : forall m : nat, n <= m -> n <= S m *)
Check le : nat -> nat -> Prop.
Check le : relation nat.
(** (Why did we write it this way instead of starting with [Inductive
    le : relation nat...]?  Because we wanted to put the first [nat]
    to the left of the [:], which makes Coq generate a somewhat nicer
    induction principle for reasoning about [<=].) *)

(* ################################################################# *)
(** * Basic Properties *)

(** As anyone knows who has taken an undergraduate discrete math
    course, there is a lot to be said about relations in general,
    including ways of classifying relations (as reflexive, transitive,
    etc.), theorems that can be proved generically about certain sorts
    of relations, constructions that build one relation from another,
    etc.  For example... *)

(* ----------------------------------------------------------------- *)
(** *** Partial Functions *)

(** A relation [R] on a set [X] is a _partial function_ if, for every
    [x], there is at most one [y] such that [R x y] -- i.e., [R x y1]
    and [R x y2] together imply [y1 = y2]. *)

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

(** For example, the [next_nat] relation defined earlier is a partial
    function. *)

Print next_nat.
(* ====> Inductive next_nat (n : nat) : nat -> Prop :=
           nn : next_nat n (S n) *)
Check next_nat : relation nat.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity.  Qed.

(** However, the [<=] relation on numbers is not a partial
    function.  (Assume, for a contradiction, that [<=] is a partial
    function.  But then, since [0 <= 0] and [0 <= 1], it follows that
    [0 = 1].  This is nonsense, so our assumption was
    contradictory.) *)

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  inversion Nonsense.   Qed.

(** **** Exercise: 2 stars, optional  *)
(** Show that the [total_relation] defined in earlier is not a partial
    function. *)

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

(** **** Exercise: 2 stars, optional  *)
(** Show that the [empty_relation] that we defined earlier is a
    partial function. *)

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

(* ----------------------------------------------------------------- *)
(** *** Reflexive Relations *)

(** A _reflexive_ relation on a set [X] is one for which every element
    of [X] is related to itself. *)

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Transitive Relations *)

(** A relation [R] is _transitive_ if [R a c] holds whenever [R a b]
    and [R b c] do. *)

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - (* le_n *) apply Hnm.
  - (* le_S *) apply le_S. apply IHHmo.  Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

(** **** Exercise: 2 stars, optional  *)
(** We can also prove [lt_trans] more laboriously by induction,
    without using [le_trans].  Do this.*)

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
    (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
(** Prove the same thing again by induction on [o]. *)

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  (* FILL IN HERE *) Admitted.
(** [] *)

(** The transitivity of [le], in turn, can be used to prove some facts
    that will be useful later (e.g., for the proof of antisymmetry
    below)... *)

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
  - apply le_S. apply le_n.
  - apply H.
Qed.

(** **** Exercise: 1 star, optional  *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (le_Sn_n_inf)  *)
(** Provide an informal proof of the following theorem:

    Theorem: For every [n], [~ (S n <= n)]

    A formal proof of this is an optional exercise below, but try
    writing an informal proof without doing the formal proof first.

    Proof:
    (* FILL IN HERE *)
    []
 *)

(** **** Exercise: 1 star, optional  *)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Reflexivity and transitivity are the main concepts we'll need for
    later chapters, but, for a bit of additional practice working with
    relations in Coq, let's look at a few other common ones... *)

(* ----------------------------------------------------------------- *)
(** *** Symmetric and Antisymmetric Relations *)

(** A relation [R] is _symmetric_ if [R a b] implies [R b a]. *)

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

(** **** Exercise: 2 stars, optional  *)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** A relation [R] is _antisymmetric_ if [R a b] and [R b a] together
    imply [a = b] -- that is, if the only "cycles" in [R] are trivial
    ones. *)

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

(** **** Exercise: 2 stars, optional  *)
Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Equivalence Relations *)

(** A relation is an _equivalence_ if it's reflexive, symmetric, and
    transitive.  *)

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(* ----------------------------------------------------------------- *)
(** *** Partial Orders and Preorders *)

(** A relation is a _partial order_ when it's reflexive,
    _anti_-symmetric, and transitive.  In the Coq standard library
    it's called just "order" for short. *)

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

(** A preorder is almost like a partial order, but doesn't have to be
    antisymmetric. *)

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - (* refl *) apply le_reflexive.
    - split.
      + (* antisym *) apply le_antisymmetric.
      + (* transitive. *) apply le_trans.  Qed.

(* ################################################################# *)
(** * Reflexive, Transitive Closure *)

(** The _reflexive, transitive closure_ of a relation [R] is the
    smallest relation that contains [R] and that is both reflexive and
    transitive.  Formally, it is defined like this in the Relations
    module of the Coq standard library: *)

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

(** For example, the reflexive and transitive closure of the
    [next_nat] relation coincides with the [le] relation. *)

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
  - (* -> *)
    intro H. induction H.
    + (* le_n *) apply rt_refl.
    + (* le_S *)
      apply rt_trans with m. apply IHle. apply rt_step.
      apply nn.
  - (* <- *)
    intro H. induction H.
    + (* rt_step *) inversion H. apply le_S. apply le_n.
    + (* rt_refl *) apply le_n.
    + (* rt_trans *)
      apply le_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2. Qed.

(** The above definition of reflexive, transitive closure is natural:
    it says, explicitly, that the reflexive and transitive closure of
    [R] is the least relation that includes [R] and that is closed
    under rules of reflexivity and transitivity.  But it turns out
    that this definition is not very convenient for doing proofs,
    since the "nondeterminism" of the [rt_trans] rule can sometimes
    lead to tricky inductions.  Here is a more useful definition: *)

Inductive clos_refl_trans_1n {A : Type}
                             (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A) :
      R x y -> clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.

(** Our new definition of reflexive, transitive closure "bundles"
    the [rt_step] and [rt_trans] rules into the single rule step.
    The left-hand premise of this step is a single use of [R],
    leading to a much simpler induction principle.

    Before we go on, we should check that the two definitions do
    indeed define the same relation...

    First, we prove two lemmas showing that [clos_refl_trans_1n] mimics
    the behavior of the two "missing" [clos_refl_trans]
    constructors.  *)

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
  intros X R x y H.
  apply rt1n_trans with y. apply H. apply rt1n_refl.   Qed.

(** **** Exercise: 2 stars, optional (rsc_trans)  *)
Lemma rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      clos_refl_trans_1n R x y  ->
      clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Then we use these facts to prove that the two definitions of
    reflexive, transitive closure do indeed define the same
    relation. *)

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide)  *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** $Date: 2017-04-26 17:33:43 -0400 (Wed, 26 Apr 2017) $ *)


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * kat_completeness: completeness of Kleene algebra with tests *)

(** We closely follow Dexter Kozen and Frederick Smith' proof:
   Kleene algebra with tests: Completeness and decidability.
   In Proc. CSL'96, vol. 1258 of LNCS, pages 244-259, 1996. Springer-Verlag.

   The only difference is that we do the proof directly for _typed_ KAT.

   (We cannot easily exploit an untyping theorem, like we do in the
   case of KA: although the untyping theorem holds for KAT, it
   actually follows from typed completeness - at least we did not find
   an alternative way of proving it)

   The proof can be summarised as follows:
   one exhibits a function [hat: gregex n m -> gregex n m] such that:
   1. forall x, KAT |- hat x == x
   2. forall x, G(hat x) == R(hat x), where
      . G(y) is the typed guarded strings interpretation of y
      . R(y) is the language interpretation of y, seen as a regular expression
   (the concrete coercions will be specified later on)

   From these properties, it follows that for all x,y: gregex n m, we have
           G(x) == G(y)
 =>    G(hat x) == G(hat y)          (1, and G is a model)
 =>    R(hat x) == R(hat x)          (2)
 => KA |- hat x == hat y             (KA completeness)
 => KA |- hat x == hat y : n -> m    (untyping theorem for KA)
 => KAT|- hat x == hat y : n -> m    (KA theorems hold in KAT)
 => KAT|-     x == y : n -> m        (1, and transitivity)

   (the converse is immediate, G being a model) *)

Require Import denum lset sums normalisation.
Require Import kat ka_completeness untyping.
Require Import regex gregex lsyntax syntax lang glang boolean atoms.
Set Implicit Arguments.

(** abbreviations: [R] is the module about regular expressions, while
   [G] is the module about generalised regular expressions *)
Module R := regex.
Module G := gregex.

Section s.
Notation Sigma := positive.
Variable pred: nat.
Variables src tgt: Sigma -> positive.
Notation gregex := (gregex_kat_ops pred src tgt).
Notation Atom := (ord (pow2 pred)).
Notation gword := (trace Atom).
Notation glang := (tglang_kat_ops pred src tgt).
Notation g_atom n a := (@g_prd pred src tgt n (@atom pred a)).
Notation test := (lsyntax.expr (ord pred)).

(** * 1. Definition of the [hat] function, and correctness *)

(** ** externally guarded terms *)

(** the hat function is defined by induction on the structure of its
   argument, but it actually produces formal sums of "externally
   guarded terms", defined by the following inductive *)

Inductive guard: positive -> positive -> Type :=
| g_pred: forall {n} (a: Atom), guard n n
| g_elem: forall n m (a: Atom) (e: gregex n m) (b: Atom), guard n m.
Notation guards n m := (list (guard n m)).

(** externally guarded terms, and sums of such terms can be converted
   back to [gregex] in the obvious way *)
Definition geval n m (x: guard n m) :=
  match x with
    | @g_pred n a => g_atom n a
    | @g_elem n m a e b => g_atom n a * e * g_atom m b
  end.
Notation teval := (sup (@geval _ _)).

(** ** inductive cases for the [hat] function *)

(** *** predicates *)

(** a predicate is mapped to the set of atoms under which it is satisfied *)
Definition g_prd' n p: guards n n  :=
  map g_pred (filter (fun a => lsyntax.eval (set.mem a) p) (seq (pow2 pred))).

Lemma teval_prd n (p: tst n): teval (g_prd' n p) == inj p.
Proof.
  unfold g_prd'. rewrite sup_map. unfold geval.
  setoid_rewrite <-inj_sup. apply inj_weq.
  symmetry. apply decomp_expr.
Qed.

(** *** unit *)

(** accordingly, [1] is simply mapped to the set of all atoms *)
Definition g_one' n := g_prd' n (@lsyntax.e_top _).

Lemma teval_one n: teval (g_one' n) == 1.
Proof. unfold g_one'. rewrite teval_prd. apply inj_top. Qed.

(** *** letters *)

(** a Kleene variable [i] is mapped to the sum of all [f*i*g], for f,g
   arbitrary atoms *)

Definition g_var' i := \sup_(f<_) \sup_(g<_) [g_elem f (g_var i) g]%list.

Lemma sum_atoms n: \sup_(i<pow2 pred) g_atom n i == 1.
Proof.
  rewrite <- teval_one. unfold g_one', g_prd'. rewrite sup_map.
  apply sup_weq. reflexivity.
  induction seq. reflexivity. now apply (cup_weq [_] [_])%list.
Qed.

Lemma teval_var i: teval (g_var' i) == g_var i.
Proof.
  unfold g_var'. rewrite sup_sup. setoid_rewrite sup_sup.
  setoid_rewrite sup_singleton. unfold geval.
  setoid_rewrite <-dotxsum. setoid_rewrite <-dotA. rewrite <-dotsumx.
  setoid_rewrite sum_atoms. ra.
Qed.

(** *** composition *)

(** composition is defined by a kind of coalesced product: we take all
   products such that the post-guard of the former element coincides
   with the pre-guard of the latter *)

(** [g_dot1 x y] tries to compose two externally guarded terms *)
Definition g_dot1 n m (x: guard n m): forall p, guard m p -> guards n p  :=
  match x with
    | g_pred a => fun p y =>
      match y with
        | g_pred b       => if eqb a b then [g_pred a] else []
        | g_elem b e c => if eqb a b then [g_elem b e c] else []
      end
    | g_elem a e b => fun p y =>
      match y with
        | g_pred c => fun e => if eqb b c then [g_elem a e b] else []
        | g_elem c f d => fun e => if eqb b c then [g_elem a (e*g_atom _ b*f) d] else []
      end e
  end%list.

(** [g_dot' h k] does the composition of two lists of externally guarded terms *)
Definition g_dot' n m p (h: guards n m) (k: guards m p) :=
  \sup_(x\in h) \sup_(y\in k) g_dot1 x y.

(** the correctness of this construction relies on the following two lemma *)
Lemma empty_atom_dot n a b: a<>b -> g_atom n a * g_atom n b == 0.
Proof.
  intros. setoid_rewrite <-inj_cap.
  rewrite (empty_atom_cap H). apply inj_bot.
Qed.

Lemma idem_atom_dot n a: g_atom n a * g_atom n a == g_atom n a.
Proof. setoid_rewrite <-inj_cap. now rewrite capI. Qed.

(** correctness of [g_dot1] *)
Lemma geval_dot n m p (x: guard n m) (y: guard m p): teval (g_dot1 x y) == geval x * geval y.
Proof.
  destruct x as [? a|? ? a e b]; destruct y as [? c|? ? c f d]; unfold g_dot1;
    (case eqb_spec; [intros <-|intro E]); unfold geval; rewrite ?sup_singleton; unfold sup.
  - now rewrite idem_atom_dot.
  - symmetry. apply (empty_atom_dot _ E).
  - now rewrite 2dotA, idem_atom_dot.
  - rewrite 2dotA, (empty_atom_dot _ E). ra.
  - now rewrite <-3dotA, idem_atom_dot.
  - rewrite <-2dotA, (empty_atom_dot _ E). ra.
  - transitivity (g_atom _ a*(e*(g_atom _ b*g_atom _ b)*f)*g_atom _ d). 2:ra.
    now rewrite idem_atom_dot.
  - transitivity (g_atom _ a*(e*(g_atom _ b*g_atom _ c)*f)*g_atom _ d). 2:ra.
    rewrite (empty_atom_dot _ E). ra.
Qed.

(** correctness of [g_dot'] *)
Lemma teval_dot n m p (x: guards n m) (y: guards m p):
  teval (g_dot' x y) == teval x * teval y.
Proof.
  unfold g_dot'. rewrite sup_sup. setoid_rewrite sup_sup.
  setoid_rewrite geval_dot.
  rewrite dotsumx. now setoid_rewrite dotxsum.
Qed.

(** *** Kleene star *)

(** Kleene star is defined by induction on the list of externally
   guarded terms, see Kozen and Smith' paper *)

Definition fst n m (x: guard n m) := match x with g_pred a | g_elem a _ _ => a end.
Definition lst n m (x: guard n m) := match x with g_pred a | g_elem _ _ a => a end.
Definition g_inner_dot n m (x: guard n m): forall p, guard m p -> gregex n p :=
  match x with
    | g_pred a => fun p y =>
      match y with
        | g_pred b       => 0
        | g_elem b e c => if eqb a b \cap eqb a c then e else 0
      end
    | g_elem a e b => fun p y =>
      match y with
        | g_pred c => fun e => if eqb a b \cap eqb b c  then e else 0
        | g_elem c f d => fun e => if eqb b c \cap eqb a d then e*g_atom _ b*f else 0
      end e
  end.

Definition xitr n m (r: guard n m) q' :=
  let rq' := g_dot' [r] q' in
  let a := fst r in
  let p := sup (@g_inner_dot _ _ r _) q' in
    g_dot' ([g_elem a (p*(g_atom _ a*p)^*) a]++g_one' _) rq'.

Fixpoint g_str' n (x: guards n n) :=
  match x with
    | [] => g_one' _
    | r::q =>
      let q' := g_str' q in
      q' ++ g_dot' q' (xitr r q')
  end.

(** the correctness of this construction is substantially more involved than for the other ones *)

Lemma geval_fst n m (r: guard n m): geval r == g_atom _ (fst r) * geval r.
Proof.
  destruct r.
   simpl fst; unfold geval. now rewrite idem_atom_dot.
   simpl fst; unfold geval. now rewrite 2dotA, idem_atom_dot.
Qed.

Lemma geval_lst n m (r: guard n m): geval r == geval r * g_atom _ (lst r).
Proof.
  destruct r.
   simpl fst; unfold geval. now rewrite idem_atom_dot.
   simpl fst; unfold geval. now rewrite <-3dotA, idem_atom_dot.
Qed.

Definition dirac n m: gregex n m.
case (eqb_pos_spec n m). intros <-. exact 1. intros _. exact 0.
Defined.

Lemma dirac_refl n: dirac n n = 1.
Proof.
  unfold dirac. case eqb_pos_spec. 2: congruence.
  intro. now rewrite cmp_eq_rect_eq.
Qed.

Lemma teval_inner_dot n m p (x: guard n m) (y: guard m p):
  dirac n p + g_atom _ (fst x) * g_inner_dot x y * g_atom _ (fst x) ==
  dirac n p + ofbool (eqb (fst x) (lst y)) * geval x * geval y.
Proof.
  unfold g_inner_dot.
  revert p y. destruct x as [n a|n m a e b]; destruct y as [p c|p q c f d];
    simpl fst; simpl lst; simpl geval.
   rewrite dirac_refl. case eqb. 2: ra. ra_normalise.
    setoid_rewrite <-inj_cap. rewrite <-inj_top, <-inj_cup. apply inj_weq. lattice.
   case eqb_spec; intro E. subst. case eqb_spec; intro E'. subst.
    simpl. ra_normalise. now rewrite idem_atom_dot.
    ra.
    simpl. ra_normalise. rewrite <-(dotA _ (g_atom p a)).
    rewrite empty_atom_dot by assumption. ra.
   case eqb_spec; intro E. subst. case eqb_spec; intro E'. subst.
    simpl. ra_normalise. now rewrite <-3dotA, idem_atom_dot.
    ra.
    simpl. case eqb_spec; intro E'. subst. ra_normalise.
     rewrite <-dotA. rewrite empty_atom_dot by congruence. ra.
     ra.
   case eqb_spec; intro E. subst. case eqb_spec; intro E'. subst.
    simpl. ra_normalise. now rewrite <-(dotA _ (g_atom p c) (g_atom p c)), idem_atom_dot.
    ra.
    simpl. case eqb_spec; intro E'. subst.
     ra_normalise. rewrite <-(dotA _ (g_atom p b) (g_atom p c)), empty_atom_dot by assumption.
      ra.
     ra.
Qed.

Lemma teval_xitr n m (r: guard n m) q: teval (xitr r q) == (geval r * teval q)^+.
Proof.
  unfold xitr.
  rewrite 2teval_dot, sup_app, 2sup_singleton, teval_one.
  symmetry. rewrite itr_str_l. rewrite (geval_fst r) at 2.
  rewrite <-(dotA (g_atom _ _)), str_dot.
  apply dot_weq. 2: reflexivity.
  rewrite cupC. unfold geval at 3. rewrite dotA. rewrite <-itr_str_l.
  rewrite itr_aea by now rewrite idem_atom_dot. rewrite <-str_itr. apply str_weq1.
  induction q as [|e q IH]. ra.
  simpl (sup _ _).
  rewrite 2dotxpls, 2dotplsx. rewrite <-(cupI 1), 2cupA, 2comm4. apply cup_weq.
  2: assumption. clear IH.
  rewrite <-dirac_refl. rewrite teval_inner_dot.
  case eqb_spec; intro E.
   setoid_rewrite dot1x. rewrite E. now rewrite <-dotA, <-geval_lst.
  rewrite (geval_lst e), <-2dotA, empty_atom_dot by congruence. ra.
Qed.

Lemma teval_str n (x: guards n n): teval (g_str' x) == teval x ^*.
Proof.
  induction x as [|r q IH]; simpl g_str'.
  rewrite teval_one. symmetry. apply str0.
  simpl (sup _ _). setoid_rewrite (cupC (geval r)). rewrite str_pls.
  rewrite sup_app, teval_dot, teval_xitr, IH. rewrite (str_itr (_*_)). ra.
Qed.

(** ** summing up the constructions, by induction *)

Fixpoint hat n m (e: gregex n m): guards n m :=
  match e with
    | g_zer _ _ _ => []
    | g_prd _ _ p => g_prd' _ p
    | g_pls e f => hat e \cup hat f
    | g_dot e f => g_dot' (hat e) (hat f)
    | g_itr e => g_dot' (hat e) (g_str' (hat e))
    | g_var i => g_var' i
  end.

Theorem teval_hat n m (e: gregex n m): teval (hat e) == e.
Proof.
  induction e; simpl hat.
   reflexivity.
   apply teval_prd.
   apply teval_var.
   setoid_rewrite sup_app. now apply cup_weq.
   rewrite teval_dot. now apply dot_weq.
   rewrite teval_dot, teval_str, <-itr_str_l. now apply itr_weq.
Qed.

(** * Relationship between generalised regular expressions and (plain) regular expressions *)

(** ** extended alphabet *)

(** a letter in the extended alphabet is either a Kleene variable, a
   positive predicate variable, or a negative one. We moreover need to
   record the type of the corresponding test in the two latter cases *)

Inductive letter :=
| l_pos (n: positive) (p: ord pred)
| l_neg (n: positive) (p: ord pred)
| l_var (i: Sigma).

(** the above type can be retracted into positives: this saves us from
   proving KA completeness on an arbitrary alphabet (this would
   require a lot of polymorphic definitions) *)

Definition lp (l: letter): positive :=
  match l with
    | l_pos n x => mk_sum (inl (mk_sum (inl (mk_pair (n, mk_ord x)))))
    | l_neg n x => mk_sum (inl (mk_sum (inr (mk_pair (n, mk_ord x)))))
    | l_var i   => mk_sum (inr i)
  end.
Definition pl (p: positive): letter :=
  match get_sum p with
    | inl p => match get_sum p with
                 | inl p => let '(n,p) := get_pair p in
                   match get_ord _ p with None => l_var 1 | Some x => l_pos n x end
                 | inr p => let '(n,p) := get_pair p in
                   match get_ord _ p with None => l_var 1 | Some x => l_neg n x end
               end
    | inr i => l_var i
  end.
Lemma plp l: pl (lp l) = l.
Proof. destruct l; unfold pl, lp; now rewrite !get_mk_sum, ?get_mk_pair, ?get_mk_ord. Qed.

(** the retraction into positives also equips [letter] with a
   [cmpType] structure *)
Definition compare_letter (a b: letter) := cmp (lp a) (lp b).
Lemma compare_letter_spec a b: compare_spec (a=b) (compare_letter a b).
Proof.
  unfold compare_letter. case cmp_spec; intro E; constructor.
  now rewrite <-(plp a), <-(plp b), E. congruence. congruence.
Qed.
Canonical Structure cmp_letter := mk_simple_cmp _ compare_letter_spec.

(** typing extended letters:
   - predicate letters come with their type
   - Kleene letters use the typing environment *)
Definition src' l :=
  match l with
    | l_pos n _ | l_neg n _ => n
    | l_var i => src i
  end.

Definition tgt' l :=
  match l with
    | l_pos n _ | l_neg n _ => n
    | l_var i => tgt i
  end.

(** ** regular expressions on the extended alphabet *)

(** [expr3] is intuitively the set of typed regular expressions on [letter],
   while [uexpr3] is the set of untyped regular expressions on [letter]

   we use [uexpr3] rather than [regex] to use the untyping theorem
   (which we proved on generic expressions rather than regular
   expressions).

   we now define several maps between these representations:
   - [o : gregex n m -> expr3 n m] (injective)
   - [o': expr3 n m -> gregex]     (partial, since expr3 has to many operations)
   - [v : expr3 n m -> regex]      (type-erasing, partial for the same reasons)
   - [w : regex -> uexpr3]         (injective, even if we do not prove it)
   - [u : expr3 n m -> uexpr3]     (type-erasing, actually [untyping.erase])

   and we prove the following properties:
   - [o'o = id]                 (yielding injectivity of [o])
   - [wvo = uo]                 (allowing us to use the untyping theorem)

*)
Notation expr3 n m := (expr_ops src' tgt' BKA n m).
Notation uexpr3 := (expr_ops (fun _ => xH) (fun _ => xH) BKA xH xH).

(** ** [o: gregex n m -> expr3 n m] *)

Section n.
Variable n: positive.
Import lsyntax.
(** we need to push negation to leaves in Boolean expressions *)
Fixpoint o_pred (x: test): expr3 n n :=
  match x with
    | e_bot => 0
    | e_top => 1
    | e_cup x y => o_pred x + o_pred y
    | e_cap x y => o_pred x * o_pred y
    | e_neg x => o_npred x
    | e_var a => syntax.e_var (l_pos n a)
  end
with o_npred (x: test): expr3 n n :=
  match x with
    | e_bot => 1
    | e_top => 0
    | e_cup x y => o_npred x * o_npred y
    | e_cap x y => o_npred x + o_npred y
    | e_neg x => o_pred x
    | e_var a => syntax.e_var (l_neg n a)
  end.
Import syntax.
Lemma o_pred_level x: e_level (o_pred x) << BKA
  with o_npred_level x: e_level (o_npred x) << BKA.
Proof.
  destruct x; simpl o_pred; simpl e_level; rewrite ?merge_spec; intuition.
  destruct x; simpl o_npred; simpl e_level; rewrite ?merge_spec; intuition.
Qed.
End n.

Fixpoint o n m (e: gregex n m): expr3 n m:=
  match e with
    | g_zer _ _ _ => 0
    | g_prd _ _ p => o_pred _ p
    | g_pls e f => o e + o f
    | g_dot e f => o e * o f
    | g_itr e => o e ^+
    | g_var j => e_var (l_var j)
  end.

Lemma o_sup n m I J (f: I -> gregex n m): o (sup f J) = \sup_(i\in J) (o (f i)).
Proof. apply f_sup_eq; now f_equal. Qed.

Lemma o_level n m (e: gregex n m): e_level (o e) << BKA.
Proof.
  pose proof o_pred_level.
  induction e; simpl o; simpl e_level; rewrite ?merge_spec; intuition.
Qed.

(** ** [o': expr3 n m -> gregex n m] *)

Definition o': forall n m, expr3 n m -> gregex n m :=
  @eval _ src' tgt' (gregex_monoid_ops pred src tgt) id
  (fun l => match l return gregex (src' l) (tgt' l) with
              | l_pos n p => g_prd _ _ (lsyntax.e_var p)
              | l_neg n p => g_prd _ _ (! lsyntax.e_var p)
              | l_var i => g_var i
            end).

Lemma o'o_pred: forall n (a: test), o' (o_pred n a) == g_prd _ _ a
 with o'o_npred: forall n (a: test), o' (o_npred n a) == g_prd _ _ (!a).
Proof.
  destruct a.
   symmetry. apply inj_bot.
   symmetry. apply inj_top.
   setoid_rewrite inj_cup. apply cup_weq; apply o'o_pred.
   setoid_rewrite inj_cap. apply dot_weq; apply o'o_pred.
   apply o'o_npred.
   reflexivity.
  destruct a.
   symmetry. etransitivity. apply inj_weq. apply negbot. apply inj_top.
   symmetry. etransitivity. apply inj_weq. apply negtop. apply inj_bot.
   etransitivity. 2: apply inj_weq; symmetry; apply negcup. rewrite inj_cap.
    apply dot_weq; apply o'o_npred.
   etransitivity. 2: apply inj_weq; symmetry; apply negcap. rewrite inj_cup.
    apply cup_weq; apply o'o_npred.
   etransitivity. 2: apply inj_weq; symmetry; apply negneg. apply o'o_pred.
   reflexivity.
Qed.

(** [o] admits [o'] as left-inverse *)
Lemma o'o: forall n m (e: gregex n m), o' (o e) == e.
Proof.
  induction e; simpl o; simpl o'.
   reflexivity.
   apply o'o_pred.
   reflexivity.
   now apply cup_weq.
   now apply dot_weq.
   now apply itr_weq.
Qed.

Lemma o'_weq n m: Proper (weq ==> weq) (@o' n m).
Proof. intros ? ? H. apply (H (gregex_monoid_ops _ _ _) _ id). Qed.

(** so that [o] is injective *)
Corollary o_inj n m (e f: gregex n m): o e == o f -> e == f.
Proof. intro H. apply o'_weq in H. revert H. now rewrite 2o'o. Qed.

(** ** [expr3 -v-> regex -w-> uexpr3] *)

Definition v: forall n m, expr3 n m -> regex :=
  eval (f':=fun _ => regex_tt) (fun l => r_var (lp l)).

Definition w (e: regex): uexpr3 :=
  eval (X:=expr_ops _ _ BKA) (f':=fun _ => xH) (fun p => e_var (pl p)) (to_expr e).

Lemma wv_u n m (e: expr3 n m): e_level e << BKA -> w (v e) == erase BKA e.
Proof.
  unfold w.
  induction e; simpl e_level; intro Hl; try discriminate_levels;
    try (first [reflexivity|apply dot_weq|apply cup_weq|apply str_weq]);
      try (first [apply IHe1|apply IHe2|apply IHe]; solve_lower').
  symmetry. simpl (erase _ _). rewrite itr_str_l, <-IHe. reflexivity. solve_lower'.
  simpl. now rewrite plp.
Qed.

(** key lemma to be able to use the untyping theorem *)
Lemma wvo_uo n m (e: gregex n m): w (v (o e)) == erase BKA (o e).
Proof. apply wv_u, o_level. Qed. (* note: on doit pouvoir prouver une égalité forte *)

Lemma w_weq: Proper (weq ==> weq) w.
Proof. intros ? ? H. apply (H (expr_ops _ _ _) _ (fun _ => xH)). Qed.

Lemma v_sup n m I J (f: I -> expr3 n m): v (sup f J) = \sup_(i\in J) (v (f i)).
Proof. apply f_sup_eq; now f_equal. Qed.

(** * From guarded string languages to languages on the extended alphabet *)
(** i.e., we define a coercion from [glang] [lang] *)

Notation word := (list positive).
Notation lang := (lang_ops positive lang_tt lang_tt).

(** converting an atom into a word of the extended alphabet.
   this word has length [pred]: each predicate variable appears
   exactly once, with its assigned truth value *)
Definition atom_to_word n (a: Atom) :=
  map (fun i => if set.mem a i then lp (l_pos n i) else lp (l_neg n i)) (seq pred).

(** converting an guarded string into a word of the extended alphabet
   the resulting word has length [pred+(1+pred)*n], where [n] is the
   length of the guarded string *)
Fixpoint gword_to_word n (w: gword) :=
  match w with
    | tnil a => atom_to_word n a
    | tcons a i w => atom_to_word n a ++ lp (l_var i) :: gword_to_word (tgt i) w
  end.

(** we convert a guarded string language by converting its words *)
Definition gl n m (G: glang n m): lang :=
  fun w => exists g, w = gword_to_word n g /\ proj1_sig G g.

Instance gl_leq n m: Proper (leq ==> leq) (@gl n m).
Proof. intros G G' H w [t [? Hw]]. exists t. split. assumption. apply H, Hw. Qed.
Instance gl_weq n m: Proper (weq ==> weq) (@gl n m) := op_leq_weq_1.

(** auxiliary definition for the following auxiliary lemma:
   [gword_to_word' w] return the suffix of the word corresponding to
   [w], where the initial atom has been omitted *)
Definition gword_to_word' (w: gword) :=
  match w with
    | tnil a => []
    | tcons a i w => lp (l_var i) :: gword_to_word (tgt i) w
  end.

Lemma gword_to_word_cut n w:
  gword_to_word n w = atom_to_word n (thead w) ++ gword_to_word' w.
Proof. destruct w. apply app_nil_end. reflexivity. Qed.

Lemma gword_tapp: forall x y z, tapp x y z ->
  forall n, gword_to_word n z = gword_to_word n x ++ gword_to_word' y.
Proof.
  induction 1; simpl; intros n.
   apply app_nil_end.
   reflexivity.
   now rewrite IHtapp, app_ass.
Qed.

(** * 2. G (hat e) = R (hat e)

   (more formally, gl (G (hat e)) == R (v (o (hat e))))

  *)

Notation R := R.lang.
Notation G := G.lang.

Notation latom n a := (eq (atom_to_word n a): lang).

(** regular language corresponding to an atom *)

Lemma R_lang_atom n a: R (v (o (g_atom n a))) == latom n a.
Proof.
  simpl o. unfold atom, atom_to_word.
  induction (seq pred). apply R.lang_1. simpl (sup _ _).
  setoid_rewrite R.lang_dot. setoid_rewrite (eq_app_dot _ [_]). apply dot_weq.
  case set.mem; apply R.lang_var. assumption.
Qed.

(** ** properties of [gl]  *)

(** [gl] is a semilattice morphism (note that it does not preserve products/iterations) *)

Lemma gl_bot n m: @gl n m bot == bot.
Proof. split. intros [? [? []]]. intros []. Qed.

Lemma gl_cup n m (e f: glang n m): gl (e \cup f) == gl e \cup gl f.
Proof.
  split.
   intros [w [-> [H|H]]]; [left|right]; exists w; split; auto.
   intros [H|H]; destruct H as [w [-> H]]; exists w; split; trivial; (now left) || (now right).
Qed.

Lemma gl_sup n m I J (f: I -> glang n m): gl (sup f J) == \sup_(i\in J) gl (f i).
Proof. apply f_sup_weq. apply gl_bot. apply gl_cup. Qed.

(** [gl] maps atoms to atoms *)

Lemma gl_atom n a: gl (tatom n a) == latom n a.
Proof.
  intro w; split.
  intros [g [-> <-]]. reflexivity.
  intros <-. eexists. split. 2: reflexivity. reflexivity.
Qed.

(** image of single letter traces under [gl] *)
Lemma gl_single' a i b:
  gl (tsingle' a i b) ==
  eq (atom_to_word (src i) a++[lp (l_var i)]++atom_to_word (tgt i) b).
Proof.
  intro w; split.
  intros [g [-> <-]]. reflexivity.
  intros <-. eexists. split. 2: reflexivity. reflexivity.
Qed.

(** key auxiliary lemma for composition: we need to use an atom as a cutting point *)
Lemma gl_dot n m p (e: glang n m) a (f: glang m p) (e' f': lang):
  gl (e * tatom m a) == e' * latom m a ->
  gl (tatom m a * f) == latom m a * f' ->
  gl (e * tatom m a * f) == e' * latom m a * f'.
Proof.
  setoid_rewrite weq_spec.
  intros He Hf. split; intro w.
  - apply proj1 in He. apply proj1 in Hf.
    intros [g [-> [xa [x Hx [? <- Hxa]] [y Hy Hg]]]].
    apply tapp_x_nil_eq in Hxa as [Ha ->].
    destruct (tapp_bounds Hg) as (H1&H2&H3). (* TOSIMPL *)
    destruct (He (gword_to_word n x)) as [x' Hx' [? <- Hxa']].
     repeat eexists; eauto. rewrite Ha. apply tapp_x_nil.
    destruct (Hf (gword_to_word m y)) as [? <- [y' Hy' Hay']].
     repeat eexists; eauto. rewrite Ha. rewrite H1. apply tapp_nil_x.
    repeat eexists; eauto.
    rewrite app_ass, <-Hay', (gword_to_word_cut m y), (gword_tapp Hg), <-app_ass.
    congruence.
  - apply proj2 in He. apply proj2 in Hf.
    intros [ea [x Hx [? <- ->]] [y Hy ->]].
    edestruct (He (x++atom_to_word m a)) as [xa [Hxa [x' Hx' [? <- Hxa']]]]. eexists; eauto.
    edestruct (Hf (atom_to_word m a++y)) as [ay [Hay [? <- [y' Hy' Hay']]]]. eexists; eauto.
    apply tapp_x_nil_eq in Hxa' as [-> ->].
    apply tapp_nil_x_eq in Hay' as [Ha ->].
    destruct (tapp_cat x' y' Ha) as [z Hz].
    repeat eexists; eauto. 2: apply tapp_x_nil.
    rewrite (gword_tapp Hz), <-Hxa, app_ass, Hay, gword_to_word_cut, ass_app.
    congruence.
Qed.

Lemma gl_nildot a n m (e: glang n m): exists e', gl (tatom n a * e) == latom n a * e'.
Proof.
  exists (fun w => exists g, proj1_sig e g /\ thead g = a /\ w = gword_to_word' g).
  rewrite weq_spec. split; intro w.
   intros [u [-> [? <- [v Hv H]]]]. apply tapp_nil_x_eq in H as [-> ->].
   repeat eexists; eauto. apply gword_to_word_cut.
   intros [? <- [u (x&He&<-&->) ->]].
   repeat eexists; eauto. apply eq_sym, gword_to_word_cut. apply tapp_nil_x.
Qed.

(** key auxiliary lemma for iteration: we need to use an atom as bounds *)
Lemma gl_itr n (e: glang n n) a (e': lang):
  gl (tatom n a * e * tatom n a) == e' * latom n a ->
  gl ((tatom n a * e)^+ * tatom n a) == e'^+ * latom n a.
Proof.
  rename n into m.
  intro H. rewrite <-itr_dot. apply antisym.
  - apply weq_spec in H as [H _]. intros w [g [-> [? <- [u [n Hn] Hg]]]].
    apply tapp_nil_x_eq in Hg as [Hu ->]. revert u Hu Hn. induction n; intros u Hu Hn.
    destruct Hn as [v Hv [? <- Hn]]. apply tapp_x_nil_eq in Hn as [Hn ->].
    destruct (H (gword_to_word m v)) as [u He [? <- H']].
     repeat eexists; eauto. rewrite Hu. apply tapp_nil_x. rewrite Hn. apply tapp_x_nil.
    exists u. now exists O. eauto.
    destruct Hn as [w [v Hv [? <- Hn]] [w' Hw' H']].
    apply tapp_x_nil_eq in Hn as [Hn ->].
    assert (H'' := tapp_bounds H'). (* TOSIMPL *)
    assert (Haw: a=thead w') by (rewrite Hn; intuition congruence).
    destruct (H (gword_to_word m v)) as [xe He [? <- Hxe]].
    repeat eexists; eauto.
     rewrite Hu, <-(tapp_head H'). apply tapp_nil_x.
     rewrite Hn; apply tapp_x_nil.
    assert (Hext: e' * (e'^+ * latom m a) <== e'^+ * latom m a).
     now rewrite dotA, itr_cons.
    apply Hext. clear Hext.
    eexists. eassumption. eexists. apply IHn. apply Haw.
    assumption.
    rewrite (gword_tapp H'), Hxe, gword_to_word_cut, Haw, app_ass. congruence.
  - apply itr_ind_l.
    now rewrite <-H, <-itr_ext, dotA.
    rewrite <-itr_cons at 2.
    destruct (gl_nildot a ((e * tatom m a)^+)) as [f' Hf].
    rewrite 2dotA. rewrite gl_dot by eassumption.
    now rewrite Hf, dotA.
Qed.

(** ** clean terms: those on which [G] and [R] coincide *)

Definition clean1 n m (e: guard n m) := gl (G (geval e)) == R (v (o (geval e))).
Definition clean n m (e: guards n m) := forall g, In g e -> clean1 g.

Lemma G_clean n m (e: guards n m): clean e -> gl (G (teval e)) == R (v (o (teval e))).
Proof.
  intro He. rewrite o_sup, v_sup, lang_sup, R.lang_sup, gl_sup.
  apply sup_weq'. reflexivity. intros g Hg. apply He, Hg.
Qed.

(** basic constructors for clean terms *)

Lemma clean_bot n m: @clean n m bot.
Proof. intros _ []. Qed.

Lemma clean_cup n m (e f: guards n m): clean e -> clean f -> clean (e++f).
Proof. unfold clean. setoid_rewrite in_app_iff. intuition. Qed.

Lemma clean_single n m (g: guard n m): clean1 g -> clean [g].
Proof. now intros ? ? [<-|[]]. Qed.

Lemma clean_sup n m I J (f: I -> guards n m): (forall i, In i J -> clean (f i)) -> clean (sup f J).
Proof. apply P_sup. apply clean_bot. apply clean_cup. Qed.

Lemma clean_map n m I J (f: I -> guard n m): (forall i, In i J -> clean1 (f i)) -> clean (map f J).
Proof. rewrite map_sup. intro. apply clean_sup. intros. apply clean_single. auto. Qed.

(** ** the basic ingredients of the [hat] function preserve cleaness  *)

Lemma clean_pred n a: clean1 (@g_pred n a).
Proof. unfold clean1, geval. rewrite G.lang_atom, R_lang_atom. apply gl_atom. Qed.

Lemma clean_elem_var a i b: clean1 (g_elem a (g_var i) b).
Proof.
  unfold clean1, geval.
  rewrite 2G.lang_dot, 2G.lang_atom.
  setoid_rewrite atom_single_atom. rewrite gl_single'. rewrite 2eq_app_dot.
  do 2 setoid_rewrite R.lang_dot. setoid_rewrite R.lang_var.
  setoid_rewrite <- R_lang_atom. apply dotA.
Qed.

Lemma clean_dot' n m p (e: guards n m) (f: guards m p): clean e -> clean f -> clean (g_dot' e f).
Proof.
  intros He Hf. apply clean_sup. intros x Hx. apply clean_sup. intros y Hy.
  apply He in Hx. apply Hf in Hy. clear e f He Hf.
  destruct x as [a|a e b]; destruct y as [c|c f d]; unfold g_dot1;
    (case eqb_spec; [intros <-|intro E]); try apply clean_bot; apply clean_single; trivial.
  revert Hx Hy. unfold clean1, geval. rewrite 8G.lang_dot, 3G.lang_atom.
  simpl o; simpl v. fold_regex. rewrite 8R.lang_dot. repeat change (o_pred ?a (atom ?b)) with (o (g_atom a b)). setoid_rewrite R_lang_atom.
  intros Hx Hy. rewrite 4dotA, <-dotA, <-(dotA _ _ (latom _ _)).
  apply gl_dot. assumption. rewrite 2dotA. assumption.
Qed.

Lemma clean_one' n: clean (g_one' n).
Proof. apply clean_map. intros. apply clean_pred. Qed.

Lemma clean_inner_dot n m (e: guard n m) (He: clean1 e):
  forall p (f: guard m p), clean1 f ->
   gl (tatom n (fst e) * G (g_inner_dot e f) * tatom p (fst e)) ==
   latom n (fst e) * R (v (o (g_inner_dot e f))) * latom p (fst e).
Proof.
  assert (Z: forall n m p q (e: glang n m) (f: glang p q) e' f', gl (e*G 0*f) == e'*R 0*f').
   intros. rewrite G.lang_0, dotx0, dot0x, gl_bot. setoid_rewrite R.lang_0. ra.
  destruct e as [n a|n m a e b]; destruct f as [p c|p q c f d]; intros Hf;
    simpl fst; simpl lst; simpl g_inner_dot.
  - apply Z.
  - case eqb_spec. intros <-. 2: intros; apply Z.
    case eqb_spec. intros <-. 2: intros; apply Z.
    unfold andb. unfold clean1, geval in Hf.
    rewrite 2G.lang_dot, 2G.lang_atom in Hf. rewrite Hf.
    rewrite <-2R_lang_atom, <-2R.lang_dot. reflexivity.
  - case eqb_spec. intros <-. 2: intros; apply Z.
    case eqb_spec. intros <-. 2: intros; apply Z.
    unfold andb. unfold clean1, geval in He.
    rewrite 2G.lang_dot, 2G.lang_atom in He. rewrite He.
    rewrite <-2R_lang_atom, <-2R.lang_dot. reflexivity.
  - case eqb_spec. intros <-. 2: intros; apply Z.
    case eqb_spec. intros <-. 2: intros; apply Z.
    unfold andb.
    unfold clean1, geval in He. rewrite 2G.lang_dot, 2G.lang_atom in He.
    unfold clean1, geval in Hf. rewrite 2G.lang_dot, 2G.lang_atom in Hf.
    simpl o in *; simpl v in *.
    rewrite 2R.lang_dot in He. repeat change (o_pred ?a (atom ?b)) with (o (g_atom a b)) in He. setoid_rewrite R_lang_atom in He.
    rewrite 2R.lang_dot in Hf. repeat change (o_pred ?a (atom ?b)) with (o (g_atom a b)) in Hf. setoid_rewrite R_lang_atom in Hf.
    rewrite 2R.lang_dot. repeat change (o_pred ?a (atom ?b)) with (o (g_atom a b)). setoid_rewrite R_lang_atom.
    setoid_rewrite G.lang_dot. rewrite dotA. setoid_rewrite G.lang_dot.
    rewrite G.lang_atom.
    rewrite dotA. rewrite <-(dotA _ (G f)).
    rewrite <-2dotA in Hf.
    rewrite gl_dot by eassumption. ra.
Qed.

Lemma clean_str' n (e: guards n n): clean e -> clean (g_str' e).
Proof.
  induction e; intro Hae; simpl g_str'. apply clean_one'.
  assert (He: clean e) by (intros ? ?; apply Hae; now right). specialize (IHe He).
  assert (Ha: clean1 a) by (apply Hae; now left). clear Hae.
  apply clean_cup. assumption.
  apply clean_dot'. assumption.
  apply clean_dot'. apply clean_cup. 2: apply clean_one'.
  2: apply clean_dot'; [now apply clean_single | assumption].
  revert IHe. generalize (g_str' e). clear e He. intros e He.
  apply clean_single. unfold clean1. unfold geval. simpl o; simpl v; fold_regex.
  rewrite 2dotA, <-str_itr, <-2itr_str_l.
  rewrite G.lang_dot, G.lang_itr, G.lang_dot, G.lang_sup, G.lang_atom.
  rewrite R.lang_dot, R.lang_itr, R.lang_dot, o_sup, v_sup, R.lang_sup.
  repeat change (o_pred ?a (atom ?b)) with (o (g_atom a b)). setoid_rewrite R_lang_atom.
  apply gl_itr. rewrite 2dotxsum, 2dotsumx, gl_sup.
  apply sup_weq'. reflexivity. intros f Hf.
  apply clean_inner_dot. apply Ha. apply He, Hf.
Qed.

(** ** the [hat] function produces clean terms *)

Theorem clean_hat n m (e: gregex n m): clean (hat e).
Proof.
  induction e; simpl hat.
   apply clean_bot.
   apply clean_map. intros ? _. apply clean_pred.
   apply clean_sup. intros ? _. apply clean_sup. intros ? _. apply clean_single, clean_elem_var.
   now apply clean_cup.
   now apply clean_dot'.
   apply clean_dot'. assumption. apply clean_str'. assumption.
Qed.

(** whence the desired property, as a corollary *)

Corollary G_hat n m (e: gregex n m): gl (G e) == R (v (o (teval (hat e)))).
Proof. rewrite <-(teval_hat e) at 1. apply G_clean, clean_hat. Qed.

(** * KAT completeness *)

(** we assemble all the pieces as explained at the beginning of this file *)
Theorem kat_complete_weq n m: forall e f: gregex n m, G e == G f -> e == f.
Proof.
  intros e f H.
  apply gl_weq in H.
  rewrite 2G_hat in H.
  apply ka_complete_weq in H.
  apply w_weq in H.
  rewrite 2wvo_uo in H.
  apply erase_faithful_weq in H.
   2: now rewrite 2o_level.
   2: reflexivity.
  apply o_inj in H.
  rewrite 2teval_hat in H.
  assumption.
Qed.

(** we deduce a similar result for language inclusions *)
Corollary kat_complete_leq n m: forall e f: gregex n m, G e <== G f -> e <== f.
Proof. intros e f. rewrite 2leq_iff_cup, <-G.lang_pls. apply kat_complete_weq. Qed.

(** and the above implications actually are equivalences *)
Corollary kat_correct_complete_weq n m: forall e f: gregex n m, G e == G f <-> e == f.
Proof. split. apply kat_complete_weq. apply G.lang_weq. Qed.

Corollary kat_correct_complete_leq n m: forall e f: gregex n m, G e <== G f <-> e <== f.
Proof. split. apply kat_complete_leq. apply G.lang_leq. Qed.

(** * KAT decidability  *)

(** additional corollaries (not used):
   - KAT proofs reduce to KA proofs
   - KAT equality is decidable *)

Corollary kat_reduces_to_ka n m: forall e f: gregex n m,
  e==f <-> v (o (teval (hat e))) == v (o (teval (hat f))).
Proof.
   intros. split; intro H.
    apply ka_complete_weq. now rewrite <-2G_hat, H.
    apply w_weq in H.
    rewrite 2wvo_uo in H.
    apply erase_faithful_weq in H.
     2: now rewrite 2o_level.
     2: reflexivity.
    apply o_inj in H.
    now rewrite 2teval_hat in H.
Qed.

Corollary kat_dec n m: forall e f: gregex n m, {e==f} + {~(e==f)}.
Proof. intros. eapply sumbool_iff. symmetry. apply kat_reduces_to_ka. apply ka_weq_dec. Qed.

End s.