Require Import Basics.
Require Import Pointed.Core.
Require Import Types.
Require Import Colimits.Pushout.
Require Import Cubical.

Local Open Scope pointed_scope.
Local Open Scope dpath_scope.

(* Definition of smash product *)

Definition sum_to_prod (X Y : pType) : X + Y -> X * Y
  := sum_ind _ (fun x => (x, point Y)) (fun y => (point X, y)).

Definition sum_to_bool X Y : X + Y -> Bool
  := sum_ind _ (fun _ => false) (fun _ => true).

Definition Smash (X Y : pType) : pType
  := Build_pType (Pushout (sum_to_prod X Y) (sum_to_bool X Y))
      (pushl (point X, point Y)).

Section Smash.

  Context {X Y : pType}.

  Definition sm (x : X) (y : Y) : Smash X Y := pushl (x, y).

  Definition auxl : Smash X Y := pushr false.

  Definition auxr : Smash X Y := pushr true.

  Notation pt := (point _).

  Definition gluel (x : X) : sm x pt = auxl
    := pglue (f:=sum_to_prod X Y) (g:=sum_to_bool X Y) (inl x).

  Definition gluer (y : Y) : sm pt y = auxr
    := pglue (f:=sum_to_prod X Y) (g:=sum_to_bool X Y) (inr y).

  Definition gluel' (x x' : X) : sm x pt = sm x' pt
    := gluel x @ (gluel x')^.

  Definition gluer' (y y' : Y) : sm pt y = sm pt y'
    := gluer y @ (gluer y')^.

  Definition glue (x : X) (y : Y) : sm x pt = sm pt y
    := gluel' x pt @ gluer' pt y.

  Definition glue_pt_left (y : Y) : glue pt y = gluer' pt y.
  Proof.
    refine (_ @ concat_1p _).
    apply whiskerR, concat_pV.
  Defined.

  Definition glue_pt_right (x : X) : glue x pt = gluel' x pt.
  Proof.
    refine (_ @ concat_p1 _).
    apply whiskerL, concat_pV.
  Defined.

  Definition ap_sm_left {x x' : X} (p : x = x')
    : ap (fun t => sm t pt) p = gluel' x x'.
  Proof.
    destruct p.
    symmetry.
    apply concat_pV.
  Defined.

  Definition ap_sm_right {y y' : Y} (p : y = y')
    : ap (sm pt) p = gluer' y y'.
  Proof.
    destruct p.
    symmetry.
    apply concat_pV.
  Defined.

  Definition Smash_ind {P : Smash X Y -> Type}
    (Psm : forall a b, P (sm a b)) (Pl : P auxl) (Pr : P auxr)
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr)
    : forall x : Smash X Y, P x.
  Proof.
    serapply Pushout_ind.
    + intros [a b].
      apply Psm.
    + apply (Bool_ind _ Pr Pl).
    + serapply sum_ind; intro; apply dp_path_transport^-1.
      - apply Pgl.
      - apply Pgr.
  Defined.

  Definition Smash_ind_beta_gluel {P : Smash X Y -> Type}
    {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a : X)
    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluel a) = Pgl a.
  Proof.
    apply dp_apD_path_transport.
    refine (Pushout_ind_beta_pglue P _ _ _ (inl a) @ _).
    unfold sum_ind.
    by apply ap.
  Qed.

  Definition Smash_ind_beta_gluer {P : Smash X Y -> Type}
    {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (b : Y)
    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluer b) = Pgr b.
  Proof.
    apply dp_apD_path_transport.
    refine (Pushout_ind_beta_pglue P _ _ _ (inr b) @ _).
    unfold sum_ind.
    by apply ap.
  Qed.

  Definition Smash_ind_beta_gluel' {P : Smash X Y -> Type}
    {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a b : X)
    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluel' a b)
    = (Pgl a) @D ((Pgl b)^D).
  Proof.
    unfold gluel'.
    rewrite dp_apD_pp, dp_apD_V.
    by rewrite 2 Smash_ind_beta_gluel.
  Qed.

  Definition Smash_ind_beta_gluer' {P : Smash X Y -> Type}
    {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a b : Y)
    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluer' a b)
    = (Pgr a) @D ((Pgr b)^D).
  Proof.
    unfold gluer'.
    rewrite dp_apD_pp, dp_apD_V.
    by rewrite 2 Smash_ind_beta_gluer.
  Qed.

  Definition Smash_ind_beta_glue {P : Smash X Y -> Type}
    {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a : X) (b : Y)
    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (glue a b)
    = ((Pgl a) @D ((Pgl pt)^D)) @D ((Pgr pt) @D ((Pgr b)^D)).
  Proof.
    by rewrite dp_apD_pp, Smash_ind_beta_gluel', Smash_ind_beta_gluer'.
  Qed.

  Definition Smash_rec {P : Type} (Psm : X -> Y -> P) (Pl Pr : P)
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr)
    : Smash X Y -> P := Smash_ind Psm Pl Pr
      (fun x => dp_const (Pgl x)) (fun x => dp_const (Pgr x)).

  Local Open Scope path_scope.

  (* Version of smash_rec that forces (Pgl pt) and (Pgr pt) to be idpath *)
  Definition Smash_rec' {P : Type} {Psm : X -> Y -> P}
    (Pgl : forall a, Psm a pt = Psm pt pt) (Pgr : forall b, Psm pt b = Psm pt pt)
    (ql : Pgl pt = 1) (qr : Pgr pt = 1)
    : Smash X Y -> P := Smash_rec Psm (Psm pt pt) (Psm pt pt) Pgl Pgr.

  Definition Smash_rec_beta_gluel {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a : X)
    : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluel a) = Pgl a.
  Proof.
    refine (_ @ eissect dp_const (Pgl a)).
    apply moveL_equiv_V.
    unfold Smash_rec.
    refine ((dp_apD_const (Smash_ind Psm Pl Pr (fun x : X => dp_const (Pgl x))
      (fun x : Y => dp_const (Pgr x))) (gluel a))^ @ _).
    erapply Smash_ind_beta_gluel.
  Qed.

  Definition smash_rec_beta_gluer {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (b : Y)
    : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluer b) = Pgr b.
  Proof.
    refine (_ @ eissect dp_const (Pgr b)).
    apply moveL_equiv_V.
    unfold Smash_rec.
    refine ((dp_apD_const (Smash_ind Psm Pl Pr (fun x : X => dp_const (Pgl x))
      (fun x : Y => dp_const (Pgr x))) (gluer b))^ @ _).
    erapply Smash_ind_beta_gluer.
  Qed.

  Definition Smash_rec_beta_gluel' {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a b : X)
    : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluel' a b) = Pgl a @ (Pgl b)^.
  Proof.
    rewrite ap_pp, ap_V.
    by rewrite 2 Smash_rec_beta_gluel.
  Qed.

  Definition Smash_rec_beta_gluer' {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a b : Y)
    : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluer' a b) = Pgr a @ (Pgr b)^.
  Proof.
    rewrite ap_pp, ap_V.
    by rewrite 2 smash_rec_beta_gluer.
  Qed.

  Definition smash_rec_beta_glue {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a : X)
    (b : Y) : ap (Smash_rec Psm Pl Pr Pgl Pgr) (glue a b)
    = ((Pgl a) @ (Pgl pt)^) @ (Pgr pt @ (Pgr b)^).
  Proof.
    by rewrite ap_pp, Smash_rec_beta_gluel', Smash_rec_beta_gluer'.
  Defined.

  Arguments sm : simpl never.
  Arguments auxl : simpl never.
  Arguments gluel : simpl never.
  Arguments gluer : simpl never.

End Smash.


From Hammer Require Import Hammer.

Require Export Ensembles.
Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Partial_Order.
Require Export Cpo.

Section The_power_set_partial_order.
Variable U : Type.

Inductive Power_set (A:Ensemble U) : Ensemble (Ensemble U) :=
Definition_of_Power_set :
forall X:Ensemble U, Included U X A -> In (Ensemble U) (Power_set A) X.
Hint Resolve Definition_of_Power_set.

Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X.
intro X; red.
intros x H'; elim H'.
Qed.
Hint Resolve Empty_set_minimal.

Theorem Power_set_Inhabited :
forall X:Ensemble U, Inhabited (Ensemble U) (Power_set X).
intro X.
apply Inhabited_intro with (Empty_set U); auto with sets.
Qed.
Hint Resolve Power_set_Inhabited.

Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U).
auto 6 with sets.
Qed.
Hint Resolve Inclusion_is_an_order.

Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U).
elim Inclusion_is_an_order; auto with sets.
Qed.
Hint Resolve Inclusion_is_transitive.

Definition Power_set_PO : Ensemble U -> PO (Ensemble U).
intro A; try assumption.
apply Definition_of_PO with (Power_set A) (Included U); auto with sets.
Defined.
Hint Unfold Power_set_PO.

Theorem Strict_Rel_is_Strict_Included :
same_relation (Ensemble U) (Strict_Included U)
(Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))).
auto with sets.
Qed.
Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included.

Lemma Strict_inclusion_is_transitive_with_inclusion :
forall x y z:Ensemble U,
Strict_Included U x y -> Included U y z -> Strict_Included U x z.
intros x y z H' H'0; try assumption.
elim Strict_Rel_is_Strict_Included.
unfold contains.
intros H'1 H'2; try assumption.
apply H'1.
apply Strict_Rel_Transitive_with_Rel with (y := y); auto with sets.
Qed.

Lemma Strict_inclusion_is_transitive_with_inclusion_left :
forall x y z:Ensemble U,
Included U x y -> Strict_Included U y z -> Strict_Included U x z.
intros x y z H' H'0; try assumption.
elim Strict_Rel_is_Strict_Included.
unfold contains.
intros H'1 H'2; try assumption.
apply H'1.
apply Strict_Rel_Transitive_with_Rel_left with (y := y); auto with sets.
Qed.

Lemma Strict_inclusion_is_transitive :
Transitive (Ensemble U) (Strict_Included U).
apply cong_transitive_same_relation with
(R := Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U)));
auto with sets.
Qed.

Theorem Empty_set_is_Bottom :
forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U).
intro A; apply Bottom_definition; simpl; auto with sets.
Qed.
Hint Resolve Empty_set_is_Bottom.

Theorem Union_minimal :
forall a b X:Ensemble U,
Included U a X -> Included U b X -> Included U (Union U a b) X.
intros a b X H' H'0; red.
intros x H'1; elim H'1; auto with sets.
Qed.
Hint Resolve Union_minimal.

Theorem Intersection_maximal :
forall a b X:Ensemble U,
Included U X a -> Included U X b -> Included U X (Intersection U a b).
auto with sets.
Qed.

Theorem Union_increases_l : forall a b:Ensemble U, Included U a (Union U a b).
auto with sets.
Qed.

Theorem Union_increases_r : forall a b:Ensemble U, Included U b (Union U a b).
auto with sets.
Qed.

Theorem Intersection_decreases_l :
forall a b:Ensemble U, Included U (Intersection U a b) a.
intros a b; red.
intros x H'; elim H'; auto with sets.
Qed.

Theorem Intersection_decreases_r :
forall a b:Ensemble U, Included U (Intersection U a b) b.
intros a b; red.
intros x H'; elim H'; auto with sets.
Qed.
Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l
Intersection_decreases_r.

Theorem Union_is_Lub :
forall A a b:Ensemble U,
Included U a A ->
Included U b A ->
Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b).
intros A a b H' H'0.
apply Lub_definition; simpl.
apply Upper_Bound_definition; simpl; auto with sets.
intros y H'1; elim H'1; auto with sets.
intros y H'1; elim H'1; simpl; auto with sets.
Qed.

Theorem Intersection_is_Glb :
forall A a b:Ensemble U,
Included U a A ->
Included U b A ->
Glb (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b)
(Intersection U a b).
intros A a b H' H'0.
apply Glb_definition; simpl.
apply Lower_Bound_definition; simpl; auto with sets.
apply Definition_of_Power_set.
generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a;
auto with sets.
intros y H'1; elim H'1; auto with sets.
intros y H'1; elim H'1; simpl; auto with sets.
Qed.

End The_power_set_partial_order.

Hint Resolve Empty_set_minimal: sets.
Hint Resolve Power_set_Inhabited: sets.
Hint Resolve Inclusion_is_an_order: sets.
Hint Resolve Inclusion_is_transitive: sets.
Hint Resolve Union_minimal: sets.
Hint Resolve Union_increases_l: sets.
Hint Resolve Union_increases_r: sets.
Hint Resolve Intersection_decreases_l: sets.
Hint Resolve Intersection_decreases_r: sets.
Hint Resolve Empty_set_is_Bottom: sets.
Hint Resolve Strict_inclusion_is_transitive: sets.


Require Import Utf8.
Require Import List.
Require Import Nat.
Require Import Permutation.
Require Import Bool.
Scheme Equality for list.

Module Type PRIQUEUE.
  Definition key := nat.
  Parameter  priqueue : Type.
  Parameter  empty : priqueue.
  Parameter  insert : key -> priqueue -> priqueue.
  Parameter  delete_min : priqueue -> option (key * priqueue).
  Parameter  merge : priqueue -> priqueue -> priqueue.
  Parameter  priq : priqueue -> Prop.
  Parameter  Abs : priqueue -> list key -> Prop.

  Axiom can_relate : forall p, priq p -> exists al, Abs p al.
  Axiom abs_perm :
    forall p al bl, priq p -> Abs p al -> Abs p bl -> Permutation al bl.
  Axiom empty_priq : priq empty.
  Axiom empty_relate : Abs empty nil.
  Axiom insert_priq : forall k p, priq p -> priq (insert k p).
  Axiom insert_relate :
    forall p al k, priq p -> Abs p al -> Abs (insert k p) (k::al).
  Axiom delete_min_None_relate :
    forall p, priq p -> (Abs p nil <-> delete_min p = None).
  Axiom delete_min_Some_priq :
    forall p q k, priq p → delete_min p = Some(k,q) → priq q.
  Axiom delete_min_Some_relate :
    forall (p q: priqueue) k (pl ql: list key), priq p →
       Abs p pl →
       delete_min p = Some (k,q) →
       Abs q ql →
       Permutation pl (k::ql) ∧ Forall (le k) ql.
  Axiom merge_priq : forall p q, priq p -> priq q -> priq (merge p q).
  Axiom merge_relate :
    forall p q pl ql al,
       priq p -> priq q ->
       Abs p pl -> Abs q ql -> Abs (merge p q) al ->
       Permutation al (pl++ql).

End PRIQUEUE.

Module CartesianTree <: PRIQUEUE.

  Inductive cartesian_tree : Type :=
  | leaf : cartesian_tree
  | node : nat -> cartesian_tree -> cartesian_tree -> cartesian_tree.

  Definition ct_empty : cartesian_tree := leaf.

  Definition ct  (ct: cartesian_tree) : Prop := True.

  Fixpoint ct_insert (n: nat) (ct: cartesian_tree) : cartesian_tree :=
  match ct with
  | leaf => node n leaf leaf
  | node x l r =>
               if x <? n then node x  l (ct_insert n r)
               else if n <? x then node n ct leaf
               else node x l (node n r leaf)
  end.

  Fixpoint create_cartesian_tree  (l: list nat) : cartesian_tree :=
  match l with
  | nil => leaf
  | (x::xs) =>
            match xs with
            | nil => node x leaf leaf
            | y::ys => fold_right ct_insert leaf (rev (x::y::ys))
            end
  end.

  Fixpoint ct_flatten (ct: cartesian_tree) : list nat :=
  match ct with
  | leaf => nil
  | node x l r => ct_flatten l ++ cons x nil ++ ct_flatten r
  end.

  Definition ct_merge (ct1: cartesian_tree ) (ct2: cartesian_tree) : cartesian_tree :=
  create_cartesian_tree ((ct_flatten ct1) ++ (ct_flatten ct2)).

  Definition ct_delete_min (ct : cartesian_tree) : option (nat * cartesian_tree) :=
  match ct with
  | leaf => None
  | node x l r => Some (x, ct_merge l r)
  end.

  Print Is_true.
  Print list_beq.
  Print remove.

  Fixpoint remv (n: nat) (l: list nat) : list nat :=
  match l with
  | nil => nil
  | (x::xs) => if n =? x then xs else (cons x nil )++ (remv n xs)
  end.

  Fixpoint l_eq (l1: list nat) (l2: list nat) : bool :=
  match l1, l2 with
  | nil, nil => true
  | nil, _ => false
  | _, nil => false
  | (x::xs), (y::ys) => if x =? y then l_eq xs ys else false
  end.

  Fixpoint perm (l1: list nat) (l2: list nat): bool :=
  match l1, l2 with
  | nil, nil => true
  | (x::xs), (y::ys) => if andb (l_eq (remv x (y::ys)) nil) (negb (l_eq ys nil)) then false else perm xs (remv x (y::ys))
  | _, _ => false
  end.

  Definition abs (ct: cartesian_tree) (l: list nat) : Prop :=
  match ct, l with
  | leaf, nil => True
  | node n l r, x::xs => if perm (ct_flatten ct) (x::xs) then True else False
  | _, _ => False
  end.

  Compute abs (node 3 (node 8 leaf leaf) (node 5 leaf leaf)) (5::3::8::nil).
  Compute create_cartesian_tree (8::4::6::3::5::4::nil).
  Compute ct_flatten (create_cartesian_tree (8::4::6::3::5::4::nil)).
  Compute create_cartesian_tree (8::nil).
  Compute create_cartesian_tree (8::4::nil).
  Compute ct_insert 3 (node 4 (node 8 leaf leaf) (node 6 leaf leaf)).
  Compute ct_insert 5 (node 3 (node 4 (node 8 leaf leaf) (node 6 leaf leaf)) leaf).
  Compute ct_flatten (node 3 (node 4 (node 8 leaf leaf) (node 6 leaf leaf)) (node 5 leaf leaf)).
  Compute create_cartesian_tree (8 :: 4 :: 6 :: 3 :: 5 :: nil).
  Compute ct_flatten (node 3 (node 8 leaf leaf) (node 5 leaf leaf)).
  Compute ct_delete_min (node 3 (node 4 (node 8 leaf leaf) (node 6 leaf leaf)) leaf).
  Compute ct_delete_min (node 4 (node 8 leaf leaf) (node 6 leaf leaf)).
  Compute ct_delete_min (node 3 (node 4 (node 8 leaf leaf) (node 6 leaf leaf)) (node 5 leaf leaf)).

  Theorem can_relate_ct : forall (p : cartesian_tree), exists al, abs p al.
  Proof.
    intros.
    eexists.
    instantiate (1:=(ct_flatten p)).
    unfold abs. destruct p eqn:H.
    - simpl. reflexivity.
    - simpl. Abort.

  Theorem abs_perm_ct :
    forall (p : cartesian_tree) al bl, abs p al /\ abs p bl -> Permutation al bl.
  Proof. Admitted.

  Theorem empty_ct : ct ct_empty.
  Proof. reflexivity. Qed.

  Theorem empty_relate_ct : abs ct_empty nil.
  Proof. unfold abs. reflexivity. Qed.

  Theorem insert_ct : forall k p, ct p -> ct (ct_insert k p).
  Proof. intros. unfold ct. reflexivity. Qed.

  Theorem insert_relate_ct :
    forall p al k, ct p -> abs p al -> abs (ct_insert k p) (k::al).
  Proof. Admitted.

  Theorem delete_min_None_relate_ct :
    forall p, ct p -> (abs p nil <-> ct_delete_min p = None).
  Proof. Admitted.

  Theorem delete_min_Some_ct :
    forall p q k, ct p → ct_delete_min p = Some(k,q) → ct q.
  Proof. intros. destruct q.
    - reflexivity.
    - apply H.
  Qed.

  Theorem delete_min_Some_relate_ct :
    forall (p q: cartesian_tree) k (pl ql: list nat), ct p →
       abs p pl →
       ct_delete_min p = Some (k,q) →
       abs q ql →
       Permutation pl (k::ql) ∧ Forall (le k) ql.
  Proof. Admitted.

  Theorem merge_ct : forall p q, ct p -> ct q -> ct (ct_merge p q).
  Proof. intros. reflexivity. Qed.

  Theorem merge_relate_ct :
    forall p q pl ql al,
       ct p -> ct q ->
       abs p pl -> abs q ql -> abs (ct_merge p q) al ->
       Permutation al (pl++ql).
  Proof. Admitted.

  Theorem in_order_traversal : forall (l : list nat), (l = (ct_flatten (create_cartesian_tree l))).
  Proof. intros. destruct l.
    - unfold create_cartesian_tree. simpl. reflexivity.
    - unfold create_cartesian_tree. Admitted.

  Definition key := nat.
  Definition insert := ct_insert.
  Definition priqueue := cartesian_tree.
  Definition empty := ct_empty.
  Definition delete_min := ct_delete_min.
  Definition merge := ct_merge.
  Definition priq := ct.
  Definition Abs := abs.

(*Usei o Let identifier := term
  Em: https://coq.inria.fr/refman/language/gallina-extensions.html#coq:exn.ident-already-exists-let*)

  Let can_relate := can_relate_ct.
  Let abs_perm := abs_perm_ct.
  Let empty_priq := empty_ct.
  Let empty_relate := empty_relate_ct.
  Let insert_priq := insert_ct.
  Let insert_relate := insert_relate_ct.
  Let delete_min_None_relate := delete_min_None_relate_ct.
  Let delete_min_Some_priq := delete_min_Some_ct.
  Let delete_min_Some_relate := delete_min_Some_relate_ct.
  Let merge_priq := merge_ct.
  Let merge_relate := merge_relate_ct.

End CartesianTree.


Require Import Basics.Trunc.
Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.theory.apartness.
Require Export
  HoTT.Classes.theory.rings.

Generalizable Variables F f.

Section field_properties.
Context `{IsField F}.

(* Add Ring F : (stdlib_ring_theory F). *)

Lemma reciperse_alt (x : F) Px : x // (x;Px) = 1.
Proof.
rewrite <-(recip_inverse (x;Px)). trivial.
Qed.

Lemma recip_proper_alt x y Px Py : x = y -> // (x;Px) = // (y;Py).
Proof.
intro E. apply ap.
apply Sigma.path_sigma with E.
apply path_ishprop.
Qed.

Lemma recip_irrelevant x Px1 Px2 : // (x;Px1) = // (x;Px2).
Proof.
apply recip_proper_alt. reflexivity.
Qed.

Lemma apart_0_proper {x y} : x ≶ 0 -> x = y -> y ≶ 0.
Proof.
intros ? E. rewrite <-E. trivial.
Qed.

Global Instance: IsStrongInjective (-).
Proof.
repeat (split; try apply _); intros x y E.
- apply (strong_extensionality (+ x + y)).
  rewrite simple_associativity, left_inverse, plus_0_l.
  rewrite (commutativity (f:=plus) x y), simple_associativity,
    left_inverse, plus_0_l.
  apply symmetry;trivial.
- apply (strong_extensionality (+ -x + -y)).
  rewrite simple_associativity, right_inverse, plus_0_l.
  rewrite (commutativity (f:=plus) (- x) (- y)),
    simple_associativity, right_inverse, plus_0_l.
  apply symmetry;trivial.
Qed.

Global Instance: IsStrongInjective (//).
Proof.
repeat (split; try apply _); intros x y E.
- apply (strong_extensionality (x.1 *.)).
  rewrite recip_inverse, (commutativity (f:=mult)).
  apply (strong_extensionality (y.1 *.)).
  rewrite simple_associativity, recip_inverse.
  rewrite mult_1_l,mult_1_r. apply symmetry;trivial.
- apply (strong_extensionality (.* // x)).
  rewrite recip_inverse, (commutativity (f:=mult)).
  apply (strong_extensionality (.* // y)).
  rewrite <-simple_associativity, recip_inverse.
  rewrite mult_1_l,mult_1_r. apply symmetry;trivial.
Qed.

Global Instance: forall z, StrongLeftCancellation (+) z.
Proof.
intros z x y E. apply (strong_extensionality (+ -z)).
do 2 rewrite (commutativity (f:=plus) z _),
  <-simple_associativity,right_inverse,plus_0_r.
trivial.
Qed.

Global Instance: forall z, StrongRightCancellation (+) z.
Proof.
intros. apply (strong_right_cancel_from_left (+)).
Qed.

Global Instance: forall z, PropHolds (z ≶ 0) -> StrongLeftCancellation (.*.) z.
Proof.
intros z Ez x y E. red in Ez.
rewrite !(commutativity z).
apply (strong_extensionality (.* // (z;(Ez : (≶0) z)))).
rewrite <-!simple_associativity, !reciperse_alt.
rewrite !mult_1_r;trivial.
Qed.

Global Instance: forall z, PropHolds (z ≶ 0) -> StrongRightCancellation (.*.) z.
Proof.
intros. apply (strong_right_cancel_from_left (.*.)).
Qed.

Lemma mult_apart_zero_l x y : x * y ≶ 0 -> x ≶ 0.
Proof.
intros. apply (strong_extensionality (.* y)).
rewrite mult_0_l. trivial.
Qed.

Lemma mult_apart_zero_r x y : x * y ≶ 0 -> y ≶ 0.
Proof.
intros. apply (strong_extensionality (x *.)).
rewrite mult_0_r. trivial.
Qed.

Instance mult_apart_zero x y :
  PropHolds (x ≶ 0) -> PropHolds (y ≶ 0) -> PropHolds (x * y ≶ 0).
Proof.
intros Ex Ey.
apply (strong_extensionality (.* // (y;(Ey : (≶0) y)))).
rewrite <-simple_associativity, reciperse_alt, mult_1_r, mult_0_l.
trivial.
Qed.

Instance: NoZeroDivisors F.
Proof.
intros x [x_nonzero [y [y_nonzero E]]].
assert (~ ~ apart y 0) as Ey.
- intros E';apply y_nonzero,tight_apart,E'.
- apply Ey. intro y_apartzero.
  apply x_nonzero.
  rewrite <- (mult_1_r x). rewrite <- (reciperse_alt y y_apartzero).
  rewrite simple_associativity, E.
  apply mult_0_l.
Qed.

Global Instance : IsIntegralDomain F := {}.

Global Instance apart_0_sig_apart_0: forall (x : ApartZero F), PropHolds (x.1 ≶ 0).
Proof.
intros [??];trivial.
Qed.

Instance recip_apart_zero x : PropHolds (// x ≶ 0).
Proof.
red.
apply mult_apart_zero_r with (x.1).
rewrite recip_inverse. solve_propholds.
Qed.

Lemma field_div_0_l x y : x = 0 -> x // y = 0.
Proof.
intros E. rewrite E. apply left_absorb.
Qed.

Lemma field_div_diag x y : x = y.1 -> x // y = 1.
Proof.
intros E. rewrite E. apply recip_inverse.
Qed.

Lemma equal_quotients (a c: F) b d : a * d.1 = c * b.1 <-> a // b = c // d.
Proof.
split; intro E.
- rewrite <-(mult_1_l (a // b)),
  <- (recip_inverse d),
  (commutativity (f:=mult) d.1 (// d)),
  <-simple_associativity,
  (simple_associativity d.1),
  (commutativity (f:=mult) d.1 a),
  E,
  <-simple_associativity,
  simple_associativity,
  recip_inverse,
  mult_1_r.
  apply commutativity.
- rewrite <-(mult_1_r (a * d.1)),
  <- (recip_inverse b),
  <-simple_associativity,
  (commutativity (f:=mult) b.1 (// b)),
  (simple_associativity d.1),
  (commutativity (f:=mult) d.1),
  !simple_associativity,
  E,
  <-(simple_associativity c),
  (commutativity (f:=mult) (// d)),
  recip_inverse,
  mult_1_r.
  reflexivity.
Qed.

Lemma recip_distr_alt (x y : F) Px Py Pxy :
  // (x * y ; Pxy) = // (x;Px) * // (y;Py).
Proof.
apply (left_cancellation_ne_0 (.*.) (x * y)).
- apply apart_ne;trivial.
- transitivity ((x // (x;Px)) *  (y // (y;Py))).
  + rewrite 3!reciperse_alt,mult_1_r. reflexivity.
  + rewrite <-simple_associativity,<-simple_associativity.
    apply ap.
    rewrite simple_associativity.
    rewrite (commutativity (f:=mult) _ y).
    rewrite <-simple_associativity.
    reflexivity.
Qed.
End field_properties.

(* Due to bug #2528 *)
Hint Extern 8 (PropHolds (// _ ≶ 0)) =>
  eapply @recip_apart_zero : typeclass_instances.
Hint Extern 8 (PropHolds (_ * _ ≶ 0)) =>
  eapply @mult_apart_zero : typeclass_instances.

Section morphisms.
  Context `{IsField F1} `{IsField F2} `{!IsSemiRingStrongPreserving (f : F1 -> F2)}.

(*   Add Ring F1 : (stdlib_ring_theory F1). *)

  Lemma strong_injective_preserves_0 : (forall x, x ≶ 0 -> f x ≶ 0) -> IsStrongInjective f.
  Proof.
  intros E1. split; try apply _. intros x y E2.
  apply (strong_extensionality (+ -f y)).
  rewrite plus_negate_r, <-preserves_minus.
  apply E1.
  apply (strong_extensionality (+ y)).
  rewrite <-simple_associativity,left_inverse,plus_0_l,plus_0_r.
  trivial.
  Qed.

  (* We have the following for morphisms to non-trivial strong rings as well.
    However, since we do not have an interface for strong rings, we ignore it. *)
  Global Instance: IsStrongInjective f.
  Proof.
  apply strong_injective_preserves_0.
  intros x Ex.
  apply mult_apart_zero_l with (f (// exist (≶0) x Ex)).
  rewrite <-rings.preserves_mult.
  rewrite reciperse_alt.
  rewrite (rings.preserves_1 (f:=f)).
  solve_propholds.
  Qed.

  Lemma preserves_recip x Px Pfx : f (// (x;Px)) = // (f x;Pfx).
  Proof.
  apply (left_cancellation_ne_0 (.*.) (f x)).
  - apply apart_ne;trivial.
  - rewrite <-rings.preserves_mult.
    rewrite !reciperse_alt.
    apply preserves_1.
  Qed.
End morphisms.


(****************************************************************
   File: SR_MiniML_equi.v
   Author: Amy Felty

   original: March 2014
   Feb 2021: Current Coq Version: V8.13.1

   Subject Reduction for Call-by-Value Mini-ML using Hybrid
   Example showing why meta-level isterm1 cannot be used for
   equivalence proof of meval and eval
   (the exists/forall quantifier problem).

   Example from:
   [1] Amy Felty and Alberto Momigliano, Hybrid: A Definitional Two Level
   Approach to Reasoning with Higher-Order Abstract Syntax, In Journal
   of Automated Reasoning, 48(1):43-105, 2012.

  ***************************************************************)

From HybridSys Require Export sl.
From HybridSys Require Export MiniML.

(****************************************************************
 ****************************************************************
   Evaluation judgment defined as an inductive definition (meval),
   and associated properties as described in Section 3.3 of [1].
  ****************************************************************
  ****************************************************************)

(****************************************************************
   Evaluation
  ****************************************************************)

Section meval.

Inductive meval: uexp -> uexp -> Prop :=
  meval_App: forall E1':uexp -> uexp, forall E1 E2 V V2:uexp,
               abstr E1' ->
               meval E1 (Fun (fun x => E1' x)) ->
               meval E2 V2 -> meval (E1' V2) V ->
               meval (App E1 E2) V
| meval_Fun: forall E:uexp -> uexp, abstr E ->
               isterm1 nil (Fun (fun x => E x)) ->
               meval (Fun (fun x => E x)) (Fun (fun x => E x))
| meval_Fix: forall E:uexp -> uexp, forall V:uexp,
               abstr E ->
               isterm1 nil (Fix (fun x => E x)) ->
               meval (E (Fix (fun x => E x))) V ->
               meval (Fix (fun x => E x)) V.

End meval.

(****************************************************************
 ****************************************************************
   The two-level encoding of isterm, eval, and hastype judgments
   as in Figure 6 in [1].
  ****************************************************************
  ****************************************************************)

(****************************************************************
   The atm type and instantiation of oo.
  ****************************************************************)

Section encoding.

Inductive atm : Set :=
   typeof : uexp -> tp -> atm
 | eval : uexp -> uexp -> atm
 | isterm : uexp -> atm.

Definition oo_ := oo atm Econ.
Definition atom_ : atm -> oo_ := atom Econ.
Definition T_ : oo_ := T atm Econ.

Hint Unfold oo_ atom_ T_: hybrid.

(****************************************************************
   Definition of prog
  ****************************************************************)

Inductive prog : atm -> oo_ -> Prop :=
  | tabs :
      forall (T1 T2: tp) (E : uexp -> uexp),
      abstr E ->
      prog (typeof (Fun (fun x => E x)) (arrow T1 T2))
        (All (fun x : uexp => Imp (typeof x T1) (atom_ (typeof (E x) T2))))
  | tap :
      forall E1 E2: uexp, forall T T' : tp,
      prog (typeof (App E1 E2) T)
        (Conj (atom_ (typeof E1 (arrow T' T))) (atom_ (typeof E2 T')))
  | tfix :
      forall (T: tp) (E : uexp -> uexp),
      abstr E ->
      prog (typeof (Fix (fun x => E x)) T)
        (All (fun x : uexp => Imp (typeof x T) (atom_ (typeof (E x) T))))
  | eap : forall E1':uexp -> uexp, forall E1 E2 V V2:uexp,
      abstr E1' ->
      prog (eval (App E1 E2) V)
        (Conj (atom_ (eval E1 (Fun (fun x => E1' x))))
         (Conj (atom_ (eval E2 V2))
          (atom_ (eval (E1' V2) V))))
  | eabs : forall E:uexp -> uexp, (abstr E) ->
      prog (eval (Fun (fun x => E x)) (Fun (fun x => E x)))
        (atom_ (isterm (Fun (fun x => E x))))
  | efix : forall E:uexp -> uexp, forall V:uexp,
      abstr E ->
      prog (eval (Fix (fun x => E x)) V)
        (Conj (atom_ (eval (E (Fix (fun x => E x))) V))
         (atom_ (isterm (Fix (fun x => E x)))))
  | exp_app : forall M N:uexp,
      prog (isterm (App M N))
        (Conj (atom_ (isterm M)) (atom_ (isterm N)))
  | exp_lam : forall (E:uexp -> uexp),
      abstr E ->
      prog (isterm (Fun (fun x => (E x))))
        (All (fun x:uexp => (Imp (isterm x) (atom_ (isterm (E x))))))
  | exp_fix : forall (E:uexp -> uexp),
      abstr E ->
      prog (isterm (Fix (fun x => (E x))))
        (All (fun x:uexp => (Imp (isterm x) (atom_ (isterm (E x)))))).

(****************************************************************
   Instantiation of seq
  ****************************************************************)

Definition seq_ : nat -> list atm -> oo_ -> Prop := sl.seq prog.
Definition seq'_ := seq' prog.
Definition seq0 (B : oo_) : Prop := seq'_ nil B.

Hint Unfold seq_ seq'_ seq0: hybrid.

End encoding.

#[global] Hint Unfold oo_ atom_ T_: hybrid.
#[global] Hint Unfold seq_ seq'_ seq0: hybrid.
#[global] Hint Unfold proper: hybrid.
#[global] Hint Resolve proper_Var : hybrid.
#[global] Hint Resolve tabs tap tfix eap eabs efix exp_app exp_lam exp_fix : hybrid.

(****************************************************************
 ****************************************************************
   Version of subject reduction with eval judgments defined as an
   inductive type (meval) as described in Section 4.4 of [1].
  ****************************************************************
  ****************************************************************)

Section meta_sr.

Fixpoint uexp2atm_list (l:list uexp) : list atm :=
  match l with
    | nil => nil
    | (e::l') => (isterm e::(uexp2atm_list l'))
  end.

Lemma memb_isterm: forall (x:uexp) (Gamma: list uexp),
  In x Gamma -> In (isterm x) (uexp2atm_list Gamma).
Proof.
intro x; induction Gamma; simpl; auto.
intros [h | h]; subst; auto.
Qed.

Hint Resolve memb_isterm : hybrid.

Theorem isterm_equiv_isterm1 : forall (E:uexp)(Gamma:list uexp),
 isterm1 Gamma E <->
 exists n:nat, seq_ n (uexp2atm_list Gamma) (atom_ (isterm E)).
intros E Gamma; split.
- induction 1; auto with hybrid.
  (* var case *)
  + generalize H; clear H; case G.
    * simpl; try tauto.
    * intros u l h.
      specialize memb_isterm with (1:=h); intro h'.
      exists 0; unfold seq_,atom_; apply s_init; eauto with hybrid.
  (* App case *)
  + destruct IHisterm1_1 as [i1 h1].
    destruct IHisterm1_2 as [i2 h2].
    exists (i1+i2+1+1+1).
    apply s_bc with (Conj (atom_ (isterm M)) (atom_ (isterm N))); eauto with hybrid.
    apply s_and; auto.
    * apply seq_mono with i1; auto; try lia.
    * apply seq_mono with i2; auto; try lia.
  (* Fun case *)
  (* exists/forall quantification problem *)
  +
Abort.

(* MC-Theorem 25 from [1] *)
Theorem eval_equiv_meval : forall e v:uexp,
 (meval e v) <-> seq0 (atom_ (eval e v)).
Proof.
intros e v; split.
- induction 1; auto with hybrid.
  (* App case *)
  + destruct IHmeval1 as [i1 h1].
    destruct IHmeval2 as [i2 h2].
    destruct IHmeval3 as [i3 h3].
    exists (i1+i2+i3+1+1+1+1).
    unfold seq_,atom_;
      apply s_bc with
          (Conj (atom_ (eval E1 (Fun (fun x => E1' x))))
                (Conj (atom_ (eval E2 V2))
                      (atom_ (eval (E1' V2) V)))); eauto with hybrid.
    apply s_and.
    * apply seq_mono with i1; try lia; auto.
    * apply s_and.
      -- apply seq_mono with i2; try lia; auto.
      -- apply seq_mono with i3; try lia; auto.
  (* Fun case *)
  + exists (0+1).
    unfold seq_,atom_; apply s_bc with (atom_ (isterm (Fun (fun x => E x))));
      eauto with hybrid.
(* need the above failed lemma to continue *)
Abort.

End meta_sr.


Require Import Ynot.
Require Import List String.
Require Import Specif.
Require Import RSep.
Require Import LinkedListSeg.
Require Import Peano_dec.

Set Implicit Arguments.

Module StoreModel.

  (* For now, all columns are nats. *)
  Fixpoint Tuple n {struct n} : Set :=
    match n with
      | 0 => unit
      | S n' => (nat * Tuple n')%type
    end.

  Definition tpl_dec : forall n (a b : Tuple n), {a = b} + {a <> b}.
    refine (fix dec (n : nat) : forall (a b : Tuple n), {a = b} + {a <> b} :=
      match n as n return forall (a b : Tuple n), {a = b} + {a <> b} with
        | 0 => fun a b => left _ _
        | S n' => fun a b =>
          if eq_nat_dec (fst a) (fst b) then
            if dec n' (snd a) (snd b) then left _ _ else right _ _
            else right _ _
      end);
    destruct a; destruct b; simpl in *; subst; auto.
    unfold not in *. intros. inversion H. auto.
    unfold not in *. intros. inversion H. auto.
  Qed.

 Section X.
  Variable n: nat.

  (* For now, a store is just a single table. *)
  Definition Table : Set := list (Tuple n).

  Definition WHERE := Tuple n -> bool.
  Definition UPDATE := Tuple n -> option (Tuple n).
  Definition AGGREGATE (T : Type) := T -> Tuple n -> T.

  Fixpoint select (wh : WHERE) (rows : Table) {struct rows} : Table :=
    match rows with
      | nil => nil
      | a :: r =>
        if wh a then
          a :: select wh r
        else
          select wh r
    end.

  Fixpoint update (up : UPDATE) (rows : Table) {struct rows} : Table :=
    match rows with
      | nil => nil
      | a :: r => match up a with
                    | None => update up r
                    | Some x => x :: update up r
                  end
    end.

  (** foldr **)
  Fixpoint aggregate (T : Type) (agg : AGGREGATE T) (v : T) (rows : Table) {struct rows} : T :=
    match rows with
      | nil => v
      | a :: b => agg (aggregate agg v b) a
    end.

  (** SELECT properties **)
  Theorem select_just : forall tbl tbl' wh,
    select wh tbl = tbl' ->
    (forall tpl, In tpl tbl' -> wh tpl = true /\ In tpl tbl).
    induction tbl; intros.
      simpl in H. rewrite <- H in *. inversion H0.
      simpl in H. remember (wh a) as RM. destruct RM. rewrite <- H in H0. simpl in H0. destruct H0.
        subst. split; auto. unfold In; auto.
        destruct tbl'. inversion H. inversion H. rewrite H3 in H0. destruct (IHtbl tbl' wh H3 tpl H0). split; auto. unfold In. right. auto.
      destruct (IHtbl tbl' wh H tpl H0). split; auto. unfold In; auto.
  Qed.

  Lemma tpl_eq : forall (a b : Tuple n), {a = b} + {a <> b}.
     induction n; simpl in *. decide equality.
       intros. destruct a. destruct b. pose (IHn0 t t0). destruct s. rewrite e.
       assert ({n1 = n2} + {n1 <> n2}). decide equality.
       destruct H. rewrite e0; auto. right; auto. unfold not. intros. inversion H. congruence.
       right. unfold not; intros. inversion H. congruence.
  Qed.

  Theorem select_all : forall tbl tbl' wh,
    select wh tbl = tbl' ->
    (forall tpl, In tpl tbl -> wh tpl = true -> In tpl tbl').
    induction tbl; intros.
      inversion H0.
      simpl in H. destruct (tpl_eq a tpl). subst. rewrite H1 in *. unfold In; auto.
      simpl in H0. destruct (wh a). destruct tbl'. congruence. inversion H. simpl. right. destruct H0. congruence. eapply IHtbl; auto; try eassumption.
      eapply IHtbl in H; auto. eassumption. destruct H0. congruence. auto. auto.
  Qed.

End X.

  Definition PROJECT (n n' : nat) := Tuple n -> Tuple n'.

  Lemma zleast : forall x, x < 0 -> False.
    intros. omega.
  Qed.

  Definition GET_COL' : forall (n c : nat) (pf : c < n), PROJECT n 1.
    refine (fix GET_COL (n c : nat) (pf : c < n) {struct n} : PROJECT n 1 :=
      match n as n' return n = n' -> c < n' -> PROJECT n' 1 with
        | 0 => fun _ pf' _ => False_rect _ (zleast pf')
        | S n' => fun _ _ tpl => match c as c' return c = c' -> Tuple 1 with
                                 | 0 => fun _ => (fst tpl, tt)
                                 | S c' => fun pf' => @GET_COL n' c' _ (snd tpl)
                               end (refl_equal _)
      end (refl_equal _) pf).
    omega.
  Defined.

  Definition GET_COL : forall (n c : nat) (pf : c < n), PROJECT n 1 := GET_COL'.

  Fixpoint PROJ (n : nat) (cols : list (sig (fun x:nat => x < n))) {struct cols} : PROJECT n (List.length cols) :=
    match cols as cols' return cols = cols' -> PROJECT n (List.length cols') with
      | nil => fun _ _ => tt
      | a :: b => fun _ tpl =>
        (fst (GET_COL (proj2_sig a) tpl), PROJ b tpl)
    end (refl_equal _).

  (** map **)
  Fixpoint project (n n' : nat) (proj : PROJECT n n') (rows : Table n) {struct rows} : Table n' :=
    match rows with
      | nil => nil
      | a :: b => (proj a) :: project proj b
    end.

  (** GET_COL Properties **)
  Fixpoint get_col (n c : nat) (tpl : Tuple n) {struct n} : option nat :=
    match n as n' return Tuple n' -> option nat
      with
      | 0 => fun _ => None
      | S n' => fun tpl => match c with
                             | 0 => Some (fst tpl)
                             | S c' => get_col n' c' (snd tpl)
                           end
    end tpl.

  Theorem GET_COL_projs : forall n c t pf,
    Some (fst (@GET_COL n c pf t)) = get_col n c t.
    unfold GET_COL.
    induction n.
      intros. elimtype False. omega.
      intros. Set Printing All. destruct c. reflexivity.
      simpl. unfold GET_COL'. auto.
  Qed.

End StoreModel.

Module TableSerializer.

Section Serialize.
  Import StoreModel.

  Fixpoint toString (n : nat) : string :=
    match n with
      | 0 => "*"%string
      | S n => String "1" (toString n)
    end.

  Fixpoint st (n' : nat) (t : Tuple n') {struct n'} : string :=
    (match n' as n'
       return Tuple n' -> string with
       | 0    => fun _ => "#"
       | S n' => fun t => toString (fst t) ++ st n' (snd t)
     end t)%string.

  Fixpoint serial' n (m : Table n) {struct m} : string :=
    match m with
      | nil => ""
      | f :: r => st n f ++ serial' r
    end%string.

  Definition serial n (m : Table n) : string :=
    (toString (List.length m) ++ ":" ++ serial' m)%string.

  Fixpoint fromString (s : string) : option (nat * string) :=
    match s with
      | EmptyString => None
      | String "1" s' => match fromString s' with
                           | None => None
                           | Some (x,y) => Some (S x, y)
                         end
      | String "*" b => Some (0, b)
      | String _ b => None
    end.

  Fixpoint dt n (str : string) {struct n} : option (Tuple n * string) :=
    match n as n, str return option (Tuple n * string) with
      | 0, String "#" str' => Some (tt, str')
      | S n', str => match fromString str with
                  | None => None
                  | Some (v,r) => match dt n' r with
                                    | None => None
                                    | Some (vr,r) => Some ((v,vr), r)
                                  end
                end
      | _,_ => None
    end.

  Fixpoint deserial' (n cnt : nat) (str : string) {struct cnt} : option (Table n) :=
    match cnt, str with
      | 0, EmptyString => Some nil
      | S cnt', s => match dt n s with
                       | None => None
                       | Some (t,sr) => match deserial' n cnt' sr with
                                          | None => None
                                          | Some tbl => Some (t :: tbl)
                                        end
                     end
      | _,_ => None
    end.

  Definition deserial n (str : string) : option (Table n) :=
    match fromString str with
      | Some (cnt,String ":" s) => deserial' n cnt s
      | _ => None
    end.

  Lemma fromString_toString : forall n s,
    fromString (toString n ++ s) = Some (n,s).
    induction n; intros;
      [ reflexivity
      | simpl; rewrite (IHn s); trivial ].
  Qed.

  Lemma str_app_ass : forall (a b c : string),
    ((a ++ b) ++ c = a ++ (b ++ c))%string.
    induction a; intros;
      [ reflexivity
      | simpl; rewrite (IHa b c); trivial ].
  Qed.

  Lemma dt_st : forall n t s,
    dt n (st n t ++ s) = Some (t,s).
    induction n; intros; simpl in *.
      destruct t; trivial.
      rewrite str_app_ass. rewrite fromString_toString. pose (IHn (snd t) s). simpl in *. unfold Tuple in *. rewrite e. fold Tuple in *.
        assert (t = (fst t, snd t)). destruct t; auto. rewrite H. reflexivity.
  Qed.

  Lemma serial_deserial' : forall n (tbl : Table n) cnt,
    List.length tbl = cnt ->
    deserial' n cnt (serial' tbl) = Some tbl.
    induction tbl; intros cnt H; simpl in H; rewrite <- H.
      reflexivity.
      destruct n. simpl. pose (IHtbl (List.length tbl) (refl_equal (List.length tbl))). simpl in *. rewrite e. destruct a. reflexivity.
      simpl. rewrite str_app_ass. rewrite fromString_toString. rewrite dt_st. pose (IHtbl (List.length tbl) (refl_equal (List.length tbl))). simpl in *. rewrite e.
      assert (a = (fst a, snd a)). destruct a; auto. rewrite H0; auto.
  Qed.

  Theorem serial_deserial : forall n (tbl : Table n),
    deserial n (serial tbl) = Some tbl.
    intros; unfold serial, deserial; rewrite fromString_toString; simpl; apply serial_deserial'; trivial.
  Qed.
End Serialize.

End TableSerializer.

Module Type Store.

  Export  StoreModel.

  Open Local Scope hprop_scope.

  (** Concrete type **)
  Parameter t : Set.

  Section X.
  Variable n : nat.

  (** Representation heap predicate **)
  Parameter rep : t -> Table n -> hprop.

  Parameter new : STsep (__) (fun r:t => rep r nil).
  Parameter free : forall (r : t) (m : [Table n]),
    STsep (m ~~ rep r m) (fun _:unit => __).

  Parameter select : forall (r : t) (wh : WHERE n) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun res:Table n => m ~~ rep r m * [res = select wh m]).

  Parameter update : forall (r : t) (up : UPDATE n) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun _:unit => m ~~ rep r (update up m)).

  Parameter insert : forall (r : t) (new_rows : Table n) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun _:unit => m ~~ rep r (m ++ new_rows)).

  Parameter aggregate : forall (T : Type) (r : t) (agg : AGGREGATE n T) (v : T) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun res:T => m ~~ rep r m * [res = aggregate agg v m]).

  Parameter serial : forall (m : Table n), string.
  Parameter deserial : forall (s : string), option (Table n).
  Parameter serial_deserial : forall (tbl : Table n),
    deserial (serial tbl) = Some tbl.

  Parameter serialize : forall (r : t) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun str:string => m ~~ rep r m * [str = serial m]).
  Parameter deserialize : forall (r : t) (s : string),
    STsep (@rep r nil)
          (fun m:option [Table n] =>
	      match m with
	  	| None => @rep r nil * [None = deserial s]
		| Some m => m ~~ rep r m * [Some m = deserial s]
              end).
End X.

  Parameter project : forall (n n' : nat) (r : t) (proj : PROJECT n n') (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun res:t * [Table n'] => m ~~ hprop_unpack (snd res) (fun m' =>
            rep r m * rep (fst res) m' * [m' = project proj m])).

End Store.

Module RefStore : Store.
  Export StoreModel.

  Open Local Scope hprop_scope.
  Open Local Scope stsepi_scope.

  Definition t := ptr.

  Section Size.
    Variable n : nat.

  Definition rep (n : nat) (p : t) (m : Table n) := p --> m.

  Ltac s := unfold t, rep; sep fail auto.

  Definition new : STsep (__) (fun r:t => @rep n r nil).
    intros; refine (n <- New (@nil (Tuple n));
            {{Return n}});
    s.
  Qed.

  Definition free : forall (r : t) (m : [Table n]),
    STsep (m ~~ @rep n r m) (fun _:unit => __).
    intros; refine {{Free r}};
    s.
  Qed.

  Definition select : forall (r : t) (wh : WHERE n) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun res:Table n => m ~~ rep r m * [res = select wh m]).
    intros; refine (
      v <- !r;
      {{Return (select wh v)}});
    s.
  Qed.

  Definition update : forall (r : t) (up : UPDATE n) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun _:unit => m ~~ rep r (update up m)).
    intros; refine (
      v <- !r ;
      r ::= update up v;;
      {{Return tt}});
    s.
  Qed.

  Definition insert : forall (r : t) (new_rows : Table n) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun _:unit => m ~~ rep r (m ++ new_rows)).
    intros; refine (
      v <- !r ;
      r ::= v ++ new_rows;;
      {{Return tt}});
    s.
  Qed.

  Definition aggregate : forall (T : Type) (r : t) (agg : AGGREGATE n T) (v : T) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun res:T => m ~~ rep r m * [res = aggregate agg v m]).
    intros; refine (
      m <- !r ;
      {{ Return (aggregate agg v m) }});
    s.
  Qed.

  Definition serial := TableSerializer.serial.
  Definition deserial := TableSerializer.deserial.
  Definition serial_deserial := TableSerializer.serial_deserial.

  Definition serialize : forall (r : t) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun str:string => m ~~ rep r m * [str = serial m]).
    intros; refine (
      v <- !r ;
      {{Return (serial v)}}).
    unfold rep. instantiate (1 := (fun v => m ~~ [v = m])). sep fail auto.
    s.
    s.
    s.
  Qed.

  Definition deserialize : forall (r : t) (s : string),
    STsep (@rep n r nil)
          (fun m:option [Table n] =>
	      match m with
	  	| None => @rep n r nil * [None = deserial n s]
		| Some m => m ~~ rep r m * [Some m = deserial n s]
              end).
    intros; refine (
      {{match deserial n s as d
          return STsep (r --> nil * [d = deserial n s])
                       (fun m:option [Table n] =>
	                 match m with
	  	           | None => @rep n r nil * [None = deserial n s]
		           | Some m => m ~~ rep r m * [Some m = deserial n s]
                         end)
          with
          | None => {{Return None}}
          | Some m => r ::= m ;;
                      {{Return (Some [m]%inhabited)}}
        end}});
    solve [ do 2 (unfold Table in *; simpl in *; s) ].
  Qed.
End Size.

  Definition project : forall (n n' : nat) (r : t) (proj : PROJECT n n') (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun res:t * [Table n'] => m ~~ hprop_unpack (snd res)
             (fun m' => rep r m * rep (fst res) m' * [m' = project proj m])).
    intros. refine (
      m <- !r ;
      let m' := project proj m in
      r' <- New m' ;
      {{ Return (r', inhabits m') }});
    try solve [ unfold t, rep; sep fail auto ].
    rsep fail auto. rewrite H1 in *. simpl in H2. rewrite <- (pack_injective H2).
    sep fail auto.
  Qed.

End RefStore.

Module ListStore : Store.
  Import StoreModel.

  Open Local Scope hprop_scope.
  Open Local Scope stsepi_scope.

  Definition t := ptr.

Section Parametric.
  Variable n : nat.
  Definition R := HeapLinkedListSeg (Tuple n).

  Definition llistR := @llist (Tuple n) R.
  Definition nil_empty := @nil_empty (Tuple n) R.
  Hint Unfold llistR.
  Hint Resolve nil_empty.
  Lemma empty_list : __ ==> llistR None nil.
    unfold llistR. unfold llist. sep fail auto.
  Qed.
  Hint Resolve empty_list.

  Definition rep (p : t) (m : Table n) := Exists d :@ LinkedList R, p --> d * llistR d m.

  Ltac s := unfold llistR, t, rep, llist; sep fail auto.

  Definition new : STsep (__) (fun r:t => rep r nil).
    refine (
      tbl <- empty R;
      n <- New tbl;
      {{ Return n }});
    s.
  Qed.

  Definition free : forall (r : t) (m : [Table n]),
    STsep (m ~~ rep r m) (fun _:unit => __).
    refine (fun r m =>
      tbl <- !r;
      @freeList (Tuple n) R tbl None m <@> (r --> tbl);;
      {{Free r}});
    s.
  Qed.

  Definition select : forall (r : t) (wh : WHERE n) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun res:Table n => m ~~ rep r m * [res = select wh m]).
    refine (fun r wh m =>
      tbl <- !r;
      v <- @elements (Tuple n) R tbl None m <@> (r --> tbl);
      {{Return (select wh v)}});
    s.
  Qed.

  Definition updateDelegate (up : UPDATE n) (tpl : Tuple n) :=
    match up tpl with
      | None => Del (Tuple n)
      | Some tpl' => Update tpl'
    end.

  Theorem update_to_proc : forall (up : UPDATE n) (x : Table n),
    process_model x (updateDelegate up) = update up x.
    induction x;
      [ reflexivity
      | unfold updateDelegate, process_model, update in *; destruct (up a); rewrite IHx; trivial ].
  Qed.

  Definition update : forall (r : t) (up : UPDATE n) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun _:unit => m ~~ rep r (update up m)).
    refine (fun r up m =>
      tbl <- !r ;
      tbl' <- process tbl None (updateDelegate up) m <@> (r --> tbl);
      r ::= tbl' ;;
      {{Return tt}});
    solve [ s; rewrite update_to_proc; s ].
  Qed.

  Definition to_heap : forall (r : Table n),
    STsep (__)
          (fun res:LinkedList R => llistR res r).
    refine (fun r =>
      Fix (fun _ => __)
          (fun r res => llistR res r)
          (fun self r =>
            match r as r
              return STsep (__) (fun res => llistR res r)
              with
              | nil => {{empty R}}
              | a :: b =>
                res' <- self b;
                {{@cons (Tuple n) R a res' [None] [b]}}
            end)
          r);
    solve [ s ].
  Qed.

  Definition insert : forall (r : t) (new_rows : Table n) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun _:unit => m ~~ rep r (m ++ new_rows)).
    unfold Table; refine (fun r new_rows m =>
      tbl <- !r ;
      new_rows' <- to_heap new_rows <@> _ ;
      tbl' <- @append (Tuple n) R tbl new_rows' m [new_rows] <@> (r --> tbl);
      r ::= tbl' ;;
      {{Return tt}});
    solve [ s ].
  Qed.

  Lemma foldr_aggregate : forall T x v agg,
    foldr_model (fun (a : Tuple n) (b : T) => agg b a) x v = aggregate agg v x.
    induction x. reflexivity. intros. simpl. rewrite IHx; auto.
  Qed.

  Definition aggregate : forall (T : Type) (r : t) (agg : AGGREGATE n T) (v : T) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun res:T => m ~~ rep r m * [res = aggregate agg v m]).
    Hint Resolve foldr_aggregate.
    refine (fun T r agg v m =>
      tbl <- !r ;
      res <- foldr_f tbl None (fun a b => agg b a) m v <@> (r --> tbl) ;
      {{ Return res }});
    s.
  Qed.

  Definition serial := TableSerializer.serial.
  Definition deserial := TableSerializer.deserial.
  Definition serial_deserial := TableSerializer.serial_deserial.

  Lemma ser_impl : forall (ls : Table n) data,
    data = foldr_model (fun a s => (TableSerializer.st n a ++ fst s, S (snd s))%string) ls (EmptyString, 0)
    -> snd data = List.length ls /\ fst data = TableSerializer.serial' ls.
    split; generalize dependent data;
    (induction ls;
      [ intros; destruct data; simpl in *; inversion H; firstorder
      | intros; simpl in H;
        rewrite (IHls (foldr_model
          (fun (a : Tuple n) (s : string * nat) =>
            ((TableSerializer.st n a ++ fst s)%string, S (snd s)))
          ls (""%string, 0)) (refl_equal _)) in H; destruct data; inversion H; reflexivity ]).
  Qed.

  Definition serialize : forall (r : t) (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun str:string => m ~~ rep r m * [str = serial m]).
    refine (fun r m =>
      v <- !r;
      data <- foldr_f v None (fun a s => (TableSerializer.st n a ++ fst s, 1 + snd s)%string) m (EmptyString,0) <@> _ ;
      {{Return (TableSerializer.toString (snd data) ++ ":" ++ fst data)%string}});
    s.
    match goal with
      | [ x : Table n, H : (?X,?Y) = _ |- _ ] =>
        let H' := fresh "H" in
        pose (H' := ser_impl x H); inversion H'; simpl in *
    end. subst. unfold serial. unfold TableSerializer.serial. s.
  Qed.

  Definition deserialize : forall (r : t) (s : string),
    STsep (rep r nil)
          (fun m:option [Table n] =>
	      match m with
	  	| None => rep r nil * [None = deserial n s]
		| Some m => m ~~ rep r m * [Some m = deserial n s]
              end).
    refine (fun r s =>
      {{match deserial n s as d
          return STsep (rep r nil * [d = deserial n s])
                       (fun m:option [Table n] =>
	                 match m with
	  	           | None => rep r nil * [None = deserial n s]
		           | Some m => m ~~ rep r m * [Some m = deserial n s]
                         end)
          with
          | None => {{Return None}}
          | Some m => hp <- to_heap m <@> _ ;
                      r ::= hp ;;
                      {{Return (Some [m]%inhabited)}}
        end}});
    solve [ do 2 (unfold Table in *; simpl in *; s)
          | s; seprw (@nil_empty (Tuple n) v0 None); s ].
  Qed.

End Parametric.

  Ltac s := unfold t, rep, llist; sep fail auto.

  Definition project : forall (n n' : nat) (r : t) (proj : PROJECT n n') (m : [Table n]),
    STsep (m ~~ rep r m)
          (fun res:t * [Table n'] => m ~~ hprop_unpack (snd res)
             (fun m' => rep r m * rep (fst res) m' * [m' = project proj m])).
    refine (fun n n' r proj m =>
      let R' := HeapLinkedListSeg (Tuple n') in
      acc <- empty R' <@> _ ;
      tbl <- !r ;
      tbl' <- foldr tbl None
              (fun rr c => @llseg (Tuple n') R' rr None (project proj c))
              (fun rr v m =>
                res <- @cons (Tuple n' ) R' (proj v) rr (inhabits None) (m ~~~ project proj m) ;
                {{ Return res }})
              m acc <@> (r --> tbl) ;
      res <- New tbl' ;
      {{ Return (res, (m ~~~ project proj m)) }}
    );
    solve [ s ].
  Qed.

End ListStore.

Require Export LinkedListSeg.


Require Export TopologicalSpaces.
Require Export Subbases.
Require Export InverseImage.
Require Export Continuity.
Require Export Nets.

Section WeakTopology.

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

Inductive weak_topology_subbasis : Family X :=
  | intro_fa_inv_image: forall (a:A) (V:Ensemble (point_set (Y a))),
    open V -> In weak_topology_subbasis (inverse_image (f a) V).

Definition WeakTopology : TopologicalSpace :=
  Build_TopologicalSpace_from_subbasis X weak_topology_subbasis.

Lemma weak_topology_makes_continuous_funcs:
  forall a:A, continuous (f a) (X:=WeakTopology).
Proof.
intro.
red; intros.
pose proof (Build_TopologicalSpace_from_subbasis_subbasis
  _ weak_topology_subbasis).
apply H0.
constructor; trivial.
Qed.

Lemma weak_topology_is_weakest: forall (T':Family X)
  (H1:_) (H2:_) (H3:_),
  (forall a:A, continuous (f a)
     (X := Build_TopologicalSpace X T' H1 H2 H3)) ->
  forall U:Ensemble X, @open WeakTopology U -> T' U.
Proof.
intros.
destruct H0.
apply H1.
intros.
apply H0 in H4.
induction H4.
exact H3.
destruct H4.
apply H; trivial.
apply H2; trivial.
Qed.

Section WeakTopology_and_Nets.

Variable I:DirectedSet.
Hypothesis I_nonempty: inhabited (DS_set I).
Variable x:Net I WeakTopology.
Variable x0:X.

Lemma net_limit_in_weak_topology_impl_net_limit_in_projections :
  net_limit x x0 ->
  forall a:A, net_limit (fun i:DS_set I => (f a) (x i)) ((f a) x0).
Proof.
intros.
apply continuous_func_preserves_net_limits; trivial.
apply continuous_func_continuous_everywhere.
apply weak_topology_makes_continuous_funcs.
Qed.

Lemma net_limit_in_projections_impl_net_limit_in_weak_topology :
  (forall a:A, net_limit (fun i:DS_set I => (f a) (x i))
                         ((f a) x0)) ->
  net_limit x x0.
Proof.
intros.
red; intros.
Require Import FiniteIntersections.
assert (@open_basis WeakTopology
        (finite_intersections weak_topology_subbasis)).
apply Build_TopologicalSpace_from_open_basis_basis.
destruct (open_basis_cover _ H2 x0 U) as [V [? [? ?]]]; trivial.
assert (for large i:DS_set I, In V (x i)).
clear H4.
induction H3.
destruct I_nonempty.
exists X0; constructor.

destruct H3.
destruct H5.
apply eventually_impl_base with (fun i:DS_set I => In V (f a (x i))).
intros.
constructor; trivial.
apply H; trivial.

apply eventually_impl_base with
  (fun i:DS_set I => In U0 (x i) /\ In V (x i)).
intros.
destruct H6.
constructor; trivial.
destruct H5.
apply eventually_and;
  (apply IHfinite_intersections || apply IHfinite_intersections0);
  trivial.

refine (eventually_impl_base _ _ _ H6).
intro; apply H4.
Qed.

End WeakTopology_and_Nets.

End WeakTopology.

Implicit Arguments WeakTopology [[X] [Y] [A]].
Implicit Arguments weak_topology_subbasis [[X] [Y] [A]].

Section WeakTopology1.

Variable X:Type.
Variable Y:TopologicalSpace.
Variable f:X->point_set Y.

Definition WeakTopology1 := WeakTopology (True_rect f).

Lemma weak_topology1_topology:
  forall U:Ensemble X, @open WeakTopology1 U ->
  exists V:Ensemble (point_set Y), open V /\ U = inverse_image f V.
Proof.
intros.
red in H.
simpl in H.
destruct H.
assert (forall U:Ensemble X,
  In (finite_intersections (weak_topology_subbasis (True_rect f))) U ->
  exists V:Ensemble (point_set Y), open V /\ U = inverse_image f V).
intros.
induction H0.
exists Full_set.
split.
apply open_full.
rewrite inverse_image_full.
trivial.
destruct H0.
destruct a.
simpl.
exists V.
split; trivial.

destruct IHfinite_intersections as [V1 [? ?]].
destruct IHfinite_intersections0 as [V2 [? ?]].
exists (Intersection V1 V2).
split.
auto with topology.
rewrite H3; rewrite H5.
rewrite inverse_image_intersection.
trivial.

Require Import ClassicalChoice.
destruct (choice (fun (U:{U:Ensemble X | In F U}) (V:Ensemble (point_set Y))
  => open V /\ proj1_sig U = inverse_image f V)) as [choice_fun].
intros.
destruct x as [U].
simpl.
apply H0; auto with sets.
exists (IndexedUnion choice_fun).
split.
apply open_indexed_union.
apply H1.
apply Extensionality_Ensembles; split; red; intros.
destruct H2.
constructor.
exists (exist _ S H2).
pose proof (H1 (exist _ S H2)).
destruct H4.
simpl in H5.
rewrite H5 in H3.
destruct H3.
exact H3.

destruct H2.
inversion H2.
pose proof (H1 a).
destruct H5.
destruct a as [U].
exists U; trivial.
simpl in H6.
rewrite H6.
constructor.
exact H3.
Qed.

Lemma weak_topology1_makes_continuous_func:
  continuous f (X:=WeakTopology1).
Proof.
exact (weak_topology_makes_continuous_funcs _ _ _ (True_rect f) I).
Qed.

End WeakTopology1.

Implicit Arguments WeakTopology1 [[X] [Y]].


From mathcomp Require Import ssreflect.

Require Import set_notations.

Import SetNotations.
Export SetNotations.

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

Module PowersetNotations.

  (* {C ∈ Power(X)| P(C)}, P(C) = A ⊂ C *)
  Inductive sigPE (U:Type) (X:Ensemble U) (P:Ensemble U -> Prop) :
    Ensemble (Ensemble U) :=
    Definition_of_Intensive_Power_set:
      forall C:Ensemble U, P C ->
                           (Included U C X -> In (Ensemble U) (sigPE X P) C).

  Notation "{ X |^ P }" := (sigPE X P).

End PowersetNotations.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable deflessthan_1 : (forall A B C D : Universe, (exists X : Universe, (lt_ A B C D -> (betS_ C X D /\ cong_ C X A B)))).
Variable deflessthan2_2 : (forall A B C D X : Universe, ((betS_ C X D /\ cong_ C X A B) -> lt_ A B C D)).
Variable lemma_betweennotequal_3 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable axiom_nocollapse_4 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).
Variable lemma_localextension_5 : (forall A B Q : Universe, (exists X : Universe, ((A <> B /\ B <> Q) -> (betS_ A B X /\ cong_ B X B Q)))).
Variable axiom_betweennesssymmetry_6 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_extension_7 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable axiom_betweennessidentity_8 : (forall A B : Universe, ~(betS_ A B A)).
Variable lemma_inequalitysymmetric_9 : (forall A B : Universe, (A <> B -> B <> A)).
Variable cn_equalityreverse_10 : (forall A B : Universe, cong_ A B B A).
Variable lemma_congruencetransitive_11 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable cn_sumofparts_12 : (forall A B C E F G : Universe, ((cong_ A B E F /\ (cong_ B C F G /\ (betS_ A B C /\ betS_ E F G))) -> cong_ A C E G)).
Variable lemma_congruencesymmetric_13 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable axiom_innertransitivity_14 : (forall A B C D : Universe, ((betS_ A B D /\ betS_ B C D) -> betS_ A B C)).
Variable axiom_5_line_15 : (forall A B C D E F G H : Universe, ((betS_ A B C /\ (betS_ E F G /\ (cong_ B C F G /\ (cong_ A D E H /\ (cong_ B D F H /\ cong_ A B E F))))) -> cong_ D C H G)).
Variable lemma_doublereverse_16 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable lemma_betweennesspreserved_17 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (cong_ B C Xb Xc /\ betS_ A B C))) -> betS_ Xa Xb Xc)).

Theorem lemma_lessthancongruence_18 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ C D E F) -> lt_ A B E F)).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Implicit Arguments.

Require Import Arith.Peano_dec.
Require Import Coq.Lists.List.
Open Local Scope list_scope.

(* TODO(arjun): try to Require Export ListNotations (submodule of List) instead. *)
Notation "[ a ; .. ; b ]" := (a :: .. (b :: nil) ..) : list_scope.

Definition Eqdec (A : Type) :=
  forall (x y : A), { x = y } + { x <> y }.

Definition second {A B C: Type} (f : B -> C) (pair : (A * B)) :=
  match pair with
    | (a,b) => (a, (f b))
  end.

(** Types with decidable equality. Doesn't this type class already exist?
 * I just can't find it... *)
Class Eq (a : Type) := {
  eqdec : forall (x y : a), { x = y } + { ~ x = y }
}.

Definition beqdec { A : Type } { E : Eq A } (x y : A) := match eqdec x y with
  | left _ => true
  | right _ => false
end.

Instance Eq_nat : Eq nat := {
  eqdec := eq_nat_dec
}.

Lemma option_eq : forall { a : Type } { E : Eq a } (x y : option a), { x = y } + { ~ x = y }.
Proof.
  decide equality. apply eqdec.
Defined.

Instance Eq_option `(a : Type, E : Eq a) : Eq (option a) := {
  eqdec := option_eq
}.

Lemma pair_eq : forall { A B : Type } { EqA : Eq A } { EqB : Eq B }
                       (x y : A * B),
                       { x = y } + { ~ x = y }.
Proof.
  decide equality. apply eqdec. apply eqdec.
Defined.

Instance Eq_pair `(A : Type, B : Type, EA : Eq A, EB : Eq B) : Eq (A * B) := {
  eqdec := pair_eq
}.

Lemma list_eq : forall (A : Type) (E : Eq A) (lst1 lst2 : list A),
  { lst1 = lst2 } + { lst1 <> lst2 }.
Proof with auto.
  intros.
  decide equality.
  apply eqdec.
Qed.

Extract Constant list_eq => "(fun _ x y -> x = y)".

Instance Eq_list `(A : Type, E : Eq A) : Eq (list A) := {
  eqdec := list_eq E
}.

Reserved Notation "x == y" (at level 70, no associativity).

Notation "x == y" := (beqdec x y) : of_scope.

Section List.

Definition concat_map {A B : Type} (f : A -> list B) (lst : list A) : list B :=
  fold_right (fun a bs => f a ++ bs) nil lst.

Lemma concat_map_app : forall {A B : Type} (f : A -> list B) (l1 l2 : list A),
  concat_map f (l1 ++ l2) = (concat_map f l1) ++ (concat_map f l2).
Proof with auto.
  intros.
  induction l1.
  simpl...
  simpl.
  rewrite <- app_assoc.
  rewrite -> IHl1...
Qed.

Definition filter_map_body {A B : Type} (f : A -> option B) a bs := match f a with
  | Some b => b :: bs
  | None => bs
end.

Definition filter_map {A B : Type} (f : A -> option B) (lst : list A) :=
  fold_right (filter_map_body f) nil lst.

Lemma filter_map_app : forall (A B : Type) (f : A -> option B) (lst1 lst2 : list A),
  filter_map f (lst1 ++ lst2) = filter_map f lst1 ++ filter_map f lst2.
Proof with auto.
  intros.
  induction lst1...
  simpl.
  rewrite -> IHlst1.
  unfold filter_map_body.
  destruct (f a)...
Qed.

(** inserts [v] after each element. *)
Definition intersperse {A : Type} (v : A) (lst : list A) : list A :=
  fold_right (fun x xs => x :: v :: xs) nil lst.

Lemma nil_cons_false : forall {A : Type} (x : A) (xs : list A),
  nil = xs ++ [x] -> False.
Proof with auto.
  intros.
  destruct xs; simpl in H; inversion H.
Qed.

Hint Resolve nil_cons_false : datatypes.

Lemma cons_tail : forall {A : Type} (x y : A) (l1 l2 : list A),
  l1 ++ [x] = l2 ++ [y] -> l1 = l2 /\ x = y.
Proof with auto with datatypes.
  intros A x y l1.
  induction l1; intros...
Qed.

Hint Resolve cons_tail : datatypes.

End List.


(** This file defines [Algebra]. *)

Require Export
  Coq.Unicode.Utf8
  HoTT.Basics.

Require Import
  HoTT.Types
  HoTT.Spaces.Finite
  HoTT.HProp
  HoTT.HSet
  HoTT.Classes.implementations.list
  HoTT.Classes.implementations.ne_list.

Declare Scope Algebra_scope.

Delimit Scope Algebra_scope with Algebra.

Open Scope Algebra_scope.

Record SymbolTypeOf {Sort : Type} := Build_SymbolTypeTo
  { Arity : Type
  ; sorts_dom : Arity -> Sort
  ; sort_cod : Sort }.

Arguments SymbolTypeOf : clear implicits.
Arguments Build_SymbolTypeTo {Sort}.

(** A [Signature] is used to characterise [Algebra]s. In particular
    a signature specifies which operations (functions) an algebra for
    the signature is expected to provide. A signature consists of
    - A type of [Sort]s. An algebra for the signature must provide
      a type for each [s : Sort].
    - A type of function symbols [Symbol]. For each function symbol
      [u : Symbol], an algebra for the signature must provide a
      corresponding operation.
    - The field [symbol_types σ u] indicates which type the operation
      corresponding to [u] should have. *)

Record Signature := Build_Signature
  { Sort : Type
  ; Symbol : Type
  ; symbol_types : Symbol -> SymbolTypeOf Sort
  ; hset_sort : IsHSet Sort
  ; hset_symbol : IsHSet Symbol }.

Notation SymbolType σ := (SymbolTypeOf (Sort σ)).

Global Existing Instance hset_sort.

Global Existing Instance hset_symbol.

Global Coercion symbol_types : Signature >-> Funclass.

(** An [Algebra] must provide a family of [Carriers σ] indexed by
    [Sort σ]. These carriers are the "objects" (types) of the algebra. *)

(* [Carriers] is a notation because it will be used for an implicit
   coercion [Algebra >-> Funclass] below. *)

Notation Carriers σ := (Sort σ → Type).

Notation DomOperation A w
  := (∀ X : Arity w, A (sorts_dom w X)) (only parsing).

Notation CodOperation A w := (A (sort_cod w)) (only parsing).

Definition Operation {σ} (A : Carriers σ) (w : SymbolType σ) : Type
  := DomOperation A w -> CodOperation A w.

Global Instance trunc_operation `{Funext} {σ : Signature}
  (A : Carriers σ) {n} `{!∀ s, IsTrunc n (A s)} (u : SymbolType σ)
  : IsTrunc n (Operation A u).
Proof.
  apply trunc_forall.
Defined.

Fixpoint CurriedOperation {σ} (A : Carriers σ) (n : nat)
  : (Fin n.+1 → Sort σ) → Type :=
  match n with
  | O => fun sorts => A (sorts (inr tt))
  | S n' => fun sorts =>
      A (sorts (inr tt)) → CurriedOperation A n' (sorts o inl)
  end.

Fixpoint OperationUncurry {σ} (A : Carriers σ) (n : nat)
  : ∀ (sorts : Fin n.+1 → Sort σ),
    CurriedOperation A n sorts →
    Operation A
      {| Arity := Fin n
       ; sorts_dom := sorts o fin_finS_inject n
       ; sort_cod := sorts (fin_max n) |}
  := match n with
     | O => fun _ op _ => op
     | S n' =>
        fun sorts op a =>
          OperationUncurry A n' (sorts o inl) (op (a (inr tt))) (a o inl)
     end.

(** An [Algebra σ] for a signature [σ] consists of a family [carriers :
    Carriers σ] indexed by the sorts [s : Sort σ], and for each symbol
    [u : Symbol σ], an operation of type [Operation carriers (σ u)],
    where [σ u : SymbolType σ] is the symbol type of [u]. *)

Record Algebra {σ : Signature} : Type := Build_Algebra
  { carriers : Carriers σ
  ; operations : ∀ (u : Symbol σ), Operation carriers (σ u)
  ; hset_algebra : ∀ (s : Sort σ), IsHSet (carriers s) }.

Arguments Algebra : clear implicits.

Arguments Build_Algebra {σ} carriers operations {hset_algebra}.

Global Existing Instance hset_algebra.

(** We have a convenient implicit coercion from an algebra to the
    family of carriers. *)
Global Coercion carriers : Algebra >-> Funclass.

Definition SigAlgebra (σ : Signature) : Type
  := {c : Carriers σ
        | { _ : ∀ (u : Symbol σ), Operation c (σ u)
              | ∀ (s : Sort σ), IsHSet (c s) } }.

Lemma issig_algebra (σ : Signature) : SigAlgebra σ <~> Algebra σ.
Proof.
  issig.
Defined.

(** To find a path between two algebras [A B : Algebra σ] it suffices
    to find paths between the carriers and the operations. *)

Lemma path_algebra `{Funext} {σ : Signature} (A B : Algebra σ)
  (p : carriers A = carriers B)
  (q : transport (λ X, ∀ u, Operation X (σ u)) p (operations A)
       = operations B)
  : A = B.
Proof.
  apply (ap (issig_algebra σ)^-1)^-1; cbn.
  apply (path_sigma' _ p).
  refine (transport_sigma p _ @ _).
  apply path_sigma_hprop.
  exact q.
Defined.

Arguments path_algebra {_} {_} (A B)%Algebra_scope (p q)%path_scope.

Lemma path_ap_carriers_path_algebra `{Funext} {σ} (A B : Algebra σ)
  (p : carriers A = carriers B)
  (q : transport (λ X, ∀ u, Operation X (σ u)) p (operations A)
       = operations B)
  : ap carriers (path_algebra A B p q) = p.
Proof.
  unfold path_algebra, path_sigma_hprop, path_sigma_uncurried.
  destruct A as [A a ha], B as [B b hb]; cbn in *.
  destruct p, q; cbn.
  now destruct (center (ha = hb)).
Defined.

Arguments path_ap_carriers_path_algebra {_} {_} (A B)%Algebra_scope (p q)%path_scope.

(** Suppose [p],[q] are paths in [Algebra σ]. To show that [p = q] it
    suffices to find a path [r] between the paths corresponding to
    [p] and [q] in [SigAlgebra σ]. *)

Lemma path_path_algebra_issig {σ : Signature} {A B : Algebra σ} (p q : A = B)
  (r : ap (issig_algebra σ)^-1 p = ap (issig_algebra σ)^-1 q)
  : p = q.
Proof.
  set (e := (equiv_ap (issig_algebra σ)^-1 A B)).
  by apply (@equiv_inv _ _ (ap e) (Equivalences.isequiv_ap _ _)).
Defined.

Arguments path_path_algebra_issig {_} {A B}%Algebra_scope (p q r)%path_scope.

(** If [p q : A = B], then [ap carriers p = ap carriers q] implies [p = q]. *)

Lemma path_path_algebra `{Funext} {σ} {A B : Algebra σ}
  (p q : A = B) (r : ap carriers p = ap carriers q)
  : p = q.
Proof.
  apply path_path_algebra_issig.
  unshelve eapply path_path_sigma.
  - transitivity (ap carriers p); [by destruct p |].
    transitivity (ap carriers q); [exact r | by destruct q].
  - apply hprop_allpath. apply hset_path2.
Defined.

Arguments path_path_algebra {_} {σ} {A B}%Algebra_scope (p q r)%path_scope.

Module algebra_notations.

(** Given [A : Algebra σ] and function symbol [u : Symbol σ], we use
    the notation [u ^^ A] to refer to the corresponding algebra
    operation of type [Operation A (σ u)]. *)

  Global Notation "u ^^ A" := (operations A u)
                              (at level 60, no associativity)
                              : Algebra_scope.

End algebra_notations.


(** Extensionality of the FSets *)
Require Import HoTT HitTactics.
Require Import kuratowski.kuratowski_sets.

(** We prove extensionality via a chain of equivalences.
    We end with proving that equality can be defined with the subset relation.
    From that we can conclude that [FSet A] has decidable equality if [A] has.
*)
Section ext.
  Context {A : Type}.
  Context `{Univalence}.

  Lemma equiv_subset1_l (X Y : FSet A) (H1 : Y ∪ X = X) (a : A) (Ya : a ∈ Y) : a ∈ X.
  Proof.
    apply (transport (fun Z => a ∈ Z) H1 (tr(inl Ya))).
  Defined.

  Lemma equiv_subset1_r X : forall (Y : FSet A), (forall a, a ∈ Y -> a ∈ X) -> Y ∪ X = X.
  Proof.
    hinduction ; try (intros ; apply path_ishprop).
    - intros.
      apply nl.
    - intros b sub.
      specialize (sub b (tr idpath)).
      revert sub.
      hinduction X ; try (intros ; apply path_ishprop).
      * contradiction.
      * intros.
        strip_truncations.
        rewrite sub.
        apply union_idem.
      * intros X Y subX subY mem.
        strip_truncations.
        destruct mem as [t | t].
        ** rewrite assoc, (subX t).
           reflexivity.
        ** rewrite (comm X), assoc, (subY t).
           reflexivity.
    - intros Y1 Y2 H1 H2 H3.
      rewrite <- assoc.
      rewrite (H2 (fun a HY => H3 a (tr(inr HY)))).
      apply (H1 (fun a HY => H3 a (tr(inl HY)))).
  Defined.

  Lemma eq_subset1 X Y : (Y ∪ X = X) * (X ∪ Y = Y) <~> forall (a : A), a ∈ X = a ∈ Y.
  Proof.
    eapply equiv_iff_hprop_uncurried ; split.
    - intros [H1 H2] a.
      apply path_iff_hprop ; apply equiv_subset1_l ; assumption.
    - intros H1.
      split ; apply equiv_subset1_r ; intros.
      * rewrite H1 ; assumption.
      * rewrite <- H1 ; assumption.
  Defined.

  Lemma eq_subset2 (X Y : FSet A) : X = Y <~> (Y ∪ X = X) * (X ∪ Y = Y).
  Proof.
    eapply equiv_iff_hprop_uncurried ; split.
    - intro Heq.
      split.
      * apply (ap (fun Z => Z ∪ X) Heq^ @ union_idem X).
      * apply (ap (fun Z => Z ∪ Y) Heq @ union_idem Y).
    - intros [H1 H2].
      apply (H1^ @ comm Y X @ H2).
  Defined.

  Theorem fset_ext (X Y : FSet A) :
    X = Y <~> forall (a : A), a ∈ X = a ∈ Y.
  Proof.
    apply (equiv_compose' (eq_subset1 X Y) (eq_subset2 X Y)).
  Defined.

  Lemma subset_union (X Y : FSet A) :
    X ⊆ Y -> X ∪ Y = Y.
  Proof.
    hinduction X ; try (intros ; apply path_ishprop).
    - intros.
      apply nl.
    - intros a.
      hinduction Y ; try (intros ; apply path_ishprop).
      + intro.
        contradiction.
      + intros b p.
        strip_truncations.
        rewrite p.
        apply idem.
      + intros X1 X2 IH1 IH2 t.
        strip_truncations.
        destruct t as [t | t].
        ++ rewrite assoc, (IH1 t).
           reflexivity.
        ++ rewrite comm, <- assoc, (comm X2), (IH2 t).
           reflexivity.
    - intros X1 X2 IH1 IH2 [G1 G2].
      rewrite <- assoc.
      rewrite (IH2 G2).
      apply (IH1 G1).
  Defined.

  Lemma subset_union_l (X : FSet A) :
    forall Y, X ⊆ X ∪ Y.
  Proof.
    hinduction X ; try (intros ; apply path_ishprop).
    - apply (fun _ => tt).
    - intros.
      apply (tr(inl(tr idpath))).
    - intros X1 X2 HX1 HX2 Y.
      split ; unfold subset in *.
      * rewrite <- assoc.
        apply HX1.
      * rewrite (comm X1 X2), <- assoc.
        apply HX2.
  Defined.

  Lemma subset_union_equiv
    : forall X Y : FSet A, X ⊆ Y <~> X ∪ Y = Y.
  Proof.
    intros X Y.
    eapply equiv_iff_hprop_uncurried.
    split.
    - apply subset_union.
    - intro HXY.
      rewrite <- HXY.
      apply subset_union_l.
  Defined.

  Lemma subset_isIn (X Y : FSet A) :
    X ⊆ Y <~> forall (a : A), a ∈ X -> a ∈ Y.
  Proof.
    etransitivity.
    - apply subset_union_equiv.
    - eapply equiv_iff_hprop_uncurried ; split.
      * apply equiv_subset1_l.
      * apply equiv_subset1_r.
  Defined.

  Lemma eq_subset (X Y : FSet A) :
    X = Y <~> (Y ⊆ X * X ⊆ Y).
  Proof.
    etransitivity ((Y ∪ X = X) * (X ∪ Y = Y)).
    - apply eq_subset2.
    - symmetry.
      eapply equiv_functor_prod' ; apply subset_union_equiv.
  Defined.
End ext.


(** * IsDiscrete.v: distributions over discrete domains *)
(** Contributed by David Baelde. This has been adapted from Certicrypt :
      Santiago Zanella and Benjmain Grégoire. *)

(* begin hide *)
Add Rec LoadPath "." as ALEA.

Require Export List.
Require Export Arith.
Require Export Prog.
Require Export Setoid.
Require Export Cover.

Open Scope U_scope.

Set Implicit Arguments.
(* end hide *)

(** ** Definition of discrete domains and decidable equalities *)

Class Discrete_domain (A:Type) :=
  { points : nat -> A ;
    points_surj : forall x, exists n, points n = x }.

Class DecidEq (A:Type) :=
  { eq_dec : forall x y : A, { x=y }+{ x<>y } }.

(** ** Useful functions on discrete domains *)
Section Discrete.

  Variable A : Type.
  Hypothesis A_discrete : Discrete_domain A.
  Hypothesis A_decidable : DecidEq A.

  Definition uequiv : A -> MF A := fun a => carac (eq_dec a).

  Lemma cover_uequiv : forall a, cover (eq a) (uequiv a).
  Proof.
    intro a.
    unfold uequiv.
    apply cover_dec.
  Qed.

  (** [not_first_repr k] decide if [points k] is not the first point in is class,
     in that case [points k] is not the representant of the class *)

  Definition not_first_repr k := sigma (fun i => uequiv (points k) (points i)) k.

  Lemma cover_not_first_repr :
   cover (fun k => exc (fun k0 => (k0 < k)%nat /\ (points k) = (points k0))) not_first_repr.
  Proof.
   red; split; intros.
   apply H;[auto | intros k0 (H1, H2)].
   apply Ole_trans with (2:= sigma_le (fun i : nat => uequiv (points x) (points i)) H1).
   rewrite (cover_eq_one _ (cover_uequiv (points x)) H2); trivial.
   unfold not_first_repr; rewrite sigma_zero; trivial; intros.
   apply (cover_elim (cover_uequiv (points x)) (points k)); [auto | | ];
   intros [H4 H5]; trivial.
   elim H; apply exc_intro with k; auto.
  Qed.

  (** [in_classes a] decides if [a] is in relation with one element of [points] *)
  Definition in_classes a := serie (fun k => uequiv a (points k)).

  Definition In_classes a := exc (fun k => a = (points k)).

  Lemma cover_in_classes : cover In_classes in_classes.
  Proof.
   unfold In_classes; red; split; intros.
   apply H;[auto | intros k H1].
   apply Ole_trans with (2:=serie_le (fun k : nat => uequiv x (points k)) k).
   rewrite (cover_eq_one _ (cover_uequiv x) H1); trivial.
   unfold in_classes; rewrite serie_zero; trivial.
   intros k; apply (cover_elim (cover_uequiv x) (points k)); [auto | | ]; intros [H4 H5]; trivial.
    elim H; apply exc_intro with k; trivial.
  Qed.

  (** [in_class a k] decides if [a] is in relation with [points k] and
     [points k] is the representant of it class *)
  Definition in_class a k := [1-] (not_first_repr k) * uequiv (points k) a.

  Definition In_class a k :=
     (points k) = a /\
     (forall k0, (k0 < k)%nat -> ~ (points k = points k0)).

  Lemma cover_in_class : forall a, cover (In_class a) (in_class a).
  Proof.
   unfold in_class, In_class;split;intros.
   destruct H.
   rewrite (cover_eq_one _ (cover_uequiv (points x)) H); Usimpl.
   rewrite (cover_eq_zero _ cover_not_first_repr);[auto| ].
   intros Hex;apply Hex;[auto | intros].
   destruct H1;apply (H0 x0);trivial.
   apply (cover_elim (cover_uequiv (points x)) a);[auto | | ];intros [H1 H2].
   rewrite H2;trivial.
   apply (cover_elim cover_not_first_repr x);[auto | | ];intros [H3 H4].
   elim H;split;trivial.
   red;intros;apply H3.
   apply exc_intro with k0;auto.
   rewrite H4;Usimpl;auto.
  Qed.

  Lemma in_class_wretract : forall x, wretract (in_class x).
  Proof.
   red; intros.
   apply (cover_elim (cover_in_class x) k);[auto | | ];intros [H H0];
   rewrite H0;[auto | ].
   rewrite sigma_zero; [auto | intros].
   destruct H;apply (cover_eq_zero _ (cover_in_class x)).
   intros (H3, H4).
   elim (H2 _ H1).
   transitivity x; auto.
  Qed.

  Lemma in_classes_refl : forall k, in_classes (points k) == 1.
  Proof.
   intros k; apply (cover_eq_one _ cover_in_classes).
   red; intros; apply exc_intro with k; reflexivity.
  Qed.

  Lemma cover_serie_in_class : cover (fun a => exc (In_class a)) (fun a => serie (in_class a)).
  Proof.
   split; intros.
   apply H;[auto | intros k H1].
   apply Ole_trans with (2:=serie_le (in_class x) k).
   rewrite (cover_eq_one _ (cover_in_class x) H1); trivial.
   rewrite serie_zero; trivial.
   intros k; apply (cover_elim (cover_in_class x) k); [auto | | ]; intros [H4 H5]; trivial.
   elim H; apply exc_intro with k; trivial.
  Qed.

  Lemma in_classes_in_class : forall a, in_classes a == serie (in_class a).
  Proof.
   intros a; apply (cover_elim cover_in_classes a); [ auto | | ]; intros [H1 H2].
   rewrite H2; symmetry; apply serie_zero; intros.
   apply (cover_elim (cover_in_class a) k);[auto | | ];intros (H3, H4);rewrite H4;trivial.
   elim H1;destruct H3;apply exc_intro with k;auto.
   rewrite H2.
   assert (exc (In_class a)).
   Focus 2.
   assert (W:= cover_eq_one a cover_serie_in_class H);simpl in W;rewrite W.
   trivial.
     apply H1;[auto | ].
     induction x using Wf_nat.lt_wf_ind; intros.
     apply (cover_elim cover_not_first_repr x); [ auto | | ]; intros [H3 H4].
     apply exc_intro with x; split.
     symmetry; assumption.
     intros k0 Hk0 HR; elim H3.
     apply exc_intro with k0;auto.
     apply H3;[auto | ].
     intros m (H5, H6);apply (H m);eauto.
     transitivity (points x); assumption.
  Qed.

(** ** Any distribtion on a discrete domain is discrete *)
  Variable d : distr A.

  Lemma range_in_classes : range In_classes d.
  Proof.
    unfold range; intros.
    assert (f == fzero A); [| rewrite H0; symmetry; apply mu_zero ].
    intro x; rewrite <- H.
    reflexivity.
    unfold In_classes.
    destruct (points_surj x) as [y Hy].
    apply exc_intro with (x:=y).
    rewrite Hy; reflexivity.
  Qed.

  Definition coeff k := ([1-] (not_first_repr k)) * mu d (uequiv (points k)).

  Lemma mu_discrete : mu d == discrete coeff points.
  Proof.
   intros f; rewrite discrete_simpl.
   unfold coeff.
   transitivity (serie (fun k => mu d (fun a => f a * (in_class a k)))).
   rewrite <- mu_serie_eq.
   unfold serie_fun.
   transitivity (mu d (fun a : A => in_classes a * f a)).
   apply range_cover with (P:= In_classes); trivial.
   apply range_in_classes.
   apply cover_in_classes.
   apply mu_stable_eq; simpl; apply ford_eq_intro; intro a.
   rewrite Umult_sym, serie_mult; [ | apply in_class_wretract].
   Usimpl; apply in_classes_in_class.
   intros; apply wretract_le with (2:=in_class_wretract x); auto.
   apply serie_eq_compat; intros.
   assert (W:= mu_stable_mult d (f (points k) * [1-] not_first_repr k )).
   rewrite Umult_sym, Umult_assoc, <- W.
   apply mu_stable_eq; simpl; apply ford_eq_intro; intros; unfold fmult.
   unfold in_class;rewrite Umult_assoc.
   apply (cover_elim (cover_uequiv (points k)) n); [auto | | ]; intros [H5 H6].
   rewrite H6; repeat Usimpl; trivial.
   rewrite H5; trivial.
  Qed.

  Lemma coeff_retract : wretract coeff.
  Proof.
    unfold coeff,wretract; intros.
    apply (cover_elim cover_not_first_repr k);
      [auto | |
       (* There is a k0<k with the same repr as k, and 0<=anything. *)
       intros (H,H0); rewrite H0; repeat Usimpl; auto].
    intros (H,H0).
    rewrite H0; clear H0; repeat Usimpl.
    rewrite mu_stable_inv_inv.
    apply Uinv_le_compat.
    transitivity
      (sigma (fun k0 : nat => (mu d) (fun x => [1-] not_first_repr k0 * uequiv (points k0) x)) k).
      apply sigma_le_compat; intros k0 Hk0; auto.
      rewrite <- mu_stable_mult.
      reflexivity.
    rewrite <- mu_sigma_eq.
    (* Sum over points represented by k0<k <= sum over points not represented by k. *)
    apply mu_le_compat; [reflexivity|].
    intro x; unfold finv, sigma_fun.
    apply (cover_elim (cover_uequiv (points k)) x); auto; intros (Hx,Hx').
      (* points k <> x : anything <= 1 *)
      rewrite Hx'; auto.
      (* points k = x : our left hand-side is 0 *)
      rewrite sigma_zero; [auto|intros k0 Hk0].
      rewrite (cover_eq_zero _ (cover_uequiv (points k0))); auto.
      intro; apply H.
      apply exc_intro with (x:=k0); auto.
      split; [assumption | transitivity x; auto].
    (* Summing points represented by k0<k is well formed. *)
    red; intros x k0 Hk0.
    apply (cover_elim (cover_uequiv (points k0)) x); auto;
      intros (H',H''); rewrite H''; clear H''; repeat Usimpl; auto.
    apply (cover_elim cover_not_first_repr k0); auto;
      intros (H0,H0'); rewrite H0'; clear H0'; [|auto].
    rewrite sigma_zero; [auto|intros].
    rewrite <- H'.
    rewrite (cover_eq_zero _ (cover_uequiv (points k1))); auto.
    intro Heq; apply H0.
    apply exc_intro with (x:=k1); split.
    auto.
    symmetry; assumption.
  Qed.

  Theorem domain_is_discrete : is_discrete d.
  Proof.
    unfold is_discrete.
    exists (Build_discr coeff_retract points).
    intro f; unfold Probas.Discrete; simpl mu.
    apply mu_discrete.
  Qed.

End Discrete.

Implicit Arguments domain_is_discrete [[A] [A_discrete] [A_decidable]].

(** **  Instances for common discrete and decidable domains *)

Instance nat_discrete : Discrete_domain nat.
Proof.
  refine {| points := fun x => x ; points_surj := _ |}.
  intro x; exists x; reflexivity.
Qed.

Instance nat_decid_eq : DecidEq nat := Build_DecidEq eq_nat_dec.

Definition bool_points := beq_nat 0.
Instance bool_discrete : Discrete_domain bool.
Proof.
  apply Build_Discrete_domain with (points := bool_points).
  intros [|]; [exists 0%nat|exists 1%nat]; reflexivity.
Qed.

Require Import Bool.

Instance bool_decid_eq : DecidEq bool := Build_DecidEq bool_dec.

(** ** Building a bijection between [nat] and [nat * nat] *)
Require Import Even.
Require Import Div2.

Lemma bij_n_nxn_aux : forall k,
 (0 < k)%nat -> sigT (fun (i:nat) => {j : nat | k = (exp2 i * (2 * j + 1))%nat}).
Proof.
 induction k using lt_wf_rec; intros.
 destruct (even_odd_dec k).
 destruct (H (div2 k)) as (i, (j, Heq)).
 apply lt_div2; auto with arith.
 inversion e.
 rewrite <- H1 in H0; inversion H0.
 inversion H1; simpl; auto with arith.
 exists (S i)%nat; exists j.
 rewrite (even_double _ e).
 rewrite Heq; unfold double; simpl exp2; ring.
 exists O; exists (div2 k).
 apply trans_eq with (1:= odd_double _ o).
 unfold double; simpl exp2; ring.
Qed.

Definition bij_n_nxn k :=
 match @bij_n_nxn_aux (S k) (lt_O_Sn k) with
 | existT i (exist j _) => (i, j)
 end.

Lemma mult_eq_reg_l : forall n m p,
 (0 < p -> p * n = p * m -> n = m)%nat.
Proof.
 intros.
 destruct p;[inversion H | ].
 apply le_antisym;
  apply mult_S_le_reg_l with p; rewrite H0; trivial.
Qed.

Lemma even_exp2 : forall n, even (exp2 (S n)).
Proof.
 induction n; simpl.
 repeat constructor.
 apply even_even_plus.
 exact IHn.
 rewrite plus_0_r; exact IHn.
Qed.

Lemma odd_2p1 : forall n, odd (2 * n + 1).
Proof.
 intros; apply odd_plus_r;[ apply even_mult_l | ];
  repeat constructor.
Qed.

Lemma bij_surj : forall i j, exists k,
 bij_n_nxn k = (i, j).
Proof.
 intros i j.
 exists (exp2 i * (2 * j + 1) - 1)%nat.
 unfold bij_n_nxn.
 destruct (bij_n_nxn_aux (lt_O_Sn (exp2 i * (2 * j + 1) - 1))) as (i', (j', H)).
 assert (exp2 i * (2 * j + 1) = exp2 i' * (2 * j' + 1))%nat .
 rewrite <- H.
 assert (0 < exp2 i * (2 * j + 1))%nat; [ | omega].
 apply le_lt_trans with (O * (2 * j + 1))%nat; trivial.
 apply mult_lt_compat_r.
 apply exp2_pos.
 rewrite plus_comm; simpl; auto with arith.
 clear H.
 generalize i j i' j' H0; clear H0 i j i' j'.
 induction i; destruct i'; intros.
 apply mult_eq_reg_l in H0; [ | apply exp2_pos].
 rewrite plus_comm, (plus_comm (2 * j')) in H0.
 apply plus_reg_l in H0; apply mult_eq_reg_l in H0.
 rewrite H0; trivial.
 auto with arith.
 elimtype False.
 apply not_even_and_odd with (exp2 0 * (2 * j + 1))%nat.
 rewrite H0.
 apply even_mult_l; apply even_exp2.
 simpl exp2; rewrite mult_1_l; apply odd_2p1.
 elimtype False.
 apply not_even_and_odd with (exp2 0 * (2 * j' + 1))%nat.
 rewrite <- H0.
 apply even_mult_l; apply even_exp2.
 simpl exp2; rewrite mult_1_l; apply odd_2p1.
 assert (forall k, exp2 (S k) = 2 * exp2 k)%nat by trivial.
 repeat rewrite H, <- mult_assoc in H0.
 apply mult_eq_reg_l in H0; [ | auto with arith].
 assert (W:= IHi _ _ _ H0); injection W; intros; subst; trivial.
Qed.

(** ** The product of two discrete domains is discrete *)
Instance prod_discrete : forall A B,
  Discrete_domain A -> Discrete_domain B -> Discrete_domain (A*B).
Proof.
  intros.
  apply Build_Discrete_domain with
    (points := fun n => let (i,j) := bij_n_nxn n in ((points i, points j):A*B)).
  intros (x,y).
  destruct (points_surj x) as (x',Hx').
  destruct (points_surj y) as (y',Hy').
  destruct (bij_surj x' y') as (n,Hn).
  exists n.
  rewrite Hn; simpl; rewrite Hx'; rewrite Hy'; reflexivity.
Qed.