Require Export TopologicalSpaces.
Require Import StrongTopology Compactness.
From ZornsLemma Require Import DependentTypeChoice EnsemblesTactics.

Section SumTopology.

Variable A:Type.
Variable X:forall a:A, TopologicalSpace.

Inductive sum_space_point_set : Type :=
  sum_space_point_set_intro (a : A) : point_set (X a) -> sum_space_point_set.

Definition SumTopology : TopologicalSpace :=
  StrongTopology sum_space_point_set_intro.

End SumTopology.

Arguments sum_space_point_set {A}.
Arguments sum_space_point_set_intro {A}.

Lemma sum_topology_open_full_set_component {A : Type} (X : forall a, TopologicalSpace) :
  forall a, @open (SumTopology A X) (Im Full_set (sum_space_point_set_intro X a)).
Proof.
intros a1 a2.
destruct (classic (a1 = a2)).
- subst.
  replace (inverse_image (sum_space_point_set_intro X a2) (Im Full_set (sum_space_point_set_intro X a2))) with
          (@Full_set (point_set (X a2))).
  + apply open_full.
  + extensionality_ensembles;
      repeat econstructor.
- replace (inverse_image (sum_space_point_set_intro X a2) (Im Full_set (sum_space_point_set_intro X a1))) with
          (@Empty_set (point_set (X a2))).
  + apply open_empty.
  + extensionality_ensembles_inv.
    subst.
    injection H2 as H2.
    now subst.
Qed.

Lemma sum_topology_closed_full_set_component {A : Type} (X : forall a, TopologicalSpace) :
  forall a, @closed (SumTopology A X) (Im Full_set (sum_space_point_set_intro X a)).
Proof.
intros a1 a2.
destruct (classic (a1 = a2)).
- subst.
  replace (inverse_image (sum_space_point_set_intro X a2)
     (@Complement (point_set (SumTopology A X))
        (Im Full_set (sum_space_point_set_intro X a2)))) with
          (@Empty_set (point_set (X a2))).
  + apply open_empty.
  + extensionality_ensembles_inv.
    destruct H0.
    repeat econstructor.
- replace (inverse_image (sum_space_point_set_intro X a2)
     (@Complement (point_set (SumTopology A X))
        (Im Full_set (sum_space_point_set_intro X a1)))) with
          (@Full_set (point_set (X a2))).
  + apply open_full.
  + extensionality_ensembles_inv;
      repeat econstructor.
    intro.
    inversion H0.
    injection H3 as H3.
    now subst.
Qed.

Lemma sum_topology_inj_image_open {A : Type} (X : forall a, TopologicalSpace) (a : A) (S : Ensemble (point_set (X a))) :
  open S <-> @open (SumTopology A X) (Im S (sum_space_point_set_intro X a)).
Proof.
split; intros.
- intro a'.
  destruct (classic (a = a')).
  + subst.
    replace (inverse_image (sum_space_point_set_intro X a') (Im S (sum_space_point_set_intro X a'))) with S;
      trivial.
    extensionality_ensembles_inv.
    * now repeat econstructor.
    * injection H2 as H2.
      apply inj_pair2 in H2.
      now subst.
  + replace (inverse_image (sum_space_point_set_intro X a') (Im S (sum_space_point_set_intro X a))) with
            (@Empty_set (point_set (X a'))).
    * apply open_empty.
    * extensionality_ensembles_inv.
      injection H3 as H3.
      now subst.
- replace S with (inverse_image (sum_space_point_set_intro X a) (Im S (sum_space_point_set_intro X a))).
  + apply H.
  + extensionality_ensembles_inv.
    * injection H2 as H2.
      apply inj_pair2 in H2.
      now subst.
    * now repeat econstructor.
Qed.

Lemma sum_topology_compact {A : Type} (X : forall a, TopologicalSpace) :
  FiniteT A ->
  (forall a, compact (X a)) ->
  compact (SumTopology A X).
Proof.
intros HA HC F HF eq.

assert (forall a U, In (Im F (inverse_image (sum_space_point_set_intro X a))) U -> open U).
{ intros.
  inversion H.
  subst.
  now apply strong_topology_makes_continuous_funcs, HF.
}

assert (forall a, FamilyUnion (Im F (inverse_image (sum_space_point_set_intro X a))) = Full_set).
{ intro.
  extensionality_ensembles_inv;
    [constructor |].
  subst.
  assert (In (@Full_set (point_set (SumTopology A X))) (sum_space_point_set_intro X a x)) by constructor.
  rewrite <- eq in H0.
  inversion H0.
  subst.
  repeat econstructor;
    eassumption.
}
destruct (choice_on_dependent_type _ (fun a => (HC a _ (H a) (H0 a)))) as [fa Hfa].

assert (forall a (U : {U : _ | In (fa a) U}), exists S, In F S /\ inverse_image (sum_space_point_set_intro X a) S = proj1_sig U).
{ intros a [U HU].
  destruct (Hfa a) as [H1 [H2 H3]].
  pose proof (H2 _ HU).
  inversion H4.
  subst.
  exists x.
  now repeat constructor.
}

destruct (choice_on_dependent_type _ (fun a => (choice_on_dependent_type _ (H1 a)))) as [f Hf].

exists (IndexedUnion (fun a => Im Full_set (f a))).
repeat split.
- apply finite_indexed_union; trivial.
  intro.
  apply FiniteT_img.
  + apply Finite_ens_type.
    now destruct (Hfa a).
  + intros.
    now apply classic.
- intros S HS.
  inversion HS;
    inversion H2;
    subst;
    now destruct (Hf a x0).
- extensionality_ensembles_inv;
    [ constructor |].
  subst.
  destruct x.
  assert (In Full_set p) by constructor.
  destruct (Hfa a) as [H3 [H4 H5]].
  rewrite <- H5 in H2.
  destruct H2, (Hf a (exist _ S H2)).
  assert (In (Im Full_set (f a)) (f a (exist _ S H2))) by now econstructor.
  econstructor.
  * econstructor. eassumption.
  * apply in_inverse_image.
    now rewrite (H8 : (@inverse_image _ (point_set (SumTopology A X)) _ _) = _).
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e468m17_15limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


From mathcomp Require Import ssreflect ssrnat ssrbool.
From MonadicEffect Require Import Trees.

Require Import Program.

Module Pure.

  Program Definition Pure A (wp : (A -> Prop) -> Prop) :=
     forall p, { a : A | wp p -> p a }.

  Program Definition ret { A } (a : A) :
    Pure A (fun p => p a) :=
    fun _ => a.

  Program Definition bind : forall A wp1 B wp2,
      Pure A wp1 -> (forall a : A, Pure B (wp2 a)) ->
      Pure B (fun p => wp1 (fun a => wp2 a p)) :=
    fun A wp1 B wp2 c1 c2 p =>
      let: a := c1 (fun x => wp2 x p) in c2 a p.
  Next Obligation.
    elim: c1 H => a' H' /= H.
    elim: c2 H => a'' H'' /= H.
    apply H''. by apply H'.
  Defined.
End Pure.

Program Definition sqr (x : nat) : Pure.Pure nat (fun p => forall y, p y) :=
  Pure.ret (x * x).

Module DST.

  Section DST.
  Variables S : Set.

  Definition WP {A} : Type := S -> ((A * S) -> Prop) -> Prop.

  Program Definition DST A (wp : WP) :=
    forall p s, { t : A * S | wp s p -> p t }.

  Program Definition ret { A } (a : A) :
    DST A (fun s p => p (a, s)) :=
    fun p s => (a, s).

  Program Definition bind : forall A wp1 B wp2,
      DST A wp1 -> (forall a : A, DST B (wp2 a)) ->
      DST B (fun s p => wp1 s (fun t => let: (a', s') := t in wp2 a' s' p)) :=
    fun A wp1 B wp2 c1 c2 p s1 =>
      let: (a, s2) := c1 (fun x => let: (a, s) := x in wp2 a s p) s1 in
      c2 a p s2.
  Next Obligation.
    elim: c1 Heq_anonymous => a' /= H' Heq_anonymous.
    subst. elim: c2 => a''/= H''. auto.
  Defined.

  Program Definition reflect { A } { wp : WP } :
    (forall s, Pure.Pure (A * S) (wp s)) -> DST A wp :=
    fun P p s => P s p.

  Program Definition reify { A } { wp : WP } :
    DST A wp -> forall s, Pure.Pure (A * S) (fun p => wp s p) :=
    fun m s p => m p s.

  Program Definition get : DST S (fun s p => p (s, s)) :=
    reflect (fun s => Pure.ret (s, s)).

  Program Definition put : forall s, DST unit (fun _ p => p (tt, s)) :=
    fun s => reflect (fun _ => Pure.ret (tt, s)).
  End DST.
End DST.

Arguments DST.ret {S} {A}.
Arguments DST.bind {S} {A} {wp1} {B} {wp2}.
Arguments DST.get {S}.
Arguments DST.put {S}.
Arguments DST.reify {S} {A} {wp}.

Notation "c >>= f" := (DST.bind c f) (at level 50, left associativity).
Notation "f =<< c" := (DST.bind c f) (at level 51, right associativity).
Notation "x <- c1 ;; c2" := (DST.bind c1 (fun x => c2)) (at level 100, c1 at next level, right associativity).
Notation "e1 ;; e2" := (_ <- e1 ;; e2) (at level 100, right associativity).

Notation "'ST' s 'return' a 'requires' [ P ] 'ensures' [ Q ]" :=
  (DST.DST s a (fun s1 p => P /\ (forall c s2, Q s1 c s2 -> p (c, s2))))
    (at level 99, P at next level, Q at next level).

Check (ST nat return (Tree nat) requires [True] ensures [fun _ _ _ => True]).

Import DST.

Program Fixpoint relabel {A : Set} (t : Tree A) :
  ST nat return Tree nat
       requires [True]
       ensures [fun i t f => f = i + size t /\ flatten t = seq i (size t)] :=
  match t with
  | Leaf x =>
    n <- get ;;
    put (n + 1) ;;
    ret (Leaf n)
  | Node l r =>
    l' <- relabel l ;;
    r' <- relabel r ;;
    ret (Node l' r')
  end.
Next Obligation.
  case (l' <- relabel A l;; _) => [[a s] H1] /=.
  apply H1. repeat split => //. intros.
  destruct H2; destruct H3; subst.
  apply H0. split => /=.
  - by rewrite addnA.
  - by rewrite H4 H5 seq_split.
Defined.

Compute (reify (relabel (Node (Leaf 1) (Leaf 1))) 10).


(**************************************************************************
* TLC: A library for Coq                                                  *
* Finite maps                                                             *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibReflect LibOption
  LibRelation LibLogic LibOperation LibEpsilon LibSet.
Require Export LibBag.

(** UNDER CONSTRUCTION *)

(* ********************************************************************** *)
(** * Construction of maps as functions *)

(* ---------------------------------------------------------------------- *)
(** ** Basic definitions *)

Definition map (A B : Type) := A -> option B.

Section Operations.
Variables (A B : Type).
Implicit Types k : A.
Implicit Types x : B.
Implicit Types M N : map A B.
Implicit Types E : set A.

Definition empty_impl : map A B := fun _ => None.
Definition single_bind_impl k x := fun k' => If k = k' then Some x else None.
Definition binds_impl M k x := M k = Some x.
Definition union_impl M N :=
  fun k => match N k with
           | None => M k
           | Some v => Some v
           end.
Definition remove_impl M E :=
  fun k => If k \in E then None else M k.
Definition restrict_impl M E :=
  fun k => If k \in E then M k else None.

End Operations.

Definition read_impl A `{Inhab B} (M:map A B) (k:A) :=
  match M k with
  | None => arbitrary
  | Some v => v
  end.

(* ---------------------------------------------------------------------- *)
(** ** Notation through typeclasses *)

Instance empty_inst : forall A B, BagEmpty (map A B).
  constructor. rapply (@empty_impl A B). Defined.
Instance single_bind_inst : forall A B, BagSingleBind A B (map A B).
  constructor. rapply (@single_bind_impl A B). Defined.
Instance binds_inst : forall A B, BagBinds A B (map A B).
  constructor. rapply (@binds_impl A B). Defined.
Instance union_inst : forall A B, BagUnion (map A B). (* todo: bug pas si on enlève B *)
  constructor. rapply (@union_impl A B). Defined.
Instance remove_inst : forall A B, BagRemove (map A B) (set A).
  constructor. rapply (@remove_impl A B). Defined.
Instance restrict_inst : forall A B, BagRestrict (map A B) (set A).
  constructor. rapply (@restrict_impl A B). Defined.
Instance read_inst : forall A `{Inhab B}, BagRead A B (map A B).
  constructor. rapply (@read_impl A B H). Defined.

(* bin : check
Instance update_inst : forall A B, BagUpdate A B (map A B).
typeclass.
*)

Global Opaque map empty_inst single_bind_inst binds_inst
 union_inst restrict_inst remove_inst read_inst.

(** [dom] *)

Definition dom_impl A B (M:map A B) := \set{ k : A | exists v, binds M k v}.

Instance dom_inst : forall A B, BagDom (map A B) (set A).
  constructor. rapply (@dom_impl A B). Defined.

Instance disjoint_inst : forall A B, BagDisjoint (map A B).
  constructor. rapply (fun M N : map A B => disjoint (dom M) (dom N)). Defined.

Instance map_inhab : forall A, Inhab (map A B).
Proof. intros. apply (prove_Inhab (@empty_impl A B)). Qed.

Global Opaque dom_inst disjoint_inst.

(** [index] *)

Instance map_index : forall A B, BagIndex (map A B) A.
Proof. intros. constructor. exact (fun m k => k \in (dom m : set A)). Defined.

Lemma map_index_def : forall A B (m:map A B) k,
  index m k = (k \in (dom m : set A)).
Proof. auto. Qed.

Global Opaque map_index_def.

(* ********************************************************************** *)
(** * Properties of maps *)
(*TODO: under construction *)

Section Properties.
Transparent dom_inst binds_inst empty_inst.

Lemma dom_empty : forall A B,
  dom (\{} : map A B) = (\{} : set A).
Proof.
  intros. simpl. unfold dom_impl. simpl. unfold binds_impl, empty_impl.
  apply set_ext. intros x. rewrite in_set. iff [v Hv] H; false.
Qed.

Lemma in_dom_empty : forall A B x,
  x \indom (\{} : map A B) ->
  False.
Proof.
  intros. rewrite dom_empty in *. eapply in_empty. eauto.
Qed.

Lemma no_binds_empty : forall (A B : Type) (M : map A B),
  (forall x k, ~ binds M x k) -> M = \{}.
Proof.
  intros A B M. simpl. unfold empty_impl, binds_impl.
  Require Import Coq.Logic.FunctionalExtensionality. (* TEMPORARY ok? *)
  intro h. extensionality x. case_eq (M x); try reflexivity. intros v Mxv. false.
  unfold not in h. eauto.
Qed.

Lemma dom_empty_inv : forall A B (M : map A B),
  dom M = \{} -> M = \{}.
Proof.
  intros A B M. simpl. unfold dom_impl, empty_impl.
  intro h. extensionality x. case_eq (M x); try reflexivity. intros v Mxv. false.
  assert (there: x \in (\{} : set A)).
    rewrite <- h. rewrite in_set. exists v. eauto.
  eauto using set_in_empty_inv.
Qed.

End Properties.

Axiom restrict_read : forall A `{Inhab B} (M:map A B) i j,
  i <> j -> (M\--i)\(j) = M\(j).

Axiom restrict_update : forall A `{Inhab B} (M:map A B) i j v,
  i <> j -> (M\--i)\(j:=v) = (M\(j:=v) \--i).

Axiom dom_update_in : forall A i `{Inhab B} v (M:map A B),
  index M i -> dom (M\(i:=v)) = dom M.

Axiom dom_restrict_in : forall A i j `{Inhab B} (M:map A B),
  index M j -> i <> j -> index (M\--i) j.

Axiom update_update_eq : forall A i `{Inhab B} v v' (M:map A B),
  M\(i:=v)\(i:=v') = M\(i:=v').

Implicit Arguments dom_update_in [A B [H]].
Implicit Arguments dom_restrict_in [A B [H]].

Lemma map_update_as_union : forall A B (M:map A B) x v,
  M\(x:=v) = M \u (x \:= v).
Proof. auto. Qed.

Axiom map_split : forall A (E:set A) B (M:map A B),
  M = (M \- E) \u (M \| E).
Axiom map_restrict_single : forall A (x:A) B `{Inhab B} (M:map A B),
  M \| \{x} = (x \:= (M\(x))).
Lemma map_split_single : forall A (x:A) B `{Inhab B} (M:map A B),
  M = (M \- \{x}) \u (x \:= (M\(x))).
Proof. intros. rewrite~ <- map_restrict_single. apply map_split. Qed.

Axiom map_indom_update_inv : forall A `{Inhab B} (m:map A B) (i j:A) (v:B),
  j \indom (m\(i:=v)) -> (j = i \/ j \indom m).
Axiom map_indom_update_already : forall A `{Inhab B} (m:map A B) (i j:A) (v:B),
  j \indom m -> j \indom (m\(i:=v)).

Axiom binds_def : forall A `{Inhab B} (M:map A B) x v,
  binds M x v = (x \indom M /\ M\(x) = v).
Axiom binds_inv : forall A `{Inhab B} (M:map A B) x v,
  binds M x v -> (x \indom M /\ M\(x) = v).
Axiom binds_prove : forall A `{Inhab B} (M:map A B) x v,
  x \indom M -> M\(x) = v -> binds M x v.

Axiom binds_update_neq : forall A i j `{Inhab B} v w (M:map A B),
  j \notin (dom M : set _) -> binds M i v -> binds (M\(j:=w)) i v.
Axiom binds_update_eq : forall A i `{Inhab B} v (M:map A B),
  binds (M\(i:=v)) i v.

Axiom binds_update_neq_inv : forall A i j `{Inhab B} v w (M:map A B),
  binds (M\(j:=w)) i v -> i <> j -> binds M i v.

Axiom binds_inj : forall A i `{Inhab B} v1 v2 (M:map A B),
  binds M i v1 -> binds M i v2 -> v1 = v2.

(*
Axiom binds_update_rem : forall A i j `{Inhab B} v w (M:map A B),
  j \notindom' M -> binds (M\(j:=w)) i v -> binds M i v.
Hint Resolve binds_update_rem.

Lemma is_repr_rem_node : forall M r c x y,
  r \notin (dom M:set _) -> is_repr (M\(r:=c)) x y -> is_repr M x y.
Proof. introv N H. induction H; constructors*. Qed.
*)

Axiom binds_get : forall A `{Inhab B} (M:map A B) x v,
  binds M x v -> M\(x) = v.
Axiom binds_dom : forall A `{Inhab B} (M:map A B) x v,
  binds M x v -> x \indom M.

Axiom dom_update_notin : forall A i `{Inhab B} v (M:map A B),
  i \notin (dom M : set _) -> dom (M\(i:=v)) = dom M \u \{i}.

Axiom binds_index : forall A i `{Inhab B} v (M:map A B),
  binds M i v -> index M i.

Axiom binds_update_neq' : forall A i j `{Inhab B} v w (M:map A B),
  i <> j -> binds M i v -> binds (M\(j:=w)) i v.

Axiom map_indom_update_already_inv : forall A `{Inhab B} (m:map A B) (i j:A) (v:B),
  j \indom (m\(i:=v)) -> i \indom m -> j \indom m.
Global Opaque binds_inst.

(* todo *)
Axiom map_indom_update : forall A `{Inhab B} (m:map A B) (i j:A) (v:B),
  j \indom (m\(i:=v)) = (j = i \/ j \indom m).
Lemma map_indom_update_self : forall A `{Inhab B} (m:map A B) (i:A) (v:B),
  i \indom (m\(i:=v)).
Proof. intros. rewrite~ map_indom_update. Qed.

Hint Resolve map_indom_update_self.

Axiom map_update_read_eq : forall A `{Inhab B} (m:map A B) (i:A) (v:B),
  (m\(i:=v))\(i) = v.
Axiom map_update_read_neq : forall A `{Inhab B} (m:map A B) (i j:A) (v:B),
  i<>j -> (m\(i:=v))\(j) = m\(j).

Axiom map_update_restrict : forall A `{Inhab B} (m:map A B) (i:A) (v:B),
  (m\(i:=v) \- \{i}) = (m \- \{i}).

Hint Rewrite @map_indom_update @map_update_read_neq @map_update_read_eq : rew_map.

Tactic Notation "rew_map" :=
  autorewrite with rew_map.
Tactic Notation "rew_map" "in" hyp(H) :=
  autorewrite with rew_map in H.
Tactic Notation "rew_map" "in" "*" :=
  autorewrite with rew_map in *.

Tactic Notation "rew_map" "~" :=
  rew_map; auto_tilde.
Tactic Notation "rew_map" "*" :=
  rew_map; auto_star.
Tactic Notation "rew_map" "~" "in" hyp(H) :=
  rew_map in H; auto_tilde.
Tactic Notation "rew_map" "*" "in" hyp(H) :=
  rew_map in H; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Reduce on maps *)

Require Import LibStruct.
Section Reduce.
Variables (A B C : Type).
Parameter reduce : monoid_def C -> (A -> B -> C) -> map A B -> C.
Parameter reduce_empty : forall m f, Monoid m ->
  reduce m f \{} = monoid_neutral m.
Parameter reduce_single : forall x v m f, Monoid m ->
  reduce m f (x \:= v) = f x v.
Parameter reduce_union : forall M1 M2 m f, Monoid m ->
  reduce m f (M1 \u M2) = (monoid_oper m) (reduce m f M1) (reduce m f M2).
End Reduce.

(* ---------------------------------------------------------------------- *)
(** ** Structural properties *)

Section Instances.
Variables (A B:Type).

Transparent map empty_inst single_bind_inst binds_inst
 union_inst dom_inst disjoint_inst.

Global Instance map_union_empty_l : Union_empty_l (T:=map A B).
Proof.
  constructor. intros m. simpl.
  unfold union_impl, empty_impl, map. extens.
  intros x. destruct~ (m x).
Qed.

Global Instance map_union_assoc : Union_assoc (T:=map A B).
Proof.
  constructor. intros M N P. simpl.
  unfold union_impl, map. extens.
  intros k. destruct~ (P k).
Qed.

End Instances.


Require Export kat_alph atoms ProofIrrelevance.

Ltac inv c := inversion c;try (discriminate||congruence).
Ltac gl_goal := split;red;intros.

Module GS(X:KAT_Alph).

  Export X.

  Notation atom := (ord (pow2 ntests)).
  Notation prim_test := (ord (ntests)).
  Definition AtSy := (atom*Z)%type.

  (** * Type of tests *)

  Inductive test : Type :=
  | ba0 : test
  | ba1 : test
  | baV : prim_test -> test
  | baN : test -> test
  | baAnd : test -> test -> test
  | baOr : test -> test -> test.

  Notation "`` x" := (baV x)(at level 35).
  Notation "! x" := (baN x)(at level 35).
  Infix "`+" := baOr(at level 45).
  Infix "`·" := baAnd(at level 45).

  (** Burocratic definitions and properties that make [test] and odered typ *)

  Inductive test_eq : test -> test -> Prop :=
  | test_eq_ba0 : test_eq ba0 ba0
  | test_eq_ba1 : test_eq ba1 ba1
  | test_eq_baV : forall x y, x === y -> test_eq (baV x) (baV y)
  | test_eq_baN : forall x y:test, test_eq x y -> test_eq (baN x) (baN y)
  | test_eq_baAnd : forall x₁ x₂ y₁ y₂, test_eq x₁ x₂ -> test_eq y₁ y₂ ->
                                        test_eq (baAnd x₁ y₁) (baAnd x₂ y₂)
  | test_eq_baOr : forall x₁ x₂ y₁ y₂, test_eq x₁ x₂ -> test_eq y₁ y₂ ->
                                        test_eq (baOr x₁ y₁) (baOr x₂ y₂).

  Proposition leibniz_test:
    forall x y:test,
      test_eq x  y -> x = y.
  Proof.
    induction 1;intros;subst;auto.
    apply ord_Eq_unique in H.
    rewrite H.
    reflexivity.
  Qed.

  Inductive test_lt : test -> test -> Prop :=
    test_lt_ba0_ba1 : test_lt ba0 ba1
  | test_lt_ba0_baV : forall y1 , test_lt ba0 (baV y1)
  | test_lt_ba0_baN : forall y1 : test, test_lt ba0 (baN y1)
  | test_lt_ba0_baAnd : forall y1 y2 : test, test_lt ba0 (baAnd y1 y2)
  | test_lt_ba0_baOr : forall y1 y2 : test, test_lt ba0 (baOr y1 y2)
  | test_lt_ba1_baV : forall y1 , test_lt ba1 (baV y1)
  | test_lt_ba1_baN : forall y1 : test, test_lt ba1 (baN y1)
  | test_lt_ba1_baAnd : forall y1 y2 : test, test_lt ba1 (baAnd y1 y2)
  | test_lt_ba1_baOr : forall y1 y2 : test, test_lt ba1 (baOr y1 y2)
  | test_lt_baV_1 : forall x1 y1 , x1 <<< y1 -> test_lt (baV x1) (baV y1)
  | test_lt_baV_baN : forall x1 (y1 : test), test_lt (baV x1) (baN y1)
  | test_lt_baV_baAnd : forall x1 (y1 y2 : test),
                        test_lt (baV x1) (baAnd y1 y2)
  | test_lt_baV_baOr : forall x1 (y1 y2 : test),
                       test_lt (baV x1) (baOr y1 y2)
  | test_lt_baN_1 : forall x1 y1 : test,
                    test_lt x1 y1 -> test_lt (baN x1) (baN y1)
  | test_lt_baN_baAnd : forall x1 y1 y2 : test,
                        test_lt (baN x1) (baAnd y1 y2)
  | test_lt_baN_baOr : forall x1 y1 y2 : test, test_lt (baN x1) (baOr y1 y2)
  | test_lt_baAnd_1 : forall x1 y1 x2 y2 : test,
                      test_lt x1 y1 -> test_lt (baAnd x1 x2) (baAnd y1 y2)
  | test_lt_baAnd_2 : forall x1 y1 x2 y2 : test,
                      test_eq x1 y1 ->
                      test_lt x2 y2 -> test_lt (baAnd x1 x2) (baAnd y1 y2)
  | test_lt_baAnd_baOr : forall x1 x2 y1 y2 : test,
                         test_lt (baAnd x1 x2) (baOr y1 y2)
  | test_lt_baOr_1 : forall x1 y1 x2 y2 : test,
                     test_lt x1 y1 -> test_lt (baOr x1 x2) (baOr y1 y2)
  | test_lt_baOr_2 : forall x1 y1 x2 y2 : test,
                     test_eq x1 y1 ->
                     test_lt x2 y2 -> test_lt (baOr x1 x2) (baOr y1 y2).

  Fixpoint test_cmp (x y : test) : comparison :=
  match x with
  | ba0 =>
      match y with
      | ba0 => Eq
      | ba1 => Lt
      | baV _ => Lt
      | baN _ => Lt
      | baAnd _ _ => Lt
      | baOr _ _ => Lt
      end
  | ba1 =>
      match y with
      | ba0 => Gt
      | ba1 => Eq
      | baV _ => Lt
      | baN _ => Lt
      | baAnd _ _ => Lt
      | baOr _ _ => Lt
      end
  | baV x1 =>
      match y with
      | ba0 => Gt
      | ba1 => Gt
      | baV y1 => ord_Cmp (ntests) x1 y1
      | baN _ => Lt
      | baAnd _ _ => Lt
      | baOr _ _ => Lt
      end
  | baN x1 =>
      match y with
      | ba0 => Gt
      | ba1 => Gt
      | baV _ => Gt
      | baN y1 => test_cmp x1 y1
      | baAnd _ _ => Lt
      | baOr _ _ => Lt
      end
  | baAnd x1 x2 =>
      match y with
      | ba0 => Gt
      | ba1 => Gt
      | baV _ => Gt
      | baN _ => Gt
      | baAnd y1 y2 =>
          match test_cmp x1 y1 with
          | Eq => test_cmp x2 y2
          | Lt => Lt
          | Gt => Gt
          end
      | baOr _ _ => Lt
      end
  | baOr x1 x2 =>
      match y with
      | ba0 => Gt
      | ba1 => Gt
      | baV _ => Gt
      | baN _ => Gt
      | baAnd _ _ => Gt
      | baOr y1 y2 =>
          match test_cmp x1 y1 with
          | Eq => test_cmp x2 y2
          | Lt => Lt
          | Gt => Gt
          end
      end
  end.

  Functional Scheme test_cmp_ind := Induction for test_cmp Sort Prop.
  Functional Scheme test_cmp_rec := Induction for test_cmp Sort Set.

  Global Instance test_eq_refl : Reflexive test_eq.
  Proof.
    repeat red;intros;induction x;try constructor;auto.
  Qed.

  Global Instance test_eq_symm : Symmetric test_eq.
  Proof.
    repeat red.
    induction 1;try reflexivity.
    - constructor;auto.
    - constructor;auto.
    - constructor;auto.
    - constructor;auto.
  Qed.

  Global Instance test_eq_trans : Transitive test_eq.
  Proof.
    repeat red.
    induction x;intros.
    - inv H.
    - inv H.
    - inv H;subst;inv H0;subst;constructor.
      rewrite H2;auto.
    - inv H;subst. inv H0;subst. constructor;eauto.
    - inv H;subst;inv H0;subst. constructor;eauto.
    - inv H;subst;inv H0;subst. constructor;eauto.
  Qed.

  Global Instance test_eq_Equiv : Equivalence test_eq.
  Proof.
    constructor;autotc.
  Qed.

  (** Auxiliary lemmas for test_cmp *)
  Lemma test_cmp_eq_leibniz :
    forall x y, test_cmp x y = Eq -> x = y.
  Proof.
    intros.
    functional induction (test_cmp x y);
      first [reflexivity|discriminate|auto].
    apply compare_2 in H.
    apply ord_Eq_unique in H.
    rewrite H;auto.
    apply IHc in H;subst;auto.
    apply IHc in e1;apply IHc0 in H;subst;auto.
    apply IHc in e1;apply IHc0 in H;subst;auto.
  Qed.

  Lemma test_cmp_lt :
    forall x y, test_cmp x y = Lt -> test_lt x y.
  Proof.
    intros.
    functional induction (test_cmp x y);
      try (now constructor||discriminate).
    apply compare_1 in H;auto.
    constructor;auto.
    constructor.
    apply IHc;auto.
    apply IHc0 in H.
    apply test_lt_baAnd_2;auto.
    apply test_cmp_eq_leibniz in e1;subst;auto.
    reflexivity.
    constructor.
    apply IHc;auto.
    apply test_cmp_eq_leibniz in e1;subst.
    apply test_lt_baOr_2;auto.
    reflexivity.
    constructor.
    apply IHc;auto.
  Qed.

  Lemma test_cmp_gt :
    forall x y, test_cmp x y = Gt -> test_lt y x.
  Proof.
    intros.
    functional induction (test_cmp x y);
      try (now constructor||discriminate).
    apply compare_3 in H;auto.
    constructor;auto.
    constructor.
    apply IHc;auto.
    apply IHc0 in H.
    apply test_lt_baAnd_2;auto.
    apply test_cmp_eq_leibniz in e1;subst;auto.
    reflexivity.
    constructor.
    apply IHc;auto.
    apply test_cmp_eq_leibniz in e1;subst.
    apply test_lt_baOr_2;auto.
    reflexivity.
    constructor.
    apply IHc;auto.
  Qed.

  Proposition test_lt_not_refl :
    forall y, ~test_lt y y.
  Proof.
    intros;intro.
    dependent induction H.
    order.
    elim IHtest_lt.
    elim IHtest_lt.
    elim IHtest_lt.
    elim IHtest_lt.
    elim IHtest_lt.
  Qed.

  Global Program Instance testUOrd : UsualOrderedType test :=
    { SOT_lt := test_lt ; SOT_cmp := test_cmp}.
  Next Obligation.
    constructor.
    - repeat red;induction x;intros;destruct y;try now(inv H);try now(inv H0;constructor).
      + inv H0;subst;econstructor;inv H;subst;transitivity o0;auto.
      + inv H0;subst;inv H;try (now constructor);subst. constructor. eapply IHx;eauto.
      + inv H0;subst;inv H;subst.
        * constructor;eapply IHx1;eauto.
        * constructor;apply leibniz_test in H5;subst;assumption.
        * { apply leibniz_test in H3;subst;inv H;subst.
            - constructor;eauto.
            - constructor;eauto.
          }
        * apply leibniz_test in H6;subst. apply test_lt_baAnd_2;auto;eapply IHx2;eauto.
        * { inv H0;subst;inv H;subst.
            - constructor;eauto.
            - apply leibniz_test in H5;subst. constructor;eauto.
          }
        * { inv H;subst.
            - apply leibniz_test in H4;subst. constructor.
            - constructor.
          }
      + inv H;subst.
        * { inv H0;subst.
            - constructor;eapply IHx1;eauto.
            - apply leibniz_test in H4. subst. apply test_lt_baOr_1;auto.
          }
        * { apply leibniz_test in H4;subst. inv H0;subst.
            - constructor;auto.
            - apply test_lt_baOr_2;eauto.
          }
    - intros;intro. rewrite H0 in H. pose proof test_lt_not_refl y. contradiction.
  Defined.
  Next Obligation.
    - case_eq(test_cmp x y);constructor.
     + apply test_cmp_eq_leibniz;auto.
     + apply test_cmp_lt;auto.
     + apply test_cmp_gt;auto.
  Defined.

  (** * Boolean evaluation of tests wrt. atoms. *)

  (* begin show *)
  Function evalT(a:atom)(x:test){struct x} : bool :=
    match x with
      | ba0 => false
      | ba1 => true
      | baV b => nth_bit _ a b
      | baN a1 => negb (evalT a a1)
      | baAnd a1 a2 => andb (evalT a a1) (evalT a a2)
      | baOr a1 a2 => orb (evalT a a1) (evalT a a2)
    end.
  (* end show*)

  (** * Type [gstring] of Guarded Strings *)

  Inductive gstring : Type :=
  | gs_end  : atom -> gstring
  | gs_conc : atom -> Z -> gstring -> gstring.

  (** Bureocratic definitions and properties that characterize [gstring] as an ordered type *)

  Inductive gstring_eq : gstring -> gstring -> Prop :=
    gstring_eq_gs_end : forall x1 y1 : atom,
                        x1 === y1 -> gstring_eq (gs_end x1) (gs_end y1)
  | gstring_eq_gs_conc : forall (x1 y1 : atom) (x2 y2 : Z) (x3 y3 : gstring),
                         x1 === y1 ->
                         x2 === y2 ->
                         gstring_eq x3 y3 ->
                         gstring_eq (gs_conc x1 x2 x3) (gs_conc y1 y2 y3).

  Hint Constructors gstring_eq.

  Proposition leibniz_gstring :
    forall x y:gstring, gstring_eq x y -> x = y.
  Proof.
    induction 1.
    - ord_eq_un H;auto.
    - ord_eq_un H;inv H0.
  Qed.

  Instance gstring_eq_equiv : Equivalence gstring_eq.
  Proof.
    constructor;repeat red.
    - intros;induction x;auto.
    - induction 1;inv H;auto.
    - induction x.
      + intros;inv H;subst;ord_eq_un H2;auto.
      + intros;inv H;subst;ord_eq_un H4;inv H6;subst;inv H0;subst;
        constructor;auto;eapply IHx;eauto.
  Qed.

  Inductive gstring_lt : gstring -> gstring -> Prop :=
    gstring_lt_gs_end_1 : forall x1 y1 : atom,
                            x1 <<< y1 -> gstring_lt (gs_end x1) (gs_end y1)
  | gstring_lt_gs_end_gs_conc : forall (x1 y1 : atom)
                                       (y2 : Z) (y3 : gstring),
                                  gstring_lt (gs_end x1) (gs_conc y1 y2 y3)
  | gstring_lt_gs_conc_1 : forall (x1 y1 : atom) (x2 y2 : Z)
                                  (x3 y3 : gstring),
                             x1 <<< y1 ->
                             gstring_lt (gs_conc x1 x2 x3) (gs_conc y1 y2 y3)
  | gstring_lt_gs_conc_2 : forall (x1 y1 : atom) (x2 y2 : Z)
                                  (x3 y3 : gstring),
                             x1 === y1 ->
                             x2 <<< y2 ->
                             gstring_lt (gs_conc x1 x2 x3) (gs_conc y1 y2 y3)
  | gstring_lt_gs_conc_3 : forall (x1 y1 : atom) (x2 y2 : Z)
                                  (x3 y3 : gstring),
                             x1 === y1 ->
                             x2 === y2 ->
                             gstring_lt x3 y3 ->
                             gstring_lt (gs_conc x1 x2 x3) (gs_conc y1 y2 y3).

  Instance gstring_lt_trans : Transitive gstring_lt.
  Proof.
    repeat red.
    induction x;intros.
    - inv H;inv H0;subst.
      + injection H5;intros;subst;constructor;order.
      + constructor.
      + constructor.
      + constructor.
      + constructor.
    - inv H;subst;inv H0;subst.
      + constructor;order.
      + ord_eq_un H6. constructor;order.
      + ord_eq_un H4. inv H7;subst;constructor;order.
      + ord_eq_un H5. constructor;auto.
      + ord_eq_un H5;inv H7;subst;constructor 4;order.
      + ord_eq_un H5;inv H4;inv H8;subst;constructor 4;order.
      + ord_eq_un H4;inv H6;subst;constructor;auto.
      + ord_eq_un H4;inv H6;inv H8;subst;constructor 4;auto.
      + ord_eq_un H4;inv H6;inv H5;inv H9;subst;constructor 5;auto;
        eapply IHx;eauto.
  Qed.

  Fixpoint gstring_cmp (x y : gstring) : comparison :=
    match x with
      | gs_end x1 =>
        match y with
          | gs_end y1 => ord_Cmp _ x1 y1
          | gs_conc _ _ _ => Lt
        end
      | gs_conc x1 x2 x3 =>
        match y with
          | gs_end _ => Gt
          | gs_conc y1 y2 y3 =>
            match ord_Cmp _ x1 y1 with
              | Eq =>
                match compare x2 y2 with
                  | Eq => gstring_cmp x3 y3
                  | Lt => Lt
                  | Gt => Gt
                end
              | Lt => Lt
              | Gt => Gt
            end
        end
    end.

  Functional Scheme gstring_cmp_ind := Induction for gstring_cmp Sort Prop.
  Functional Scheme gstring_cmp_rec := Induction for gstring_cmp Sort Set.

  Proposition gstring_cmp_eq_leibniz :
    forall x y, gstring_cmp x y = Eq -> x = y.
  Proof.
    intros.
    functional induction (gstring_cmp x y);try discriminate.
    + apply compare_2 in H. ord_eq_un H;auto.
    + apply compare_2 in e1; apply compare_2 in e2.
      ord_eq_un e1. inv e2. subst. apply IHc in H;subst;reflexivity.
  Qed.

  Proposition gstring_cmp_lt :
    forall x y, gstring_cmp x y = Lt -> gstring_lt x y.
  Proof.
    intros.
    functional induction (gstring_cmp x y);try (now (discriminate||constructor)).
    + apply compare_1 in H. constructor. order.
    + apply compare_2 in e1; apply compare_2 in e2;subst;inv e1;inv e2;subst.
      constructor 5;auto.
    + apply compare_2 in e1;apply compare_1 in e2;inv e1;subst;constructor 4;auto.
    + apply compare_1 in e1;constructor;auto.
  Qed.

  Proposition gstring_cmp_gt :
    forall x y, gstring_cmp x y = Gt -> gstring_lt y x.
  Proof.
    intros.
    functional induction (gstring_cmp x y);try (now (discriminate||constructor)).
    + apply compare_3 in H;constructor;auto.
    + apply compare_2 in e1; apply compare_2 in e2;subst;inv e1;inv e2;subst.
      constructor 5;auto.
    + apply compare_2 in e1;apply compare_3 in e2;inv e1;subst;constructor 4;auto.
    + apply compare_3 in e1;constructor;auto.
  Qed.

  Instance gstring_UOT : UsualOrderedType gstring :=
    { SOT_lt := gstring_lt ; SOT_cmp := gstring_cmp}.
  Proof.
    constructor;autotc.
    - induction 1;intros.
      + intro H0;inv H0;subst;order.
      + intro H0;inv H0.
      + intro H0;inv H0;subst;order.
      + intro H1;inv H1;subst;order.
      + intro H2;inv H2;subst;order.
    - intros. case_eq(gstring_cmp x y);intro;constructor.
      + apply gstring_cmp_eq_leibniz;auto.
      + apply gstring_cmp_lt;auto.
      + apply gstring_cmp_gt;auto.
  Defined.

  Lemma list_leibniz :
    forall l1 l2:list (atom*Z),
      l1 === l2 -> l1 = l2.
  Proof.
    induction 1;try congruence.
    normalize_notations.
    subst.
    destruct a;destruct a'.
    f_equal.
    destruct H.
    normalize_notations. clear H0. inv H1.
  Qed.

  (** * First and last atom of a guarded string *)

  Fixpoint last gs :=
    match gs with
      | gs_end k => k
      | gs_conc _ _ k => last k
    end.
  Notation "↓ g" := (last g)(at level 44).

  Fixpoint first gs :=
    match gs with
      | gs_end k => k
      | gs_conc k _ _ => k
    end.
  Notation "↑ g" := (first g)(at level 44).

  Notation "⌜  a  , b ⌝:: v" := (gs_conc a b v)(at level 45).
  Notation "⌜  a ⌝" := (gs_end a)(at level 45).

  (** Two guarded strings are [compatible] if the last atom of the
      first guarded string is the same as the first atom of the
      second. *)

  Definition compatible gs1 gs2 := last gs1 = first gs2.
  Infix "≀" := (compatible)(at level 10).

  (** Properties of compatibility *)

  Lemma compatible_gs_conc :
    forall g1 g2 x xs,
      compatible g1 g2 -> compatible (gs_conc x xs g1) g2.
  Proof.
    auto.
  Qed.

  Lemma compatible_last :
    forall g1 g2,
      compatible g1 g2 -> compatible (gs_end (last g1)) g2.
  Proof.
    auto.
  Qed.

  Definition compatible_rewrite (gs1 gs2:gstring)(H:compatible gs1 gs2)
              (x:atom)(k:Z)(t:gstring)(L:gs1 = gs_conc x k t) :
    compatible t gs2.
  Proof.
    subst.
    auto.
  Defined.

  (** * Fusion product for guarded strings. *)

  Fixpoint fusion_prod gs1 gs2 (H:compatible gs1 gs2) : gstring :=
    match gs1 as x return gs1=x -> gstring with
      | gs_end _ =>
          fun H:(gs1 = gs_end _) => gs2
      | gs_conc k s t =>
          fun H0:(gs1 = gs_conc k s t) =>
            gs_conc k s (fusion_prod t gs2 (compatible_rewrite gs1 gs2 H k s t H0))
    end (refl_equal gs1).

  Notation "a ⋄ b ( c )" := (fusion_prod a b c)(at level 45).

  (** Properties of fusion product. *)

  Lemma fusion_prod_compatible :
    forall a a0 s x y0 T0,
      compatible (gs_end a) (fusion_prod (gs_conc a0 s x) y0 T0) ->
      compatible (gs_end a) (gs_conc a0 s x).
  Proof.
    intros.
    simpl in H.
    unfold compatible in H.
    simpl in H.
    subst.
    unfold compatible.
    simpl.
    reflexivity.
  Qed.

  (** Decidability of the [compatible] predicate. *)

  Lemma compatible_dec :
    forall x y,
      {compatible x y}+{~compatible x y}.
  Proof.
    unfold compatible.
    induction x;simpl;auto with typeclass_instances.
    intros.
    destruct y;simpl;intros;
    (case_eq(compare o o0);intros;
    [apply compare_2 in H | apply compare_1 in H | apply compare_3 in H]);try auto;
    try (right;intro;subst;order).
  Qed.

  (** Some more properties about [fusion_prod] *)

  Lemma fusion_prod_head :
    forall a a0 s x H,
    fusion_prod (gs_end a) (gs_conc a0 s x) H = gs_conc a0 s x.
  Proof. auto. Qed.

  Lemma fusion_prod_ext :
    forall a y H,
      fusion_prod (gs_end a) y H = y.
  Proof. auto. Qed.

  Lemma fusion_prod_end :
    forall x0 a T,
      fusion_prod x0 (gs_end a) T = x0.
  Proof.
    induction x0;simpl;intros.
    -  unfold compatible in T;simpl in T;subst;auto.
    - f_equal;rewrite IHx0;auto.
  Qed.

  Lemma fusion_prod_fst :
    forall x y0 T0,
      first (fusion_prod x y0 T0) = first x.
  Proof. induction x;simpl;intros;auto. Qed.

  Lemma fusion_prod_gs_conc :
    forall a s x0 x y0 T0 T,
      exists t',
        fusion_prod (gs_conc a s x0) (fusion_prod x y0 T0) T =
        gs_conc a s (fusion_prod x0 (fusion_prod x y0 T0) t').
  Proof.
    intros.

    assert(compatible x0 (fusion_prod x y0 T0)).
    unfold compatible in T |- *.
    simpl in *.
    assumption.

    red in T;simpl in T.
    exists T;simpl;f_equal.
  Qed.

  Lemma fusion_prod_gs_conc_rev :
    forall a s x0 x y0 T0 T,
      exists t',
        gs_conc a s (fusion_prod x0 (fusion_prod x y0 T0) T) =
        fusion_prod (gs_conc a s x0) (fusion_prod x y0 T0) t'.
  Proof.
    induction x0.
    simpl.
    intros.
    eexists.
    red.
    simpl.
    red in T.
    simpl in T.
    assumption.
    f_equal.
    intros.
    unfold compatible in *.
    simpl in *.
    exists T.
    f_equal.
  Qed.

  Lemma fusion_prod_gs_generic :
    forall a s x0 z T,
      exists t',
        fusion_prod (gs_conc a s x0) z T =
        gs_conc a s (fusion_prod x0 z t').
  Proof.
    intros.
    simpl.
    eexists.
    f_equal.
  Qed.

  Lemma fusion_prod_proof_inj :
    forall x z T T',
      fusion_prod x z T = fusion_prod x z T'.
  Proof.
    induction x;simpl;intros.
    reflexivity.
    f_equal.
    unfold compatible in *;simpl in *.
    generalize(
      (compatible_rewrite (gs_conc o z x) z0 T o z x (eq_refl (gs_conc o z x)))).
    generalize(
      (compatible_rewrite (gs_conc o z x) z0 T' o z x (eq_refl (gs_conc o z x)))).
    intros.
    unfold compatible in c,c0.
    pose proof IHx z0 c0 c.
    assumption.
  Qed.

  Lemma fusion_prod_gs_generic_inv :
    forall a s x0 z t',
      exists T,
        gs_conc a s (fusion_prod x0 z t') =
        fusion_prod (gs_conc a s x0) z T.
  Proof.
    intros.
    assert(compatible (gs_conc a s x0) z).
    unfold compatible in *.
    simpl in *.
    assumption.
    simpl.
    exists H.
    f_equal.
    apply fusion_prod_proof_inj.
  Qed.

  Lemma last_fusion_prod :
    forall x0 x c,
    last (fusion_prod x0 x c) = last x.
  Proof.
    induction x0;intros.
    simpl.
    reflexivity.
    erewrite <- (IHx0 x _).
    simpl.
    f_equal.
  Qed.

  Lemma fusion_prod_end_gen :
    forall a s x0 x H,
      last (fusion_prod (gs_conc a s x0) x H) = last x.
  Proof.
    intros.
    simpl.
    generalize((compatible_rewrite (gs_conc a s x0) x H a s x0
           (eq_refl (gs_conc a s x0)))).
    intro.
    rewrite last_fusion_prod.
    reflexivity.
  Qed.

  Lemma fusion_prod_same_last :
    forall x t ,
       x = fusion_prod x (gs_end (last x)) t.
  Proof.
    induction x;intros.
    simpl.
    reflexivity.
    simpl.
    rewrite IHx at 1.
    reflexivity.
  Qed.

  Lemma fusion_product_assoc_left :
    forall x x0 y0 T0 T,
    exists T',
      exists T'',
        (fusion_prod x0 (fusion_prod x y0 T0) T) =
        (fusion_prod (fusion_prod x0 x T') y0 T'').
  Proof.
    induction x0;intros.
    destruct x.
    simpl in T.

    assert(compatible (gs_end o) (gs_end o0)).
    unfold compatible in *.
    rewrite T.
    symmetry.
    assumption.

    exists H.
    simpl.
    exists T0.
    reflexivity.

    pose proof fusion_prod_compatible o o0 z x y0 T0 T.
    exists H.

    assert(compatible (fusion_prod (gs_end o) (gs_conc o0 z x) H) y0).
    unfold compatible in *;simpl in *.
    assumption.

    rewrite fusion_prod_head.
    exists T0.
    unfold compatible in T,T0;simpl in T,T0.
    generalize T.
    rewrite T.
    intro.
    rewrite fusion_prod_ext.
    reflexivity.

    assert(compatible (gs_conc o z x0) x).
    apply compatible_last in T.
    simpl in T.
    unfold compatible in T.
    simpl in T.
    red.
    simpl.
    rewrite fusion_prod_fst in T.
    assumption.

    exists H.
    assert(compatible x0 (fusion_prod x y0 T0)).
    unfold compatible in H.
    unfold compatible.
    simpl in H.
    rewrite fusion_prod_fst.
    assumption.
    specialize IHx0 with y0 T0 H0.
    destruct IHx0.
    destruct H1.

    assert(compatible (fusion_prod (gs_conc o z x0) x H) y0).
    unfold compatible in *;simpl in *.
    generalize((compatible_rewrite (gs_conc o z x0) x H o z x0
           (eq_refl (gs_conc o z x0))));intro.
    rewrite last_fusion_prod.
    assumption.
    exists H2.
    simpl.
    assert(fusion_prod x0 (fusion_prod x y0 T0) H0 =
      (fusion_prod x0 (fusion_prod x y0 T0)
        (compatible_rewrite (gs_conc o z x0) (fusion_prod x y0 T0) T o z x0
           (eq_refl (gs_conc o z x0))))).
    apply fusion_prod_proof_inj.
    rewrite <- H3.
    rewrite H1.
    f_equal.
    generalize((compatible_rewrite
        (gs_conc o z
           (fusion_prod x0 x
              (compatible_rewrite (gs_conc o z x0) x H o z x0
                 (eq_refl (gs_conc o z x0))))) y0 H2 o z
        (fusion_prod x0 x
           (compatible_rewrite (gs_conc o z x0) x H o z x0
              (eq_refl (gs_conc o z x0))))
        (eq_refl
           (gs_conc o z
              (fusion_prod x0 x
                 (compatible_rewrite (gs_conc o z x0) x H o z x0
                    (eq_refl (gs_conc o z x0)))))))).
    intro.
    assert(fusion_prod x0 x x1 =
      fusion_prod x0 x
        (compatible_rewrite (gs_conc o z x0) x H o z x0
           (eq_refl (gs_conc o z x0)))).
    apply fusion_prod_proof_inj.
    revert c.
    rewrite <- H4.
    intros.
    apply fusion_prod_proof_inj.
  Qed.

  Lemma fusion_product_assoc_right :
    forall x x0 y0 T' T'',
    exists T0,
      exists T,
        (fusion_prod (fusion_prod x0 x T') y0 T'') =
        (fusion_prod x0 (fusion_prod x y0 T0) T).
  Proof.
    induction x0;intros.
    destruct x.
    simpl in T''.

    exists T''.
    assert(compatible (gs_end o) (fusion_prod (gs_end o0) y0 T'')).
    simpl.
    unfold compatible in *.
    simpl in *.
    subst.
    reflexivity.
    exists H.
    rewrite fusion_prod_ext.
    simpl.
    reflexivity.
    simpl in T''.
    exists T''.

    assert(compatible (gs_end o) (fusion_prod (gs_conc o0 z x) y0 T'')).
    unfold compatible.
    simpl.
    unfold compatible in T'.
    simpl in T'.
    assumption.
    exists H.

    rewrite fusion_prod_ext.
    simpl.
    reflexivity.

    assert(compatible x y0).
    unfold compatible in T'' |- *.
    rewrite fusion_prod_end_gen in T''.
    assumption.

    exists H.
    assert(compatible (gs_conc o z x0) (fusion_prod x y0 H)).
    unfold compatible.
    simpl.
    unfold compatible in T';simpl in T'.
    rewrite fusion_prod_fst.
    assumption.

    exists H0.
    assert(compatible x0 x).
    unfold compatible in T'.
    simpl in T'.
    apply T'.

    generalize T''.

    pose proof fusion_prod_gs_generic o z x0 _ H0.
    destruct H2.
    rewrite H2.
    pose proof fusion_prod_gs_generic o z x0 x T'.
    destruct H3.
    rewrite H3.
    intro.
    pose proof fusion_prod_gs_generic o z (fusion_prod x0 x x2) y0 T''0.
    destruct H4.
    rewrite H4.
    f_equal.
    pose proof IHx0 y0 x2 x3.
    destruct H5.
    destruct H5.
    rewrite H5.
    assert(fusion_prod x y0 x4 = fusion_prod x y0 H) by
      (apply fusion_prod_proof_inj).
    revert x5 H5.
    rewrite H6.
    intros.
    apply fusion_prod_proof_inj.
  Qed.

  Corollary fusion_prod_split_gs_end :
  forall x y a T,
    fusion_prod x y T = gs_end a ->
    x = gs_end a /\ y = gs_end a.
  Proof.
    induction x;intros.
    simpl in H;rewrite H in T.
    red in T;simpl in T.
    subst.
    split;auto.
    split.
    assert(compatible x y).
    apply T.
    pose proof IHx y a T.
    simpl in H.
    discriminate.
    assert(compatible x y).
    apply T.
    assert(fusion_prod x y T = gs_end a).
    revert H.
    induction x.
    simpl.
    intros.
    discriminate.
    simpl.
    intros.
    discriminate.
    apply IHx in H1.
    destruct H1;auto.
  Qed.

  Lemma blop :
      forall x0 y T a s x,
        fusion_prod x0 y T = gs_conc a s x ->
        (exists x',exists t',
                 x0 = gs_conc a s x' /\ fusion_prod x' y t' = x) \/
        (x0 = gs_end a /\ y = gs_conc a s x).
    Proof.
      induction x0;intros.
      simpl in *.
      right.
      split;auto.
      rewrite H in T.
      unfold compatible in T.
      simpl in T.
      subst;auto.
      simpl in H.
      injection H.
      intros.
      clear H.
      subst.
      left.
      exists x0.
      assert(compatible x0 y).
      unfold compatible in T |- *.
      simpl in T.
      assumption.
      exists H.
      split;auto.
      apply fusion_prod_proof_inj.
    Qed.

  (** Besides guarded strings, we also consider guarded sequences,
      which are lists of type [(atom*Z)]. Sequences can be mapped and
      extracted form a guarded string since sequences are guarded strings
      without their last atom.*)

  Notation seq := (list (atom*Z)).

  Fixpoint to_gstring (l:seq) (g:gstring) : gstring :=
    match l with
      | nil => g
      | x::xs => gs_conc (fst x) (snd x) (to_gstring xs g)
    end.

  Fixpoint from_gstring (g:gstring) : (list (atom*Z)) :=
    match g with
      | gs_end a => nil
      | gs_conc a p x => (a,p)::from_gstring x
    end.

  Lemma to_gstring_app :
    forall w1 w2 x,
      to_gstring (w1 ++ w2) x = to_gstring w1 (to_gstring w2 x).
  Proof.
    induction w1;simpl;intros.
    reflexivity.
    f_equal.
    rewrite IHw1.
    reflexivity.
  Qed.

  Lemma from_to_gstring :
    forall w,
      w = (to_gstring (from_gstring w) (gs_end (last w))).
  Proof.
    induction w;simpl;intros.
    reflexivity.
    rewrite <- IHw.
    reflexivity.
  Qed.

  Lemma from_string_correct :
    forall g,
      g = to_gstring (from_gstring g) (gs_end (last g)).
  Proof.
    induction g;intros.
    simpl.
    reflexivity.
    simpl.
    rewrite <- IHg.
    reflexivity.
  Qed.

End GS.


Require Import Tweetnacl.Libs.Export.

Open Scope Z.

Module Mid.
Definition getbit (i:Z) (a: Z) :=
  if (Z.ltb a 0) then
    0
  else
  if (Z.ltb i 0) then
  Z.land a 1
  else
  Z.land (Z.shiftr a i) 1.

End Mid.
Close Scope Z.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e468m17_19limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(*|
############################################
Dependent type as a function argument in Coq
############################################

:Link: https://stackoverflow.com/q/58848680
|*)

(*|
Question
********

I am very new to Coq. I am trying to experiment with Coq's dependent
types. What I want to do, is to simply feed an even number to a
function. For example, in pseudo-code:

.. code::

    def next_even(n: {n: Integer | n is even}) :=
    {
      add n 2
    }

Then I want to utilize the function with different arguments, such as
(in pseudo-code):

.. code-block:: C

    next_even(1)    // Coq should show an error
    next_even(4)    // Coq should compute 6

So, in Coq, I want to do the following:

.. code-block:: coq

    Compute (next_even 1).
    Compute (next_even 4).

How can I construct it?
|*)

(*|
Answer
******

Here is a direct translation of your function in Coq:
|*)

From Coq Require Import Arith.

Definition add_two_even (n : {n : nat | Nat.even n = true}) : nat :=
  proj1_sig n + 1.

(*|
Note that you need the ``proj1_sig`` function to extract ``n`` from
the subset type ``{n : nat | Nat.even n = true}``. To use
``add_two_even``, you also need to go the other way around: go from a
number to an element of ``{n | Nat.even n = true}``. In Coq, this
requires manual proof. For concrete values of ``n``, this is easy:
|*)

(* The next command fails with a type checking error *)
Fail Compute add_two_even (exist _ 1 eq_refl). (* .fails *)
(* The next command succeeds *)
Compute add_two_even (exist _ 4 eq_refl).

(*|
The ``exist`` constructor wraps a value ``x`` with a proof of ``P x``,
producing an element of the subset type ``{x | P x}``. The ``eq_refl``
term is a proof of ``x = x`` for any value of ``x``. When ``n`` is a
concrete number, Coq can evaluate ``Nat.even n`` and find if
``eq_refl`` is a valid proof of ``Nat.even n = true``. When ``n`` is
``1``, ``Nat.even n = false``, and the check fails, leading to the
first error message. When ``n`` is ``4``, the check succeeds.

Things get more complicated when ``n`` is not a constant, but an
arbitrary expression. A proof that ``Nat.even n = true`` can require
detailed reasoning that must be guided by the user. For instance, we
know that ``Nat.even (n + n) = true`` for any value of ``n``, but Coq
does not. Thus, to call ``add_two_even`` on something of the form ``n
+ n``, we need to show a lemma.
|*)

Lemma add_n_n_even n : Nat.even (n + n) = true.
Proof.
  induction n as [|n IH]; trivial.
  now simpl; rewrite <- plus_n_Sm, IH.
Qed.

Definition foo (n : nat) :=
  add_two_even (exist _ (n + n) (add_n_n_even n)).

(*|
There are some tools for facilitating this style of programming, such
as the `equations plugin
<https://github.com/mattam82/Coq-Equations>`__, but the general wisdom
in the Coq community is that you should avoid subset types for
functions like ``add_two_even``, where the constraints do not
substantially simplify the properties about the function.

You can find many examples of good uses of subset types in the
`Mathematical Components <https://github.com/math-comp/math-comp>`__
libraries. For example, the libraries use subset types to define a
type ``n.-tuple T`` of lists of length ``n``, and a type ``'I_n`` of
integers bounded by ``n``. This allows us to define a total accessor
function ``tnth (t : n.-tuple T) (i : 'I_n) : T`` that extracts the
``i``\ th element of the list ``t``. If we define this accessor for
arbitrary lists and integers, we need to pass a default value to the
function to return when the index is out of bounds, or change the
function's signature so that it returns a value of type ``option T``
instead, indicating that the function can fail to return a value. This
change makes properties of the accessor function harder to state. For
example, consider the ``eq_from_tnth`` lemma, which says that two
lists are equal if all their elements are equal:

.. code-block:: coq

    eq_from_tnth:
      forall (n : nat) (T : Type) (t1 t2 : n.-tuple T),
        (forall i : 'I_n, tnth t1 i = tnth t2 i) -> t1 = t2

The statement of this lemma for arbitrary lists becomes more
complicated, because we need an extra assumption saying that the two
lists are of the same size. (Here, ``x0`` is the default value.)

.. code-block:: coq

    eq_from_nth:
      forall (T : Type) (x0 : T) (s1 s2 : list T),
      size s1 = size s2 ->
      (forall i : nat, i < size s1 -> nth x0 s1 i = nth x0 s2 i) -> s1 = s2
|*)


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.PreFun.
Require Import ExtLib.Data.String.

Require Import MirrorCore.TypesI.

Require Import Charge.ModularFunc.Denotation.

Require Import Coq.Strings.String.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.

Class BaseType (typ : Type) := {
  tyNat  : typ;
  tyBool : typ;
  tyString : typ;
  tyProd : typ -> typ -> typ
}.

Section BaseTypeD.
	Context {typ : Type} {HT : BaseType typ} {HR : RType typ}.

	Class BaseTypeD := {
	  btNat : typD tyNat = nat;
	  btBool : typD tyBool = bool;
	  btString : typD tyString = string;
	  btProd : forall t1 t2, typD (tyProd t1 t2) = (typD t1 * typD t2)%type;

      tyProd_inj : forall t u t' u', Rty (tyProd t u) (tyProd t' u') -> Rty t t' /\ Rty u u'
	}.

End BaseTypeD.

Implicit Arguments BaseTypeD [[typ] [HR]].

Ltac prod_inj :=
  match goal with
    | typ : Type |- _ =>
      match goal with
        | BT : BaseType typ, RType_typ : RType typ |- _ =>
          match goal with
            | _ : BaseTypeD BT, H : tyProd _ _ = tyProd _ _ |- _ => apply tyProd_inj in H; unfold Rty in H; destruct H; subst
          end
      end
  end.

Section BaseTypeD'.
  Context {typ : Type} {BT : BaseType typ} {RType_typ : RType typ} {BTD : BaseTypeD BT}.

  Definition natD (n : typD tyNat) : nat :=
    trmD n btNat.

  Definition boolD (b : typD tyBool) : bool :=
    trmD b btBool.

  Definition stringD (s : typD tyString) : string :=
    trmD s btString.

  Definition pairE {A B : Type} {t u : typ} (e1 : typD t = A) (e2 : typD u = B) : typD (tyProd t u) = (A * B)%type :=
    eq_ind (typD t) (fun X : Type => typD (tyProd t u) = (X * B)%type)
      (eq_ind (typD u) (fun Y : Type => typD (tyProd t u) = (typD t * Y)%type)
         (btProd t u) B e2) A e1.

  Definition natR (n : nat) : typD tyNat :=
    trmR n btNat.

  Definition boolR (b : bool) : typD tyBool :=
    trmR b btBool.

  Definition stringR (s : string) : typD tyString :=
    trmR s btString.

  Definition prodD t u (p : typD (tyProd t u)) : typD t * typD u :=
    trmD p (pairE (t := t) (u := u) eq_refl eq_refl).

  Definition prodR t u (p : typD t * typD u) : typD (tyProd t u) :=
    trmR p (pairE (t := t) (u := u) eq_refl eq_refl).

  Lemma prodDR (t u : typ) A B C D (x : A) (y : B) (e1 : typD t = A) (e2 : typD u = B) (e3 : typD t = C) (e4 : typD u = D) :
    trmD (trmR (x, y) (pairE e1 e2)) (pairE e3 e4) =
    (trmD (trmR x e1) e3, trmD (trmR y e2) e4).
  Proof.
    unfold trmD, trmR, pairE, eq_ind, eq_rect_r, eq_rect, eq_sym, id.
    clear.
    revert e1 e2 e3 e4.
    generalize (btProd t u).
    generalize dependent (tyProd t u).
    generalize dependent (typD t).
    generalize dependent (typD u).
    do 3 intros.
    generalize dependent (typD t0).
    intros; repeat subst. reflexivity.
  Qed.

End BaseTypeD'.

Section BaseTypeRelDec.
  Context {typ : Type} {BT : BaseType typ} {RType_typ : RType typ} {BTD : BaseTypeD BT}.

  Global Instance RelDec_tyString : RelDec (@eq (typD tyString)) := {
    rel_dec a b := stringD a ?[ eq ] stringD b
  }.

  Lemma rel_dec_tyString_correct (a b : typD tyString) :
    a ?[ eq ] b = true <-> a = b.
  Proof.
    split; intros.
    + unfold rel_dec in H; simpl in H.
      rewrite rel_dec_correct in H.
      apply trmD_inj in H. apply H.
    + subst; unfold rel_dec; simpl; apply rel_dec_eq_true; [apply _| reflexivity].
  Qed.

  Global Instance RelDec_Correct_tyString : RelDec_Correct RelDec_tyString := {
    rel_dec_correct := rel_dec_tyString_correct
  }.

End BaseTypeRelDec.


Require Import List.
Require Import Eqdep_dec.
Require Import Peano_dec.

Require Export prison.
Require Import list_facts.

Definition xorem l ll := map (fun e => xorb (fst e) (snd e)) (zipmin l ll).

Lemma replen :
  forall A (a : A) n,
    length (rep a n) = n.
Proof.
   induction n. simpl. reflexivity.
   simpl. rewrite IHn. reflexivity.
Qed.

Lemma zipmap_comm :
  forall A B (f : A -> A -> B) (_ : forall a aa, f a aa = f aa a) l ll,
    map (fun e => f (fst e) (snd e)) (zipmin l ll) = map (fun e => f (fst e) (snd e)) (zipmin ll l).
Proof.
  induction l. destruct ll; reflexivity.
  destruct ll. reflexivity.
  simpl. rewrite H. apply f_equal2; [ reflexivity | ].
  apply IHl.
Qed.

Lemma zipmap_assoc :
  forall A (f : A -> A -> A) (_ : forall a aa aaa, f a (f aa aaa) = f (f a aa) aaa) l ll lll,
    map (fun e => f (fst e) (snd e)) (zipmin l (map (fun e => f (fst e) (snd e)) (zipmin ll lll))) =
    map (fun e => f (fst e) (snd e)) (zipmin (map (fun e => f (fst e) (snd e)) (zipmin l ll)) lll).
Proof.
  induction l. destruct ll; reflexivity.
  destruct ll. reflexivity.
  intros.
  simpl. destruct lll; simpl; [ reflexivity | ].
  rewrite H. rewrite IHl. reflexivity.
Qed.

Lemma xorem_length :
  forall l ll,
    length l = length ll ->
    length (xorem l ll) = length l.
Proof.
  induction l. simpl. reflexivity.
  intros. simpl. destruct ll. simpl in H. discriminate H.
  simpl. unfold xorem in *. rewrite IHl. reflexivity.
  simpl in H. inversion H. auto.
Qed.

Lemma xorem_comm :
  forall l ll,
    xorem l ll = xorem ll l.
Proof.
  unfold xorem. apply zipmap_comm. destruct a, aa; reflexivity.
Qed.

Lemma xorem_assoc :
  forall l ll lll,
    xorem l (xorem ll lll) = xorem (xorem l ll) lll.
Proof.
  unfold xorem. apply zipmap_assoc. destruct a, aa, aaa; reflexivity.
Qed.

Lemma flipxor :
  forall l n k,
    flip l n k = xorem (flip (rep false (length l)) n k) l.
Proof.
  induction l. simpl. reflexivity.
  intros. unfold xorem in *. simpl.
  destruct k; simpl; apply f_equal2; destruct a; simpl; try reflexivity; rewrite IHl; reflexivity.
Qed.

Lemma flipeachxor :
  forall l n,
    flipeach l n = xorem (flipeach (rep false (length l)) n) l.
Proof.
  unfold flipeach. intros. apply flipxor.
Qed.

Lemma flip_length : forall l n k, length (flip l n k) = length l.
Proof.
  induction l; auto.
  simpl. destruct k.
  - simpl. rewrite IHl. reflexivity.
  - simpl. rewrite IHl. reflexivity.
Qed.

Lemma flipeach_length : forall l n, length (flipeach l n) = length l.
Proof.
  induction l; auto.
  simpl. destruct n;
  simpl; rewrite flip_length; reflexivity.
Qed.

Lemma flipwhile_length :
  forall n l,
    length (flipwhile l n) = length l.
Proof.
  induction n. simpl. intros. rewrite flipeach_length. reflexivity.
  intros. simpl. rewrite IHn. rewrite flipeach_length. reflexivity.
Qed.

Lemma flipwhilexor :
  forall n l,
    flipwhile l n = xorem (flipwhile (rep false (length l)) n) l.
Proof.
  induction n. simpl. intros. apply flipeachxor.
  destruct l.
  -  simpl. rewrite IHn. clear IHn.
     unfold xorem. unfold flipeach. unfold flip.
     simpl. repeat rewrite zipminlnil. reflexivity.
  - simpl. rewrite IHn. rewrite (IHn (flipeach _ _)). rewrite flipeachxor at 2.
    rewrite xorem_assoc.
    apply f_equal2; [ | reflexivity ].
    repeat rewrite flipeach_length.
    simpl. rewrite replen. reflexivity.
Qed.

Lemma flipflip : forall l n1 k1 n2 k2, flip (flip l n1 k1) n2 k2 = flip (flip l n2 k2) n1 k1.
Proof.
  intros.
  rewrite (flipxor (flip l n2 _) n1).
  rewrite (flipxor l n2).
  rewrite (flipxor (flip l _ _)).
  rewrite (flipxor l).
  rewrite xorem_length. rewrite flip_length. rewrite replen.
  rewrite xorem_length. rewrite flip_length. rewrite replen.
  remember (rep _ (length l)).
  remember (flip _ n2 _).
  remember (flip _ n1 _).
  rewrite xorem_assoc. rewrite (xorem_comm l1 l2). rewrite xorem_assoc. reflexivity.
  rewrite flip_length. rewrite replen. reflexivity.
  rewrite flip_length. rewrite replen. reflexivity.
Qed.

Lemma flipeachflipeach : forall l n1 n2, flipeach (flipeach l n1) n2 = flipeach (flipeach l n2) n1.
Proof.
  intros.
  rewrite flipeachxor. rewrite flipeach_length.
  rewrite (flipeachxor _ n1).
  rewrite (flipeachxor l).
  rewrite (flipeachxor (xorem _ _)).
  rewrite xorem_length. rewrite flipeach_length. rewrite replen.
  remember (rep false _).
  remember (flipeach _ n1).
  remember (flipeach _ n2).
  rewrite xorem_assoc. rewrite (xorem_comm l2 l1).
  rewrite xorem_assoc. reflexivity.
  rewrite flipeach_length. rewrite replen. reflexivity.
Qed.

Lemma flipwhileflipwhile : forall n1 n2 l, flipwhile (flipwhile l n1) n2 = flipwhile (flipwhile l n2) n1.
Proof.
  intros.
  rewrite flipwhilexor. rewrite flipwhile_length.
  rewrite (flipwhilexor n1).
  rewrite (flipwhilexor _ l).
  rewrite (flipwhilexor _ (xorem _ _)). rewrite xorem_length. rewrite flipwhile_length. rewrite replen.
  remember (flipwhile _ n2). remember (flipwhile _ n1).
  rewrite xorem_assoc. rewrite (xorem_comm l0 l1). rewrite xorem_assoc. reflexivity.
  rewrite flipwhile_length. rewrite replen. reflexivity.
Qed.

Lemma flipeach0neg :
  forall l,
    flipeach l 0 = map negb l.
Proof.
  induction l. simpl. reflexivity.
  unfold flipeach in *. simpl in *.
  rewrite <- IHl. reflexivity.
Qed.

Lemma flipwhileflipeach :
  forall n1 n2 l,
    flipwhile (flipeach l n1) n2 = flipeach (flipwhile l n2) n1.
Proof.
  intros.
  rewrite flipwhilexor. rewrite flipeach_length.
  rewrite (flipwhilexor n2 l).
  rewrite flipeachxor.
  rewrite (flipeachxor (xorem _ _) n1).
  rewrite xorem_length. rewrite flipwhile_length. rewrite replen.
  remember (flipwhile _ _).
  remember (flipeach _ _).
  rewrite xorem_assoc. rewrite (xorem_comm l0 l1). rewrite xorem_assoc. reflexivity.
  rewrite flipwhile_length. rewrite replen. reflexivity.
Qed.


Inductive unit : Set :=
| tt.

Check unit.
Check tt.

Theorem unit_singleton : forall x : unit, x = tt.
  induction x.
  reflexivity.
Qed.

Check unit_ind.

Inductive Empty_set : Set := .

Theorem the_sky_is_falling : forall x : Empty_set, 2 + 2 = 5.
  destruct 1.
Qed.

Check Empty_set_ind.

Definition e2u (e : Empty_set) : unit :=
  match e with end.

Inductive bool : Set :=
| true
| false.

Definition negb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Theorem negb_inverse : forall b : bool, negb (negb b) = b.
  destruct b.
  reflexivity.
  Restart.
  destruct b; reflexivity.
Qed.

Theorem negb_ineq : forall b : bool, negb b <> b.
  destruct b;
    discriminate.
Qed.

Check bool_ind.