Require Export Smallstep_J.

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

Hint Constructors refl_step_closure.
Hint Resolve beq_id_eq beq_id_false_not_eq.

Definition astep_many st := refl_step_closure (astep st).
Notation "t '/' st '==>a*' t'" := (astep_many st t t')
                                    (at level 40, st at level 39).

Example astep_example1:
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state ==>a* (ANum 15).
Proof.
  apply rsc_step with (APlus (ANum 3) (ANum 12)).
  apply AS_Plus2.
  apply av_num.
  apply AS_Mult.
  apply rsc_step with (ANum 15).
  apply AS_Plus.
  apply rsc_refl.
Qed.

Hint Constructors astep aval.
Example astep_example1':
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state ==>a* (ANum 15).
Proof.
  eapply rsc_step. auto. simpl.
  eapply rsc_step. auto. simpl.
  apply rsc_refl.
Qed.

Tactic Notation "print_goal" := match goal with |- ?x => idtac x
                                end.
Tactic Notation "normalize" :=
  repeat (print_goal; eapply rsc_step;
          [(eauto 10; fail) | (instantiate; simpl)]);
  apply rsc_refl.

Example astep_example1'':
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state ==>a* (ANum 15).
Proof.
  normalize.
Qed.

Example astep_example1''': exists e',
                             (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
                                                                        ==>a* e'.
Proof.
  eapply ex_intro. normalize.
Qed.

Inductive tm : Type :=
| tm_true : tm
| tm_false : tm
| tm_if : tm -> tm -> tm -> tm
| tm_zero : tm
| tm_succ : tm -> tm
| tm_pred : tm -> tm
| tm_iszero : tm -> tm.

Inductive bvalue: tm -> Prop :=
  | bv_true : bvalue tm_true
  | bv_false : bvalue tm_false.

Inductive nvalue : tm -> Prop :=
| nv_zero : nvalue tm_zero
| nv_succ : forall t, nvalue t -> nvalue (tm_succ t).

Definition value (t:tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue.
Hint Unfold value.

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
| ST_IFTrue: forall t1 t2,
               (tm_if tm_true t1 t2) ==> t1
| ST_IfFalse : forall t1 t2,
                 (tm_if tm_false t1 t2) ==> t2
| ST_If : forall t1 t1' t2 t3,
            t1 ==> t1' ->
            (tm_if t1 t2 t3) ==> (tm_if t1' t2 t3)
| ST_Succ: forall t1 t1',
             t1 ==> t1' ->
             (tm_succ t1) ==> (tm_succ t1')
| ST_PredZero :
    (tm_pred tm_zero) ==> tm_zero
| ST_PredSucc : forall t1,
                  nvalue t1 ->
                  (tm_pred (tm_succ t1)) ==> t1
| ST_Pred : forall t1 t1',
              t1 ==> t1' ->
              (tm_pred t1) ==> (tm_pred t1')
| ST_IszeroZero :
    (tm_iszero tm_zero) ==> tm_true
| ST_IszeroSucc : forall t1,
                    nvalue t1 ->
                    (tm_iszero (tm_succ t1)) ==> tm_false
| ST_Iszero : forall t1 t1',
                t1 ==> t1' ->
                (tm_iszero t1) ==> (tm_iszero t1')
where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [Case_aux c "ST_IfTrue" | Case_aux c "ST_IfFalse" | Case_aux c "ST_If"
   | Case_aux c "ST_Succ" | Case_aux c "ST_PredZero"
   | Case_aux c "ST_PredSucc" | Case_aux c "ST_Pred"
   | Case_aux c "ST_IszeroZero" | Case_aux c "ST_IszeroSucc"
   | Case_aux c "ST_Iszero"].

Hint Constructors step.

Notation step_normal_form := (normal_form step).

Definition stuck(t:tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck.

Example some_tm_is_stuck:
  exists t, stuck t.
Proof.
  exists (tm_succ tm_true).
  unfold stuck.
  split.
  unfold normal_form.
  intros contra.
  inversion contra.
  inversion H.
  inversion H1.
  intros contra.
  inversion contra.
  inversion H.
  inversion H.
  inversion H1.
Qed.

Lemma value_is_nf: forall t,
                     value t -> step_normal_form t.
Proof.
  intros t H.
  unfold normal_form.
  intros H1.
  destruct H.
  destruct H.
  inversion H1.
  inversion H.
  inversion H1.
  inversion H.
  induction H.
  inversion H1.
  inversion H.
  apply IHnvalue.
  inversion H1.
  inversion H0.
  exists t1'.
  assumption.
Qed.

Theorem step_deterministic:
  partial_function step.
Proof with eauto.
  unfold partial_function.
  intros x y1 y2 H1.
  generalize dependent y2.
  step_cases(induction H1) Case;intros y2 H2.
  Case "ST_IfTrue".
  inversion H2. reflexivity. inversion H4.
  Case "ST_IfFalse".
  inversion H2. reflexivity. inversion H4.
  Case "ST_If".
  inversion H2.
  subst. inversion H1.
  subst. inversion H1.
  subst. apply IHstep in H5. subst. reflexivity.
  Case "ST_Succ".
  inversion H2. subst. apply IHstep in H0. subst. reflexivity.
  Case "ST_PredZero".
  inversion H2. reflexivity.
  inversion H0.
  Case "ST_PredSucc".
  inversion H2.
  reflexivity.
  inversion H; subst.
  inversion H1. inversion H3.
  inversion H1. inversion H3. subst.
  assert (value t).
  unfold value.
  right.
  apply H4.
  apply value_is_nf in H0.
  unfold normal_form in H0.
  destruct H0.
  exists t1'1.
  apply H7.
  Case "ST_Pred".
  inversion H2; subst.  inversion H1.
  inversion H1.
  assert (value y2).
  unfold value. right. apply H0.
  apply value_is_nf in H5.
  unfold normal_form in H5.
  destruct H5.
  exists t1'0.
  apply H3. apply IHstep in H0. subst. reflexivity.
  Case "ST_IszeroZero".
  inversion H2. reflexivity.
  inversion H0.
  Case "ST_IszeroSucc".
  inversion H2; subst.
  reflexivity.
  inversion H1.
  assert (value t1). unfold value. right. apply H.
  apply value_is_nf in H5.
  unfold normal_form in H5.
  destruct H5.
  exists t1'0. apply H3.
  Case "ST_Iszero".
  inversion H2; subst.
  inversion H1.
  inversion H1.
  assert (value t0). right. apply H0.
  apply value_is_nf in H5.
  unfold normal_form in H5.
  destruct H5.
  exists t1'0.
  apply H3.
  apply IHstep in H0. subst.
  reflexivity.
Qed.

Inductive ty: Type :=
| ty_Bool: ty
| ty_Nat: ty.

Inductive has_type: tm -> ty -> Prop :=
| T_True:
    has_type tm_true ty_Bool
| T_False:
    has_type tm_false ty_Bool
| T_If: forall t1 t2 t3 T,
          has_type t1 ty_Bool ->
          has_type t2 T ->
          has_type t3 T ->
          has_type (tm_if t1 t2 t3) T
| T_Zero:
    has_type tm_zero ty_Nat
| T_Succ: forall t1,
            has_type t1 ty_Nat ->
            has_type (tm_succ t1) ty_Nat
| T_Pred: forall t1,
            has_type t1 ty_Nat ->
            has_type (tm_pred t1) ty_Nat
| T_Iszero: forall t1,
              has_type t1 ty_Nat ->
              has_type (tm_iszero t1) ty_Bool.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_True" | Case_aux c "T_False" | Case_aux c "T_If"
    | Case_aux c "T_Zero" | Case_aux c "T_Succ" | Case_aux c "T_Pred"
    | Case_aux c "T_Iszero"].

Hint Constructors has_type.

Example has_type_1:
  has_type (tm_if tm_false tm_zero (tm_succ tm_zero)) ty_Nat.
Proof.
  apply T_If.
  apply T_False.
  apply T_Zero.
  apply T_Succ.
  apply T_Zero.
Qed.

Example has_type_not:
  ~ has_type (tm_if tm_false tm_zero tm_true) ty_Bool.
Proof.
  intros Contra. solve by inversion 2.
Qed.

Example succ_hastype_nat_hastype_nat: forall t,
    has_type (tm_succ t) ty_Nat ->
    has_type t ty_Nat.
Proof.
  intros t H.
  inversion H.
  apply H1.
Qed.

Theorem progress: forall t T,
    has_type t T ->
    value t \/ exists t', t ==> t'.
Proof with auto.
  intros t T HT.
  has_type_cases (induction HT) Case...
  Case "T_If".
  right. destruct IHHT1.
  SCase "t1 is a value". destruct H.
  SSCase "t1 is a bvalue". destruct H.
  SSSCase "t1 is tm_true".
  exists t2...
  SSSCase "t1 is tm_false".
  exists t3...
  SSCase "t1 is an nvalue".
  solve by inversion 2.
  SCase "t1 can take a step".
  destruct H as [t1' H1].
  exists (tm_if t1' t2 t3)...
  Case "T_Succ".
  destruct IHHT.
  SCase "t1 is a value".
  left.
  unfold value. right.
  unfold value in H.
  destruct H.
  SSCase "t1 is a bvalue".
  inversion H; subst; inversion HT.
  SSCase "t1 is an nvalue".
  apply nv_succ. apply H.
  SCase "t1 can take a step".
  right. destruct H.
  exists (tm_succ x)...
  Case "T_Pred".
  right. destruct IHHT.
  SCase "t1 is a value".
  unfold value in H.
  destruct H.
  SSCase "t1 is a bvalue".
  inversion H; subst; inversion HT.
  SSCase "t1 is a nvalue".
  inversion H. subst.
  exists tm_zero...
  exists t...
  SCase "t1 take a step".
  destruct H.
  exists (tm_pred x)...
  Case "T_Iszero".
  right. destruct IHHT.
  SCase "t1 is a value".
  destruct H.
  SSCase "t1 is a bvalue".
  inversion H; subst; inversion HT.
  SSCase "t1 is a nvalue".
  inversion H.
  exists tm_true...
  exists tm_false...
  SCase "t1 take a step".
  destruct H.
  exists (tm_iszero x)...
Qed.

Theorem preservation: forall t t' T,
    has_type t T ->
    t ==> t' ->
    has_type t' T.
Proof with auto.
  intros t t' T HT HE.
  generalize dependent t'.
  has_type_cases (induction HT) Case;
    intros t' HE;
    try (solve by inversion).
  Case "T_If"; inversion HE; subst.
  SCase "ST_IFTrue". assumption.
  SCase "ST_IFFalse". assumption.
  SCase "ST_If". apply T_If; try assumption.
  apply IHHT1; assumption.
  Case "T_Succ".
  inversion HE; subst.
  apply IHHT in H0.
  apply T_Succ. apply H0.
  Case "T_Pred".
  inversion HE; subst.
  SCase "t1 is tm_zero".
  apply T_Zero.
  inversion HT.
  SCase "t1 is (tm_succ t')".
  assumption.
  SCase "t1 take a step".
  apply IHHT in H0.
  inversion HE; subst. inversion H1.
  apply T_Pred. assumption.
  Case "T_Iszero".
  inversion HE; subst.
  SCase "t1 is tm_true".
  apply T_True.
  SCase "t1 is tm_false".
  apply T_False.
  SCase "t1 take a step".
  apply IHHT in H0.
  inversion HE; subst.
  apply T_Iszero. assumption.
Qed.

Definition stepmany := (refl_step_closure step).
Notation "t1 '==>*' t2" := (stepmany t1 t2) (at level 40).

Corollary soundness : forall t t' T,
    has_type t T ->
    t ==>* t' ->
    ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP. apply (preservation x y T HT H).
  unfold stuck. split; auto.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Variable names                                                          *
**************************************************************************)

Set Implicit Arguments.
Require Import TLC.LibTactics TLC.LibList TLC.LibLogic TLC.LibNat TLC.LibEpsilon TLC.LibReflect.
Require Export TLC.LibFset.

(* ********************************************************************** *)
(** * Abstract Definition of Variables *)

Module Type VariablesType.

(** We leave the type of variables abstract. *)

Parameter var : Set.

(** This type is inhabited. *)

Parameter var_inhab : Inhab var.

(** This type is comparable. *)
Parameter var_comp : Comparable var.
Instance var_comparable : Comparable var := var_comp.

(** We can build sets of variables. *)

Definition vars := fset var.

(** Finally, we have a means of generating fresh variables. *)

Parameter var_gen : vars -> var.
Parameter var_gen_spec : forall E, (var_gen E) \notin E.
Parameter var_fresh : forall (L : vars), { x : var | x \notin L }.

End VariablesType.

(* ********************************************************************** *)
(** * Concrete Implementation of Variables *)

Module Export Variables : VariablesType.

Definition var := nat.

Lemma var_inhab : Inhab var.
Proof using. apply (prove_Inhab 0). Qed.

Lemma var_comp : Comparable var.
Proof using. apply nat_comparable. Qed.

Instance var_comparable : Comparable var := var_comp.

Definition vars := fset var.

Definition var_gen_list (l : list nat) :=
  1 + fold_right plus O l.

Lemma var_gen_list_spec : forall n l,
  n \in from_list l -> n < var_gen_list l.
Proof using.
  unfold var_gen_list. induction l; introv I.
  rewrite from_list_nil in I. false (in_empty_elim I).
  rewrite from_list_cons in I. rew_list.
   rewrite in_union in I. destruct I as [H|H].
     rewrite in_singleton in H. subst. nat_math.
     specializes IHl H. nat_math.
Qed.

Definition var_gen (E : vars) : var :=
  var_gen_list (epsilon (fun l => E = from_list l)).

Lemma var_gen_spec : forall E, (var_gen E) \notin E.
Proof using.
  intros. unfold var_gen. spec_epsilon as l.
  applys fset_finite. rewrite Hl. introv H.
  forwards M: var_gen_list_spec H. nat_math.
Qed.

Lemma var_fresh : forall (L : vars), { x : var | x \notin L }.
Proof using. intros L. exists (var_gen L). apply var_gen_spec. Qed.

End Variables.

(* ********************************************************************** *)
(** ** Lists of variables of given length and given freshness *)

(** Freshness of n variables from a set L and from one another. *)

Fixpoint fresh (L : vars) (n : nat) (xs : list var) {struct xs} : Prop :=
  match xs, n with
  | nil, O => True
  | x::xs', S n' => x \notin L /\ fresh (L \u \{x}) n' xs'
  | _,_ => False
  end.

Hint Extern 1 (fresh _ _ _) => simpl.

(* It is possible to build a list of n fresh variables. *)

Lemma var_freshes : forall L n,
  { xs : list var | fresh L n xs }.
Proof using.
 intros. gen L. induction n; intros L.
  exists* (nil : list var).
  destruct (var_fresh L) as [x Fr].
   destruct (IHn (L \u \{x})) as [xs Frs].
   exists* (x::xs).
Qed.

(* ********************************************************************** *)
(** ** Picking fresh names *)

(** [gather_vars_for_type T F] return the union of all the finite sets
  of variables [F x] where [x] is a variable from the context such that
  [F x] type checks. In other words [x] has to be of the type of the
  argument of [F]. The resulting union of sets does not contain any
  duplicated item. This tactic is an extreme piece of hacking necessary
  because the tactic language does not support a "fold" operation on
  the context. *)

Ltac gather_vars_with F :=
  let rec gather V :=
    match goal with
    | H: ?S |- _ =>
      let FH := constr:(F H) in
      match V with
      | \{} => gather FH
      | context [FH] => fail 1
      | _ => gather (FH \u V)
      end
    | _ => V
    end in
  let L := gather (\{}:vars) in eval simpl in L.

(** [beautify_fset V] assumes that [V] is built as a union of finite
  sets and return the same set cleaned up: empty sets are removed and
  items are laid out in a nicely parenthesized way *)

Ltac beautify_fset V :=
  let rec go Acc E :=
     match E with
     | ?E1 \u ?E2 => let Acc1 := go Acc E1 in
                     go Acc1 E2
     | \{}  => Acc
     | ?E1 => match Acc with
              | \{} => E1
              | _ => constr:(Acc \u E1)
              end
     end
  in go (\{}:vars) V.

(** [pick_fresh_gen L Y] expects [L] to be a finite set of variables
  and adds to the context a variable with name [Y] and a proof that
  [Y] is fresh for [L]. *)

Ltac pick_fresh_gen L Y :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (var_fresh L) as [Y Fr]).

(** [pick_fresh_gens L n Y] expects [L] to be a finite set of variables
  and adds to the context a list of variables with name [Y] and a proof
  that [Y] is of length [n] and contains variable fresh for [L] and
  distinct from one another. *)

Ltac pick_freshes_gen L n Y :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (var_freshes L n) as [Y Fr]).

(* ********************************************************************** *)
(** ** Tactics for notin *)

(* Can I and must I generalize x here? *)
(** For efficiency, we avoid rewrites by splitting equivalence. *)

Implicit Types x : var.

Lemma notin_singleton_r : forall x y,
  x \notin \{y} -> x <> y.
Proof using. intros. rewrite~ <- notin_singleton. Qed.

Lemma notin_singleton_l : forall x y,
  x <> y -> x \notin \{y}.
Proof using. intros. rewrite~ notin_singleton. Qed.

Lemma notin_singleton_swap : forall x y,
  x \notin \{y} -> y \notin \{x}.
Proof using.
  intros. apply notin_singleton_l.
  apply sym_not_eq. apply~ notin_singleton_r.
Qed.

Lemma notin_union_r : forall x E F,
  x \notin (E \u F) -> (x \notin E) /\ (x \notin F).
Proof using. intros. rewrite~ <- notin_union. Qed.

Lemma notin_union_r1 : forall x E F,
  x \notin (E \u F) -> (x \notin E).
Proof using. introv. rewrite* notin_union. Qed.

Lemma notin_union_r2 : forall x E F,
  x \notin (E \u F) -> (x \notin F).
Proof using. introv. rewrite* notin_union. Qed.

Lemma notin_union_l : forall x E F,
  x \notin E -> x \notin F -> x \notin (E \u F).
Proof using. intros. rewrite~ notin_union. Qed.

Lemma notin_var_gen : forall E F,
  (forall x, x \notin E -> x \notin F) ->
  (var_gen E) \notin F.
Proof using. intros. autos~ var_gen_spec. Qed.

Implicit Arguments notin_singleton_r    [x y].
Implicit Arguments notin_singleton_l    [x y].
Implicit Arguments notin_singleton_swap [x y].
Implicit Arguments notin_union_r  [x E F].
Implicit Arguments notin_union_r1 [x E F].
Implicit Arguments notin_union_r2 [x E F].
Implicit Arguments notin_union_l  [x E F].

(** Tactics to deal with notin.  *)

Ltac notin_solve_target_from x E H :=
  match type of H with
  | x \notin E => constr:(H)
  | x \notin (?F \u ?G) =>
     let H' :=
        match F with
        | context [E] => constr:(notin_union_r1 H)
        | _ => match G with
          | context [E] => constr:(notin_union_r2 H)
          | _ => fail 20
          end
        end in
     notin_solve_target_from x E H'
  end.

Ltac notin_solve_target x E :=
  match goal with
  | H: x \notin ?L |- _ =>
    match L with context[E] =>
      let F := notin_solve_target_from x E H in
      apply F
    end
  | H: x <> ?y |- _ =>
     match E with \{y} =>
       apply (notin_singleton_l H)
     end
  end.

Ltac notin_solve_one :=
  match goal with
  | |- ?x \notin \{?y} =>
     apply notin_singleton_swap;
     notin_solve_target y (\{x})
  | |- ?x \notin ?E =>
    notin_solve_target x E
  (* If x is an evar, tries to instantiate it.
     Problem: it might loop !
  | |- ?x \notin ?E =>
     match goal with y:var |- _ =>
       match y with
       | x => fail 1
       | _ =>
         let H := fresh in cuts H: (y \notin E);
         [ apply H | notin_solve_target y E ]
        end
     end
  *)
  end.

Ltac notin_simpl :=
  match goal with
  | |- _ \notin (_ \u _) => apply notin_union_l; notin_simpl
  | |- _ \notin (\{}) => apply notin_empty; notin_simpl
  | |- ?x <> ?y => apply notin_singleton_r; notin_simpl
  | |- _ => idtac
  end.

Ltac notin_solve_false :=
  match goal with
  | H: ?x \notin ?E |- _ =>
    match E with context[x] =>
      apply (@notin_same _ x);
      let F := notin_solve_target_from x (\{x}) H in
      apply F
    end
  | H: ?x <> ?x |- _ => apply H; reflexivity
  end.

Ltac notin_false :=
  match goal with
  | |- False => notin_solve_false
  | _ => intros_all; false; notin_solve_false
  end.

Ltac notin_from_fresh_in_context :=
  repeat (match goal with H: fresh _ _ _ |- _ =>
    progress (simpl in H; destructs H) end).

Ltac notin_solve :=
  notin_from_fresh_in_context;
  first [ notin_simpl; try notin_solve_one
        | notin_false ].

Hint Extern 1 (_ \notin _) => notin_solve.
Hint Extern 1 (_ <> _ :> var) => notin_solve.
Hint Extern 1 ((_ \notin _) /\ _) => splits.

(*
LATER:
  | |- ?x \notin ?E =>
	progress (unfold x); notin_simpl
  | |- (var_gen ?x) \notin _ =>
        apply notin_var_gen; intros; notin_simpl
*)

(* ********************************************************************** *)
(** ** Tactics for fresh *)

(* todo: cleanup proofs of fresh using calc_fset *)

Lemma fresh_union_r : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L1 n xs /\ fresh L2 n xs.
Proof using.
  induction xs; simpl; intros; destruct n;
  tryfalse*. auto.
  destruct H. split; split; auto.
  forwards*: (@IHxs (L1 \u \{a}) L2 n).
   rewrite union_comm.
   rewrite union_comm_assoc.
   rewrite* union_assoc.
  forwards*: (@IHxs L1 (L2 \u \{a}) n).
   rewrite* union_assoc.
Qed.

Lemma fresh_union_r1 : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L1 n xs.
Proof using. intros. forwards*: fresh_union_r. Qed.

Lemma fresh_union_r2 : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L2 n xs.
Proof using. intros. forwards*: fresh_union_r. Qed.

Lemma fresh_union_l : forall xs L1 L2 n,
  fresh L1 n xs -> fresh L2 n xs -> fresh (L1 \u L2) n xs.
Proof using.
  induction xs; simpl; intros; destruct n; tryfalse*. auto.
  destruct H. destruct H0. split~.
  forwards~ K: (@IHxs (L1 \u \{a}) (L2 \u \{a}) n).
  rewrite <- (union_same \{a}).
  rewrite union_assoc.
  rewrite <- (union_assoc L1).
  rewrite (union_comm L2).
  rewrite (union_assoc L1).
  rewrite* <- union_assoc.
Qed.

Lemma fresh_empty : forall L n xs,
  fresh L n xs -> fresh \{} n xs.
Proof using.
  intros. rewrite <- (union_empty_r L) in H.
  destruct* (fresh_union_r _ _ _ _ H).
Qed.

Lemma fresh_length : forall L n xs,
  fresh L n xs -> n = length xs.
Proof using.
  intros. gen n L. induction xs; simpl; intros n L Fr;
    destruct n; tryfalse*.
  auto.
  rew_length. rewrite* <- (@IHxs n (L \u \{a})).
Qed.

Lemma fresh_resize : forall L n xs,
  fresh L n xs -> forall m, m = n -> fresh L m xs.
Proof using.
  introv Fr Eq. subst~.
Qed.

Lemma fresh_resize_length : forall L n xs,
  fresh L n xs -> fresh L (length xs) xs.
Proof using.
  introv Fr. rewrite* <- (fresh_length _ _ _ Fr).
Qed.

Implicit Arguments fresh_union_r [xs L1 L2 n].
Implicit Arguments fresh_union_r1 [xs L1 L2 n].
Implicit Arguments fresh_union_r2 [xs L1 L2 n].
Implicit Arguments fresh_union_l [xs L1 L2 n].
Implicit Arguments fresh_empty  [L n xs].
Implicit Arguments fresh_length [L n xs].
Implicit Arguments fresh_resize [L n xs].
Implicit Arguments fresh_resize_length [L n xs].

Lemma fresh_single_notin : forall x xs n,
  fresh \{x} n xs ->
  x \notin from_list xs.
Proof using.
  induction xs; destruct n; introv F; simpl in F; tryfalse.
  rewrite~ from_list_nil.
  destruct F as [Fr F']. lets [? ?]: (fresh_union_r F').
   specializes IHxs n. rewrite~ from_list_cons.
Qed.

Ltac fresh_solve_target_from E n xs H :=
  match type of H with
  | fresh E n xs => constr:(H)
  | fresh E ?m xs =>
      match n with
      | length xs => constr:(fresh_resize_length H)
      | _ =>
         match goal with
         | Eq: m = n |- _ => constr:(fresh_resize H _ (sym_eq Eq))
         | Eq: n = m |- _ => constr:(fresh_resize H _ Eq)
         end
      end
  | fresh (?F \u ?G) ?m xs =>
     let H' :=
        match F with
        | context [E] => constr:(fresh_union_r1 H)
        | _ => match G with
          | context [E] => constr:(fresh_union_r2 H)
          | _ => fail 20
          end
        end in
     fresh_solve_target_from E n xs H'
  end.

Ltac fresh_solve_target E n xs :=
  match goal with H: fresh ?L _ xs |- _ =>
    match L with context[E] =>
      let F := fresh_solve_target_from E n xs H in
      apply F
    end
  end.

Ltac fresh_solve_one :=
  match goal with
  | |- fresh ?E ?n ?xs =>
    fresh_solve_target E n xs
  | |- fresh \{} ?n ?xs =>
    match goal with H: fresh ?F ?m xs |- _ =>
      apply (fresh_empty H);
      fresh_solve_target F n xs
    end
  end.

Ltac fresh_simpl :=
  try match goal with |- fresh (_ \u _) _ _ =>
    apply fresh_union_l; fresh_simpl end.

Ltac fresh_solve_by_notins :=
  simpl; splits; try notin_solve.

Ltac fresh_solve :=
  fresh_simpl;
  first [ fresh_solve_one
        | fresh_solve_by_notins
        | idtac ].

Hint Extern 1 (fresh _ _ _) => fresh_solve.

(* LATER: more automation of fresh_length properties *)


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

Require Cantor.
Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

(* Enumerable X allows injection into nat *)
Class Enumerable (X: Type) :=
  {
    to_nat : X -> nat;
    of_nat : nat -> X;
    enumP {x: X} : of_nat (to_nat x) = x
  }.

(* to_nat is injective *)
Lemma to_nat_inj {X: Type} {enumX: Enumerable X} {x y: X}:
  to_nat x = to_nat y <-> x = y.
Proof.
  constructor; last by move->.
  move /(f_equal of_nat). by rewrite ?enumP.
Qed.

Lemma enumerableI {X Y: Type} {enum: Enumerable X} (to_X: Y -> X) (of_X: X -> Y) :
  (forall (y: Y), of_X (to_X y) = y) -> Enumerable Y.
Proof.
  move=> cancel. exists (fun y => to_nat (to_X y)) (fun x => of_X (of_nat x)).
  move=> y. by rewrite enumP cancel.
Qed.

#[export] Instance nat_Enumerable : Enumerable nat.
Proof. by exists id id. Qed.

#[export] Instance bool_Enumerable : Enumerable bool.
Proof.
  exists (fun b => if b then 1 else 0) (fun n => if n is 0 then false else true).
  by case.
Qed.

#[export] Instance nat2_Enumerable : Enumerable (nat * nat).
Proof.
  exists Cantor.to_nat Cantor.of_nat.
  exact: Cantor.cancel_of_to.
Qed.

#[export] Instance prod_Enumerable {X Y: Type} {enumX: Enumerable X} {enumY: Enumerable Y} : Enumerable (X * Y).
Proof.
  exists
    (fun '(x, y) => to_nat (to_nat x, to_nat y))
    (fun n => match of_nat n with | (n1, n2) => (of_nat n1, of_nat n2) end).
  move=> [x y]. by rewrite ?enumP.
Qed.

#[export] Instance sum_Enumerable {X Y: Type} {enumX: Enumerable X} {enumY: Enumerable Y} : Enumerable (X + Y).
Proof.
  exists
    (fun t => match t with | inl x => to_nat (0, to_nat x) | inr y => to_nat (1, to_nat y) end)
    (fun n => match of_nat n with | (0, n) => inl (of_nat n) | (1, n) => inr (of_nat n) | _ => inl (of_nat n) end).
  by case => ?; rewrite ?enumP.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Sum of Data Structures                                                  *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibBool.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Fixing implicit types *)

Implicit Arguments inl [[A] [B]].
Implicit Arguments inr [[A] [B]].

(* ********************************************************************** *)
(** * Inhabited *)

Instance sum_inhab_left : forall `{Inhab A} B, Inhab (A + B).
Proof. intros. apply (prove_Inhab (inl arbitrary)). Qed.
Instance sum_inhab_right : forall `{Inhab B} A, Inhab (A + B).
Proof. intros. apply (prove_Inhab (inr arbitrary)). Qed.

Definition sum_inhab : forall `{Inhab A, Inhab B}, Inhab (A + B).
Proof. typeclass. Qed.

(* ********************************************************************** *)
(** * Operations *)

Section IsIn.
Variables (A B : Type).
Implicit Type x : A + B.

Definition is_inl x :=
  match x with
  | inl _ => true
  | inr _ => false
  end.

Definition is_inr x :=
  match x with
  | inl _ => false
  | inr _ => true
  end.

Lemma is_inl_neg_is_inr : forall x,
  is_inl x = ! (is_inr x).
Proof. intros x. destruct~ x. Qed.

Lemma is_inr_neg_is_inl : forall x,
  is_inr x = ! (is_inl x).
Proof. intros x. destruct~ x. Qed.

End IsIn.

(* ********************************************************************** *)
(** * Projections *)

(*-----------------------------------------------------*)
(** ** Stripping of the branch tag *)

Section Get.
Variables (A1 A2 : Type) (DA1:Inhab A1) (DA2:Inhab A2).
Implicit Types x : A1+A2.

Definition get21 x :=
  match x with
  | inl x1 => x1
  | inr x2 => arbitrary
  end.

Definition get22 x :=
  match x with
  | inl x1 => arbitrary
  | inr x2 => x2
  end.

End Get.

Implicit Arguments get21 [[A1] [A2] [DA1]].
Implicit Arguments get22 [[A1] [A2] [DA2]].

(*-----------------------------------------------------*)
(** ** Lifting functions over sum types *)

Section Fget.
Variables (A1 A2 B1 B2 : Type)
  (DB1:Inhab B1) (DB2:Inhab B2).
Implicit Types f : A1+A2->B1+B2.

Definition func_get21 f :=
  fun x => get21 (f (inl x)).
Definition func_get22 f :=
  fun x => get22 (f (inr x)).

End Fget.

Implicit Arguments func_get21 [[A1] [A2] [B1] [B2] [DB1]].
Implicit Arguments func_get22 [[A1] [A2] [B1] [B2] [DB2]].


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Finite_sets.
Require Export Constructive_sets.
Require Export Classical_Type.
Require Export Classical_sets.
Require Export Powerset.
Require Export Powerset_facts.
Require Export Powerset_Classical_facts.
Require Export Gt.
Require Export Lt.

Section Finite_sets_facts.
  Variable U : Type.

  Lemma finite_cardinal :
    forall X:Ensemble U, Finite U X ->  exists n : nat, cardinal U X n.
  Proof.
    induction 1 as [| A _ [n H]].
    exists 0; auto with sets.
    exists (S n); auto with sets.
  Qed.

  Lemma cardinal_finite :
    forall (X:Ensemble U) (n:nat), cardinal U X n -> Finite U X.
  Proof.
    induction 1; auto with sets.
  Qed.

  Theorem Add_preserves_Finite :
    forall (X:Ensemble U) (x:U), Finite U X -> Finite U (Add U X x).
  Proof.
    intros X x H'.
    elim (classic (In U X x)); intro H'0; auto with sets.
    rewrite (Non_disjoint_union U X x); auto with sets.
  Qed.

  Theorem Singleton_is_finite : forall x:U, Finite U (Singleton U x).
  Proof.
    intro x; rewrite <- (Empty_set_zero U (Singleton U x)).
    change (Finite U (Add U (Empty_set U) x)) in |- *; auto with sets.
  Qed.

  Theorem Union_preserves_Finite :
    forall X Y:Ensemble U, Finite U X -> Finite U Y -> Finite U (Union U X Y).
  Proof.
    intros X Y H; induction H as [|A Fin_A Hind x].
    rewrite (Empty_set_zero U Y). trivial.
    intros.
    rewrite (Union_commutative U (Add U A x) Y).
    rewrite <- (Union_add U Y A x).
    rewrite (Union_commutative U Y A).
    apply Add_preserves_Finite.
    apply Hind. assumption.
  Qed.

  Lemma Finite_downward_closed :
    forall A:Ensemble U,
      Finite U A -> forall X:Ensemble U, Included U X A -> Finite U X.
  Proof.
    intros A H'; elim H'; auto with sets.
    intros X H'0.
    rewrite (less_than_empty U X H'0); auto with sets.
    intros; elim Included_Add with U X A0 x; auto with sets.
    destruct 1 as [A' [H5 H6]].
    rewrite H5; auto with sets.
  Qed.

  Lemma Intersection_preserves_finite :
    forall A:Ensemble U,
      Finite U A -> forall X:Ensemble U, Finite U (Intersection U X A).
  Proof.
    intros A H' X; apply Finite_downward_closed with A; auto with sets.
  Qed.

  Lemma cardinalO_empty :
    forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U.
  Proof.
    intros X H; apply (cardinal_invert U X 0); trivial with sets.
  Qed.

  Lemma inh_card_gt_O :
    forall X:Ensemble U, Inhabited U X -> forall n:nat, cardinal U X n -> n > 0.
  Proof.
    induction 1 as [x H'].
    intros n H'0.
    elim (gt_O_eq n); auto with sets.
    intro H'1; generalize H'; generalize H'0.
    rewrite <- H'1; intro H'2.
    rewrite (cardinalO_empty X); auto with sets.
    intro H'3; elim H'3.
  Qed.

  Lemma card_soustr_1 :
    forall (X:Ensemble U) (n:nat),
      cardinal U X n ->
      forall x:U, In U X x -> cardinal U (Subtract U X x) (pred n).
  Proof.
    intros X n H'; elim H'.
    intros x H'0; elim H'0.
    clear H' n X.
    intros X n H' H'0 x H'1 x0 H'2.
    elim (classic (In U X x0)).
    intro H'4; rewrite (add_soustr_xy U X x x0).
    elim (classic (x = x0)).
    intro H'5.
    absurd (In U X x0); auto with sets.
    rewrite <- H'5; auto with sets.
    intro H'3; try assumption.
    cut (S (pred n) = pred (S n)).
    intro H'5; rewrite <- H'5.
    apply card_add; auto with sets.
    red in |- *; intro H'6; elim H'6.
    intros H'7 H'8; try assumption.
    elim H'1; auto with sets.
    unfold pred at 2 in |- *; symmetry  in |- *.
    apply S_pred with (m := 0).
    change (n > 0) in |- *.
    apply inh_card_gt_O with (X := X); auto with sets.
    apply Inhabited_intro with (x := x0); auto with sets.
    red in |- *; intro H'3.
    apply H'1.
    elim H'3; auto with sets.
    rewrite H'3; auto with sets.
    elim (classic (x = x0)).
    intro H'3; rewrite <- H'3.
    cut (Subtract U (Add U X x) x = X); auto with sets.
    intro H'4; rewrite H'4; auto with sets.
    intros H'3 H'4; try assumption.
    absurd (In U (Add U X x) x0); auto with sets.
    red in |- *; intro H'5; try exact H'5.
    lapply (Add_inv U X x x0); tauto.
  Qed.

  Lemma cardinal_is_functional :
    forall (X:Ensemble U) (c1:nat),
      cardinal U X c1 ->
      forall (Y:Ensemble U) (c2:nat), cardinal U Y c2 -> X = Y -> c1 = c2.
  Proof.
    intros X c1 H'; elim H'.
    intros Y c2 H'0; elim H'0; auto with sets.
    intros A n H'1 H'2 x H'3 H'5.
    elim (not_Empty_Add U A x); auto with sets.
    clear H' c1 X.
    intros X n H' H'0 x H'1 Y c2 H'2.
    elim H'2.
    intro H'3.
    elim (not_Empty_Add U X x); auto with sets.
    clear H'2 c2 Y.
    intros X0 c2 H'2 H'3 x0 H'4 H'5.
    elim (classic (In U X0 x)).
    intro H'6; apply f_equal.
    apply H'0 with (Y := Subtract U (Add U X0 x0) x).
    elimtype (pred (S c2) = c2); auto with sets.
    apply card_soustr_1; auto with sets.
    rewrite <- H'5.
    apply Sub_Add_new; auto with sets.
    elim (classic (x = x0)).
    intros H'6 H'7; apply f_equal.
    apply H'0 with (Y := X0); auto with sets.
    apply Simplify_add with (x := x); auto with sets.
    pattern x at 2 in |- *; rewrite H'6; auto with sets.
    intros H'6 H'7.
    absurd (Add U X x = Add U X0 x0); auto with sets.
    clear H'0 H' H'3 n H'5 H'4 H'2 H'1 c2.
    red in |- *; intro H'.
    lapply (Extension U (Add U X x) (Add U X0 x0)); auto with sets.
    clear H'.
    intro H'; red in H'.
    elim H'; intros H'0 H'1; red in H'0; clear H' H'1.
    absurd (In U (Add U X0 x0) x); auto with sets.
    lapply (Add_inv U X0 x0 x); [ intuition | apply (H'0 x); apply Add_intro2 ].
  Qed.

  Lemma cardinal_Empty : forall m:nat, cardinal U (Empty_set U) m -> 0 = m.
  Proof.
    intros m Cm; generalize (cardinal_invert U (Empty_set U) m Cm).
    elim m; auto with sets.
    intros; elim H0; intros; elim H1; intros; elim H2; intros.
    elim (not_Empty_Add U x x0 H3).
  Qed.

  Lemma cardinal_unicity :
    forall (X:Ensemble U) (n:nat),
      cardinal U X n -> forall m:nat, cardinal U X m -> n = m.
  Proof.
    intros; apply cardinal_is_functional with X X; auto with sets.
  Qed.

  Lemma card_Add_gen :
    forall (A:Ensemble U) (x:U) (n n':nat),
      cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n.
  Proof.
    intros A x n n' H'.
    elim (classic (In U A x)).
    intro H'0.
    rewrite (Non_disjoint_union U A x H'0).
    intro H'1; cut (n = n').
    intro E; rewrite E; auto with sets.
    apply cardinal_unicity with A; auto with sets.
    intros H'0 H'1.
    cut (n' = S n).
    intro E; rewrite E; auto with sets.
    apply cardinal_unicity with (Add U A x); auto with sets.
  Qed.

  Lemma incl_st_card_lt :
    forall (X:Ensemble U) (c1:nat),
      cardinal U X c1 ->
      forall (Y:Ensemble U) (c2:nat),
	cardinal U Y c2 -> Strict_Included U X Y -> c2 > c1.
  Proof.
    intros X c1 H'; elim H'.
    intros Y c2 H'0; elim H'0; auto with sets arith.
    intro H'1.
    elim (Strict_Included_strict U (Empty_set U)); auto with sets arith.
    clear H' c1 X.
    intros X n H' H'0 x H'1 Y c2 H'2.
    elim H'2.
    intro H'3; elim (not_SIncl_empty U (Add U X x)); auto with sets arith.
    clear H'2 c2 Y.
    intros X0 c2 H'2 H'3 x0 H'4 H'5; elim (classic (In U X0 x)).
    intro H'6; apply gt_n_S.
    apply H'0 with (Y := Subtract U (Add U X0 x0) x).
    elimtype (pred (S c2) = c2); auto with sets arith.
    apply card_soustr_1; auto with sets arith.
    apply incl_st_add_soustr; auto with sets arith.
    elim (classic (x = x0)).
    intros H'6 H'7; apply gt_n_S.
    apply H'0 with (Y := X0); auto with sets arith.
    apply sincl_add_x with (x := x0).
    rewrite <- H'6; auto with sets arith.
    pattern x0 at 1 in |- *; rewrite <- H'6; trivial with sets arith.
    intros H'6 H'7; red in H'5.
    elim H'5; intros H'8 H'9; try exact H'8; clear H'5.
    red in H'8.
    generalize (H'8 x).
    intro H'5; lapply H'5; auto with sets arith.
    intro H; elim Add_inv with U X0 x0 x; auto with sets arith.
    intro; absurd (In U X0 x); auto with sets arith.
    intro; absurd (x = x0); auto with sets arith.
  Qed.

  Lemma incl_card_le :
    forall (X Y:Ensemble U) (n m:nat),
      cardinal U X n -> cardinal U Y m -> Included U X Y -> n <= m.
  Proof.
    intros; elim Included_Strict_Included with U X Y; auto with sets arith; intro.
    cut (m > n); auto with sets arith.
    apply incl_st_card_lt with (X := X) (Y := Y); auto with sets arith.
    generalize H0; rewrite <- H2; intro.
    cut (n = m).
    intro E; rewrite E; auto with sets arith.
    apply cardinal_unicity with X; auto with sets arith.
  Qed.

  Lemma G_aux :
    forall P:Ensemble U -> Prop,
      (forall X:Ensemble U,
	Finite U X ->
	(forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
      P (Empty_set U).
  Proof.
    intros P H'; try assumption.
    apply H'; auto with sets.
    clear H'; auto with sets.
    intros Y H'; try assumption.
    red in H'.
    elim H'; intros H'0 H'1; try exact H'1; clear H'.
    lapply (less_than_empty U Y); [ intro H'3; try exact H'3 | assumption ].
    elim H'1; auto with sets.
  Qed.

  Lemma Generalized_induction_on_finite_sets :
    forall P:Ensemble U -> Prop,
      (forall X:Ensemble U,
	Finite U X ->
	(forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
      forall X:Ensemble U, Finite U X -> P X.
  Proof.
    intros P H'0 X H'1.
    generalize P H'0; clear H'0 P.
    elim H'1.
    intros P H'0.
    apply G_aux; auto with sets.
    clear H'1 X.
    intros A H' H'0 x H'1 P H'3.
    cut (forall Y:Ensemble U, Included U Y (Add U A x) -> P Y); auto with sets.
    generalize H'1.
    apply H'0.
    intros X K H'5 L Y H'6; apply H'3; auto with sets.
    apply Finite_downward_closed with (A := Add U X x); auto with sets.
    intros Y0 H'7.
    elim (Strict_inclusion_is_transitive_with_inclusion U Y0 Y (Add U X x));
      auto with sets.
    intros H'2 H'4.
    elim (Included_Add U Y0 X x);
      [ intro H'14
	| intro H'14; elim H'14; intros A' E; elim E; intros H'15 H'16; clear E H'14
	| idtac ]; auto with sets.
    elim (Included_Strict_Included U Y0 X); auto with sets.
    intro H'9; apply H'5 with (Y := Y0); auto with sets.
    intro H'9; rewrite H'9.
    apply H'3; auto with sets.
    intros Y1 H'8; elim H'8.
    intros H'10 H'11; apply H'5 with (Y := Y1); auto with sets.
    elim (Included_Strict_Included U A' X); auto with sets.
    intro H'8; apply H'5 with (Y := A'); auto with sets.
    rewrite <- H'15; auto with sets.
    intro H'8.
    elim H'7.
    intros H'9 H'10; apply H'10 || elim H'10; try assumption.
    generalize H'6.
    rewrite <- H'8.
    rewrite <- H'15; auto with sets.
  Qed.

End Finite_sets_facts.


(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(** * Extensions to [Coq.Sets.Multiset] *)

(* cf <http://coq.inria.fr/stdlib/Coq.Sets.Multiset.html> *)
(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)

Require Import Coq.Sets.Multiset.
Require Import Coq.Arith.Minus.
Require Import Coq.Arith.Le.
Require Import Coq.Arith.Lt.

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(** The multiset difference operator. *)
Definition mdiff {A:Type} (m1 m2 : multiset A) : multiset A :=
    Bag (fun a:A => multiplicity m1 a - multiplicity m2 a).

Delimit Scope multiset_scope with multiset.
Bind Scope multiset_scope with multiset.
Open Scope multiset_scope.

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(** ** Notations for common multiset relationships. *)

(** Subset for multisets. N.B., _not_ submultiset! *)
Notation "xs \c ys" :=
    (forall a:_, IsSucc (multiplicity xs a) -> IsSucc (multiplicity ys a))
    (at level 38):multiset_scope.

(** Submultiset. *)
Notation "xs [<=] ys" :=
    (forall a:_, multiplicity xs a <= multiplicity ys a)
    (at level 38):multiset_scope.

(** Strict submultiset. *)
Notation "xs [<] ys" :=
    (forall a:_, multiplicity xs a < multiplicity ys a)
    (at level 38):multiset_scope.

(** Extensional syntactic identity. *)
Notation "xs [=] ys" :=
    (forall a:_, multiplicity xs a = multiplicity ys a)
    (at level 38):multiset_scope.

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(** ** Transitivity for common multiset relationships. *)

Lemma msubset_trans
    : forall {A : Type} {xs ys zs : multiset A}
    , xs \c ys -> ys \c zs -> xs \c zs.
Proof. intros; auto. Qed.

Lemma submultiset_trans
    : forall {A : Type} {xs ys zs : multiset A}
    , xs [<=] ys -> ys [<=] zs -> xs [<=] zs.
Proof. intros; apply (le_trans _ (multiplicity ys a) _); auto. Qed.
(* BUG: [le] isn't setoid!! *)

Lemma strict_submultiset_trans
    : forall {A : Type} {xs ys zs : multiset A}
    , xs [<] ys -> ys [<] zs -> xs [<] zs.
Proof. intros; apply (lt_trans _ (multiplicity ys a) _); auto. Qed.
(* BUG: [le] isn't setoid!! *)

Lemma eq_multiset_trans
    : forall {A : Type} {xs ys zs : multiset A}
    , xs [=] ys -> ys [=] zs -> xs [=] zs.
Proof. intros; transitivity (multiplicity ys a); auto. Qed.

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ fin. *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Relations over pairs *)

(* Require Import SetoidList. *)
From Coq.Logic Require Import StrictProp.
From Mon.SRelation Require Import SRelations SMorphisms.
(* NB: This should be system-wide someday, but for that we need to
    fix the simpl tactic, since "simpl fst" would be refused for
    the moment.

Arguments fst {A B}.
Arguments snd {A B}.
Arguments pair {A B}.

/NB *)

Local Notation Fst := (@fst _ _).
Local Notation Snd := (@snd _ _).

Arguments relation_conjunction A%type (R R')%signature _ _.
Arguments relation_equivalence A%type (_ _)%signature.
Arguments subrelation A%type (R R')%signature.
Arguments Reflexive A%type R%signature.
Arguments Irreflexive A%type R%signature.
Arguments Symmetric A%type R%signature.
Arguments Transitive A%type R%signature.
Arguments PER A%type R%signature.
Arguments Equivalence A%type R%signature.
Arguments StrictOrder A%type R%signature.

Generalizable Variables A B RA RB Ri Ro f.

(** Any function from [A] to [B] allow to obtain a relation over [A]
    out of a relation over [B]. *)

Definition SRelCompFun {A} {B : Type}(R:srelation B)(f:A->B) : srelation A :=
 fun a a' => R (f a) (f a').

(** Instances on RelCompFun must match syntactically *)
Typeclasses Opaque SRelCompFun.

Infix "s@@" := (@SRelCompFun _ _) (at level 30, right associativity) : signature_scope.

Notation "R s@@1" := (R s@@ Fst)%signature (at level 30) : signature_scope.
Notation "R s@@2" := (R s@@ Snd)%signature (at level 30) : signature_scope.

(** We declare measures to the system using the [Measure] class.
   Otherwise the instances would easily introduce loops,
   never instantiating the [f] function.  *)

Class Measure {A B} (f : A -> B).

(** Standard measures. *)

Instance fst_measure : @Measure (A * B) A Fst. Proof. Defined.
Instance snd_measure : @Measure (A * B) B Snd. Proof. Defined.

(** We define a product relation over [A*B]: each components should
    satisfy the corresponding initial relation. *)

Definition SRelProd {A : Type} {B : Type} (RA:srelation A)(RB:srelation B) : srelation (A*B) :=
 srelation_conjunction (@SRelCompFun (A * B) A RA fst) (SRelCompFun RB Snd).

Typeclasses Opaque SRelProd.

Infix "*" := SRelProd : signature_scope.

Section SRelCompFun_Instances.
  Context {A : Type} {B : Type} (R : srelation B).

  Global Instance SRelCompFun_Reflexive
    `(Measure A B f, Reflexive _ R) : Reflexive (R s@@f).
  Proof. firstorder. Qed.

  Global Instance SRelCompFun_Symmetric
    `(Measure A B f, Symmetric _ R) : Symmetric (R s@@f).
  Proof. firstorder. Qed.

  Global Instance SRelCompFun_Transitive
    `(Measure A B f, Transitive _ R) : Transitive (R s@@f).
  Proof. firstorder. Qed.

  Global Instance SRelCompFun_Irreflexive
    `(Measure A B f, Irreflexive _ R) : Irreflexive (R s@@f).
  Proof. firstorder. Qed.

  Global Program Instance SRelCompFun_Equivalence
    `(Measure A B f, Equivalence _ R) : Equivalence (R s@@f).

  Global Program Instance SRelCompFun_StrictOrder
    `(Measure A B f, StrictOrder _ R) : StrictOrder (R s@@f).

End SRelCompFun_Instances.

Section SRelProd_Instances.

  Context {A : Type} {B : Type} (RA : srelation A) (RB : srelation B).

  Global Instance SRelProd_Reflexive `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB).
  Proof. firstorder. Qed.

  Global Instance SRelProd_Symmetric `(Symmetric _ RA, Symmetric _ RB)
  : Symmetric (RA*RB).
  Proof. firstorder. Qed.

  Global Instance SRelProd_Transitive
           `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB).
  Proof. firstorder. Qed.

  Global Program Instance SRelProd_Equivalence
          `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB).

  Lemma FstRel_ProdRel :
    srelation_equivalence (SRelCompFun RA fst) (RA*(fun _ _ : B => sUnit))%signature.
  Proof. firstorder. Qed.

  Lemma SndRel_ProdRel :
    srelation_equivalence (SRelCompFun RB snd) ((fun _ _ : A => sUnit) * RB)%signature.
  Proof. firstorder. Qed.

  Global Instance FstRel_sub :
    subsrelation (RA*RB)%signature (SRelCompFun RA fst).
  Proof. firstorder. Qed.

  Global Instance SndRel_sub :
    subsrelation (RA*RB)%signature (SRelCompFun RB snd).
  Proof. firstorder. Qed.

  Global Instance pair_compat :
    SProper (RA s==>RB s==> RA*RB)%signature (@pair _ _).
  Proof. firstorder. Qed.

  Global Instance fst_compat :
    SProper (RA*RB s==> RA)%signature Fst.
  Proof.
    intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
  Qed.

  Global Instance snd_compat :
    SProper (RA*RB s==> RB) Snd.
  Proof.
    intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
  Qed.

  Global Instance SRelCompFun_compat (f:A->B)
           `(SProper _ (Ri s==>Ri s==>Ro) RB) :
    SProper (Ri s@@f s==> Ri s@@f s==>Ro) (RB s@@f)%signature.
  Proof. unfold SRelCompFun; firstorder. Qed.
End SRelProd_Instances.

Hint Unfold SRelProd SRelCompFun.
Hint Extern 2 (SRelProd _ _ _ _) => split.


Require Import ZArith.
Require Import QArith.
Require Import Lqa.
Require Import Coq.micromega.Psatz.
Require Import Toy.FP.usl.interface.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Sound.Sound_Flat.
Require Import Logic.SeparationLogic.ShallowEmbedded.PredicateSeparationLogic.
Require Import Logic.PropositionalLogic.ShallowEmbedded.PredicatePropositionalLogic.
Require Import Logic.GeneralLogic.ShallowEmbedded.PredicateAsLang.

Definition var : Type := nat.
Definition store : Type := var -> Z.
Definition addr : Type := Z.
Definition heap : Type := addr -> option (Q * Z).
Definition state : Type := store * heap.
Definition Assertion : Type := state -> Prop.

Definition storeJ : Join store := equiv_Join.

Definition storeSA : SeparationAlgebra store := equiv_SA.

Definition Q_Join : Join Q := fun q1 q2 q =>
  0 <= q1 /\ 0 <= q2 /\ 0 <= q /\ q1 <= 1 /\ q2 <= 1 /\ q <= 1 /\ Qeq q (q1 + q2).

Definition Q_SA : @SeparationAlgebra Q Q_Join.
Proof.
  constructor; intros; unfold join, Q_Join in *;
  [| exists (mxyz - mx)]; repeat (split; try tauto; lra).
Qed.

Definition Z_Join : Join Z := equiv_Join.

Definition Z_SA : SeparationAlgebra Z:= equiv_SA.

Definition s_Join : Join (Q * Z):= @prod_Join _ _ Q_Join Z_Join.

Definition s_SA : SeparationAlgebra (Q * Z) := @prod_SA Q Z Q_Join Z_Join Q_SA Z_SA.

Definition heapJ : Join heap := @fun_Join _ _ (@option_Join _ (s_Join)).

Definition heapSA : SeparationAlgebra heap := @fun_SA _ _ _ (@option_SA _ _ (s_SA)).

Definition stateJ : Join state := @prod_Join _ _ storeJ heapJ.

Definition stateSA : SeparationAlgebra state := @prod_SA store heap storeJ heapJ storeSA heapSA.

Definition stateR : KripkeModel.KI.Relation (state) := fun x y => x = y.

Definition SepCon (P : Assertion) (Q : Assertion) : Assertion :=
  fun st => exists st1 st2, (P st1) /\ (Q st2) /\ (stateJ st1 st2 st).

Module NaiveLang <: LanguageSig.
  Definition expr := Assertion.
  Section NaiveLang.
    Definition context := expr -> Prop.
    Definition provable (e : expr) : Prop := forall st, e st.
    Definition impp (e1 e2 : expr) : expr := fun st => e1 st -> e2 st.
    Definition andp (e1 e2 : expr) : expr := fun st => e1 st /\ e2 st.
    Definition orp (e1 e2 : expr) : expr := fun st => e1 st \/ e2 st.
    Definition sepcon := SepCon.
    Definition negp (e : expr) : expr := fun st => ~ e st.
    Definition falsep : expr := fun st => False.
    Definition truep : expr := fun st => True.
    Definition emp : expr := fun st => forall p, snd st p = None.
  End NaiveLang.
End NaiveLang.

Module NaiveRule.
Include DerivedNames (NaiveLang).

Instance L : Language := (Build_Language expr) .
Instance minL : (MinimumLanguage L) := (Build_MinimumLanguage L impp) .
Instance andpL : (AndLanguage L) := (Build_AndLanguage L andp) .
Instance sepconL : (SepconLanguage L) := (Build_SepconLanguage L sepcon) .
Instance falsepL : (FalseLanguage L) := (Build_FalseLanguage L falsep) .

Lemma falsep_sepcon_impp : (forall x : expr, provable (impp (sepcon falsep x) falsep)) .
Proof.
  unfold provable, impp, sepcon, falsep. intros.
  destruct H as [st1 [st2 ?]]. tauto.
Qed.

Lemma sepcon_comm_impp : (forall x y : expr, provable (impp (sepcon x y) (sepcon y x))) .
Proof.
  intros x y.
  pose proof (@sound_sepcon_comm L _ _ (Build_Model state) (unit_kMD _) tt stateR stateJ stateSA (Pred_SM _) (Pred_kminSM _) (Pred_fsepconSM _) x y).
Admitted.
  (* exact (@sound_sepcon_comm L _ _ (Build_Model state) (unit_kMD _) tt stateR stateJ stateSA (Pred_SM _) (Pred_kminSM _) (Pred_fsepconSM _) x y).
Qed. *)

Lemma sepcon_assoc1 : (forall x y z : expr, provable (impp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) .
Proof.
  intros x y z.
Admitted.
  (* exact (@sound_sepcon_assoc1 L _ _ (Build_Model state) (unit_kMD _) tt stateR stateJ stateSA (Pred_SM _) (Pred_kminSM _) (Pred_fsepconSM _) x y z).
Qed.  *)

Lemma sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
Proof.
  unfold provable, impp, sepcon, SepCon; intros.
  destruct H1 as [st1 [st2 ?]]; exists st1, st2.
  specialize (H st1); specialize (H0 st2); tauto.
Qed.

Lemma andp_intros : (forall x y : expr, provable (impp x (impp y (andp x y)))) .
Proof.
  unfold provable, impp, andp. auto.
Qed.

Lemma andp_elim1 : (forall x y : expr, provable (impp (andp x y) x)) .
Proof.
  unfold provable, impp, andp. tauto.
Qed.

Lemma andp_elim2 : (forall x y : expr, provable (impp (andp x y) y)) .
Proof.
  unfold provable, impp, andp. tauto.
Qed.

Lemma modus_ponens : (forall x y : expr, provable (impp x y) -> provable x -> provable y) .
Proof.
  unfold provable, impp, andp. auto.
Qed.

Lemma axiom1 : (forall x y : expr, provable (impp x (impp y x))) .
Proof.
  unfold provable, impp. auto.
Qed.

Lemma axiom2 : (forall x y z : expr, provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z)))) .
Proof.
  unfold provable, impp. auto.
Qed.

End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
Import T.


Require Import
        Coq.omega.Omega
        Fiat.Narcissus.Common.Notations
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt.
Require Export
        Coq.Lists.List.

Notation "| ls |" := (Datatypes.length ls) : format_scope.

Section FixList.
  Context {A : Type}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {monoid : Monoid B}.

  Variable A_predicate : A -> Prop.
  Variable A_predicate_rest : A -> B -> Prop.
  Variable format_A : A -> CacheFormat -> Comp (B * CacheFormat).
  Variable A_decode : B -> CacheDecode -> option (A * B * CacheDecode).
  Variable A_cache_inv : CacheDecode -> Prop.
  Variable A_decode_pf : CorrectDecoder monoid A_predicate A_predicate_rest format_A A_decode A_cache_inv.

  (* Ben: Should we do this with a FixComp instead? *)
  Fixpoint format_list (xs : list A) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    match xs with
    | nil => ret (mempty, ce)
    | x :: xs' => `(b1, env1) <- format_A x ce;
                  `(b2, env2) <- format_list xs' env1;
                  ret (mappend b1 b2, env2)
    end%comp.

  Fixpoint encode_list
           (encode_A : A -> CacheFormat -> B * CacheFormat)
           (xs : list A) (ce : CacheFormat)
    : B * CacheFormat :=
    match xs with
    | nil => (mempty, ce)
    | x :: xs' =>  let (b1, env1) := encode_A x ce in
                   let (b2, env2) := encode_list encode_A xs' env1 in
                   (mappend b1 b2, env2)
    end%comp.

  Fixpoint decode_list (s : nat) (b : B) (cd : CacheDecode) : option (list A * B * CacheDecode) :=
    match s with
    | O => Some (nil, b, cd)
    | S s' => `(x, b1, e1) <- A_decode b cd;
              `(xs, b2, e2) <- decode_list s' b1 e1;
              Some (x :: xs, b2, e2)
    end.

  Fixpoint FixList_predicate_rest
           (As : list A)
           (b : B)
    : Prop :=
    match As with
    | nil => True
    | cons a As' =>
      (forall b' ce ce',
          computes_to (format_list As' ce) (b', ce')
          -> A_predicate_rest a (mappend b' b))
      /\ FixList_predicate_rest As' b
    end.

  Theorem FixList_decode_correct
    :
    forall sz ,
      CorrectDecoder
         monoid
        (fun ls => |ls| = sz /\ forall x, In x ls -> A_predicate x)
        FixList_predicate_rest
        format_list (decode_list sz) A_cache_inv.
  Proof.
    split.
    {
      intros env env' xenv l l' ext ? Eeq Ppred Ppred_rest Penc.
      intuition; subst.
      revert H0.
      generalize dependent env. generalize dependent env'.
      generalize dependent xenv.
      generalize dependent l'. induction l.
      { intros.
        simpl in *; intuition; computes_to_inv;
          injections; simpl.
        rewrite mempty_left; eexists; eauto. }
      { intros; simpl in *.
        assert (A_predicate a) by eauto.
        unfold Bind2 in Penc; computes_to_inv; subst.
        destruct v; destruct v0; simpl in *.
        injections.
        destruct (fun H' => proj1 A_decode_pf _ _ _ _ _ (mappend b0 ext) env_OK Eeq H H' Penc) as [ ? [? [? xenv_OK] ] ].
        intuition; destruct_ex.
        eapply H1; eauto.
        setoid_rewrite <- mappend_assoc; setoid_rewrite H1;
          simpl.
        destruct (IHl (proj2 Ppred_rest) b0 xenv x xenv_OK c); intuition eauto.
        setoid_rewrite H6; simpl.
        eexists; intuition.
      }
    }
    { induction sz; simpl; intros.
      - injections; simpl; repeat eexists; intuition eauto.
        symmetry; apply mempty_left.
      - destruct (A_decode bin env') as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate.
        destruct (decode_list sz b c) as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate; injections.
        eapply (proj2 A_decode_pf) in Heqo; eauto;
          destruct Heqo; destruct_ex; intuition; subst;
            eapply IHsz in Heqo0; eauto; destruct Heqo0;
              destruct_ex; intuition; subst.
        simpl.
        eexists; eexists; intuition eauto.
        computes_to_econstructor; eauto.
        computes_to_econstructor; eauto.
        rewrite mappend_assoc; reflexivity.
        subst; eauto.
    }
  Qed.

  Definition format_list_body
               (A_format_Impl : A -> CacheFormat -> B * CacheFormat)
:= (fun (acc: B * CacheFormat) x =>
                                    let (bacc, env) := acc in
                                       let (b1, env1) := A_format_Impl x env in
                                       (mappend bacc b1, env1)).

  Lemma format_list_body_characterization A_format_Impl :
    forall xs base env,
      fold_left (format_list_body A_format_Impl) xs (base, env) =
      (let (b2, env2) := fold_left (format_list_body A_format_Impl) xs (mempty, env) in
       (mappend base b2, env2)).
  Proof.
    induction xs; simpl.
    + intros; rewrite mempty_right; reflexivity.
    + intros; destruct (A_format_Impl _ _).
      rewrite IHxs, mempty_left, (IHxs b).
      destruct (fold_left _ _ _).
      rewrite mappend_assoc; reflexivity.
  Qed.

  Lemma format_list_as_foldl encode_A :
    forall xs env,
      encode_list encode_A xs env =
      fold_left (format_list_body encode_A) xs (mempty, env).
  Proof.
    induction xs; simpl.
    + reflexivity.
    + intros; destruct (encode_A _ _).
      rewrite IHxs, mempty_left, (format_list_body_characterization encode_A xs b c).
      destruct (fold_left _ _ _); reflexivity.
  Qed.

  Lemma measure_format_length_Spec n :
    (forall (a : A) b ctx ctx',
        computes_to (format_A a ctx) (b, ctx')
        -> bin_measure b = n)
    -> forall l b ctx ctx',
      computes_to (format_list l ctx) (b, ctx') ->
      bin_measure b = n * (length l).
  Proof.
    induction l; simpl; intros.
    - computes_to_inv; injections.
      pose proof (mappend_measure mempty mempty) as H';
        rewrite mempty_left in H'.
      simpl bin_measure in H'; simpl mempty in H'; omega.
    - unfold Bind2 in *; computes_to_inv; injections.
      destruct v; destruct v0; simpl in *.
      rewrite mappend_measure.
      apply H in H0; rewrite H0.
      apply IHl in H0'; rewrite H0'.
      rewrite Mult.mult_succ_r.
      auto with arith.
  Qed.

End FixList.

Lemma FixedList_predicate_rest_True {A B}
      {cache : Cache}
      {monoid : Monoid B}
      (format_A : A -> CacheFormat -> Comp (B * CacheFormat))
  : forall (l : list A) (b : B),
    FixList_predicate_rest (fun a b => True) format_A l b.
Proof.
  induction l; simpl; eauto.
Qed.


Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.

Local Open Scope cat.

(** The bicategory *)
Definition pointed_one_type_bicat_data
  : prebicat_data.
Proof.
  use build_prebicat_data.
  - exact (∑ (X : one_type), X).
  - exact (λ X Y, ∑ (f : pr1 X → pr1 Y), f (pr2 X) = pr2 Y).
  - exact (λ X Y f g, ∑ (h : pr1 f = pr1 g),
           transportf (λ φ, φ (pr2 X) = pr2 Y) h (pr2 f) = pr2 g).
  - exact (λ X, (λ x, x) ,, idpath _).
  - exact (λ X Y Z f g, (λ x,pr1 g(pr1 f x)) ,, maponpaths (pr1 g) (pr2 f) @ pr2 g).
  - exact (λ X Y f, idpath _ ,, idpath _).
  - refine (λ X Y f g h p q, (pr1 p @ pr1 q) ,, _) ; cbn in *.
    exact (!(transport_f_f _ _ _ _) @ maponpaths _ (pr2 p) @ pr2 q).
  - refine (λ X Y Z f g h p, (maponpaths (λ φ x, φ (pr1 f x)) (pr1 p)) ,, _) ; cbn in *.
    induction g as [g1 g2], h as [h1 h2], p as [p1 p2] ; cbn in *.
    induction p1, p2 ; cbn.
    apply idpath.
  - refine (λ X Y Z f g h p, (maponpaths (λ φ x, pr1 h (φ x)) (pr1 p)) ,, _) ; cbn in *.
    induction g as [g1 g2], h as [h1 h2], p as [p1 p2] ; cbn in *.
    induction p1, p2 ; cbn.
    apply idpath.
  - exact (λ X Y f, idpath _ ,, idpath _).
  - exact (λ X Y f, idpath _ ,, idpath _).
  - refine (λ X Y f, idpath _ ,, _) ; cbn in *.
    exact (pathscomp0rid _ @ maponpathsidfun _).
  - refine (λ X Y f, idpath _ ,, _) ; cbn in *.
    exact (!(pathscomp0rid _ @ maponpathsidfun _)).
  - refine (λ W X Y Z f g h, idpath _ ,, _) ; cbn in *.
    refine (path_assoc _ _ _ @ _).
    apply maponpaths_2.
    refine (_ @ !(maponpathscomp0 _ _ _)).
    apply maponpaths_2.
    exact (!(maponpathscomp _ _ _)).
  - refine (λ W X Y Z f g h, idpath _ ,, ! _) ; cbn in *.
    refine (path_assoc _ _ _ @ _).
    apply maponpaths_2.
    refine (_ @ !(maponpathscomp0 _ _ _)).
    apply maponpaths_2.
    exact (!(maponpathscomp _ _ _)).
Defined.

Lemma pointed_one_type_bicat_laws
  : prebicat_laws pointed_one_type_bicat_data.
Proof.
  repeat (use tpair).
  - intros X Y f g p ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], p as [p1 p2] ; cbn in *.
    induction p1 ; cbn.
    apply idpath.
  - intros X Y f g p ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], p as [p1 p2] ; cbn in *.
    induction p1, p2 ; cbn.
    apply idpath.
  - intros X Y f g h k p q r ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], h as [h1 h2], k as [k1 k2].
    induction p as [p1 p2], q as [q1 q2], r as [r1 r2] ; cbn in *.
    induction p1, p2, q1, q2, r1, r2.
    apply idpath.
  - intros; apply idpath.
  - intros; apply idpath.
  - intros X Y Z f g h i p q ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2].
    induction p as [p1 p2], q as [q1 q2] ; cbn in *.
    induction p1, p2, q1, q2 ; cbn.
    apply idpath.
  - intros X Y Z f g h i p q ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2].
    induction p as [p1 p2], q as [q1 q2] ; cbn in *.
    induction p1, p2, q1, q2 ; cbn.
    apply idpath.
  - intros X Y f g p ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], p as [p1 p2] ; cbn in *.
    induction p1, p2 ; cbn.
    apply idpath.
  - intros X Y f g p ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], p as [p1 p2] ; cbn in *.
    induction p1, p2, f2 ; cbn.
    apply idpath.
  - intros W X Y Z f g h i p ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2].
    induction p as [p1 p2] ; cbn in *.
    induction p1, p2, f2, g2, h2 ; cbn.
    apply idpath.
  - intros W X Y Z f g h i p ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2].
    induction p as [p1 p2] ; cbn in *.
    induction p1, p2, f2, g2 ; cbn.
    apply idpath.
  - intros W X Y Z f g h i p ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2].
    induction p as [p1 p2] ; cbn in *.
    induction p1, p2, f2, h2 ; cbn.
    apply idpath.
  - intros X Y Z f g h i p q ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2].
    induction p as [p1 p2], q as [q1 q2] ; cbn in *.
    induction p1, p2, q1, q2, f2, h2 ; cbn.
    apply idpath.
  - intros; apply idpath.
  - intros; apply idpath.
  - intros X Y p ; cbn in *.
    induction p as [p1 p2].
    induction p2 ; cbn.
    apply idpath.
  - intros X Y p ; cbn in *.
    induction p as [p1 p2].
    induction p2 ; cbn.
    apply idpath.
  - intros W X Y Z f g h ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], h as [h1 h2] ; cbn in *.
    induction f2, g2, h2 ; cbn.
    apply idpath.
  - intros W X Y Z f g h ; cbn in *.
    induction f as [f1 f2], g as [g1 g2], h as [h1 h2] ; cbn in *.
    induction f2, g2, h2 ; cbn.
    apply idpath.
  - intros X Y Z f g ; cbn in *.
    induction f as [f1 f2], g as [g1 g2] ; cbn in *.
    induction f2, g2 ; cbn.
    apply idpath.
  - intros V W X Y Z f g h i.
    induction f as [f1 f2], g as [g1 g2], h as [h1 h2], i as [i1 i2] ; cbn in *.
    induction f2, g2, h2, i2 ; cbn.
    apply idpath.
Qed.

Definition pointed_one_types
  : bicat.
Proof.
  use build_bicategory.
  - exact pointed_one_type_bicat_data.
  - exact pointed_one_type_bicat_laws.
  - intros X Y f g ; cbn in *.
    use isaset_total2.
    + exact (impredfun 3 (pr1 X) (pr1 Y) (pr21 Y) (pr1 f) (pr1 g)).
    + intro ; cbn.
      repeat intro.
      apply hlevelntosn.
      apply (pr21 Y).
Defined.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Export NOrder.

Module NAddOrderProp (Import N : NAxiomsMiniSig').
Include NOrderProp N.

(** Theorems true for natural numbers, not for integers *)

Theorem le_add_r : forall n m, n <= n + m.
Proof.
intro n; induct m.
rewrite add_0_r; now apply eq_le_incl.
intros m IH. rewrite add_succ_r; now apply le_le_succ_r.
Qed.

Theorem lt_lt_add_r : forall n m p, n < m -> n < m + p.
Proof.
intros n m p H; rewrite <- (add_0_r n).
apply add_lt_le_mono; [assumption | apply le_0_l].
Qed.

Theorem lt_lt_add_l : forall n m p, n < m -> n < p + m.
Proof.
intros n m p; rewrite add_comm; apply lt_lt_add_r.
Qed.

Theorem add_pos_l : forall n m, 0 < n -> 0 < n + m.
Proof.
intros; apply add_pos_nonneg. assumption. apply le_0_l.
Qed.

Theorem add_pos_r : forall n m, 0 < m -> 0 < n + m.
Proof.
intros; apply add_nonneg_pos. apply le_0_l. assumption.
Qed.

End NAddOrderProp.


(* Andrew W. Appel and Stephen Yi-Hsien Lin,
    May 2013, October 2013, March 2014 *)

Require Recdef.
Require Import VST.floyd.coqlib3.
Require Import VST.floyd.sublist.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Coqlib.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import List.
Require Import sha.general_lemmas.

(* THIS BLOCK OF STUFF is not needed to define SHA256,
  but is useful for reasoning about it *)
Definition LBLOCKz : Z := 16. (* length of a block, in 32-bit integers *)
Definition WORD : Z := 4.  (* length of a word, in bytes *)
Definition CBLOCKz : Z := (LBLOCKz * WORD)%Z. (* length of a block, in characters *)
Definition hi_part (z: Z) := Int.repr (z / Int.modulus).
Definition lo_part (z: Z) := Int.repr z.

Fixpoint little_endian_integer (contents: list byte) : int :=
 match contents with
 | nil => Int.zero
 | c::cr => Int.or (Int.shl (little_endian_integer cr) (Int.repr 8)) (Int.repr (Byte.unsigned c))
 end.

Definition big_endian_integer (contents: list byte) : int :=
   little_endian_integer (rev contents).

(* END OF "THIS BLOCK OF STUFF" *)

Import ListNotations.

(* PREPROCESSING: CONVERTING STRINGS TO PADDED MESSAGE BLOCKS *)

(*converting a string to a list of Z *)
Fixpoint str_to_bytes (str : string) : list byte :=
  match str with
    |EmptyString => nil
    |String c s => Byte.repr (Z.of_N (N_of_ascii c)) :: str_to_bytes s
    end.

Definition generate_and_pad msg :=
  let n := Zlength msg in
   bytelist_to_intlist (msg ++ [Byte.repr 128%Z]
                ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) Byte.zero)
           ++ [Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)].

(*ROUND FUNCTION*)

(*hardcoding the constants, first 32 bits of the fractional parts of the cube roots of the first 64 prime numbers*)
Definition K256 := map Int.repr
  [1116352408 ; 1899447441; 3049323471; 3921009573;
   961987163   ; 1508970993; 2453635748; 2870763221;
   3624381080; 310598401  ; 607225278  ; 1426881987;
   1925078388; 2162078206; 2614888103; 3248222580;
   3835390401; 4022224774; 264347078  ; 604807628;
   770255983  ; 1249150122; 1555081692; 1996064986;
   2554220882; 2821834349; 2952996808; 3210313671;
   3336571891; 3584528711; 113926993  ; 338241895;
   666307205  ; 773529912  ; 1294757372; 1396182291;
   1695183700; 1986661051; 2177026350; 2456956037;
   2730485921; 2820302411; 3259730800; 3345764771;
   3516065817; 3600352804; 4094571909; 275423344;
   430227734  ; 506948616  ; 659060556  ; 883997877;
   958139571  ; 1322822218; 1537002063; 1747873779;
   1955562222; 2024104815; 2227730452; 2361852424;
   2428436474; 2756734187; 3204031479; 3329325298].

(*functions used for round function*)
Definition Ch (x y z : int) : int :=
  Int.xor (Int.and x y) (Int.and (Int.not x) z).

Definition Maj (x y z : int) : int :=
  Int.xor (Int.xor (Int.and x z) (Int.and y z) ) (Int.and x y).

Definition Rotr b x := Int.ror x (Int.repr b).

Definition Sigma_0 (x : int) : int :=
          Int.xor (Int.xor (Rotr 2 x) (Rotr 13 x)) (Rotr 22 x).
Definition Sigma_1 (x : int) : int :=
          Int.xor (Int.xor (Rotr 6 x) (Rotr 11 x)) (Rotr 25 x).
Definition sigma_0 (x : int) : int :=
          Int.xor (Int.xor (Rotr 7 x) (Rotr 18 x)) (Shr 3 x).
Definition sigma_1 (x : int) : int :=
          Int.xor (Int.xor (Rotr 17 x) (Rotr 19 x)) (Shr 10 x).

(* word function *)
Function W (M: Z -> int) (t: Z) {measure Z.to_nat t} : int :=
  if zlt t 16
  then M t
  else  (Int.add (Int.add (sigma_1 (W M (t-2))) (W M (t-7)))
               (Int.add (sigma_0 (W M (t-15))) (W M (t-16)))).
Proof.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
Qed.

(*registers that represent intermediate and final hash values*)
Definition registers := list int.

(*initializing the values of registers, first thirty-two bits of the fractional
    parts of the square roots of the first eight prime numbers*)
Definition init_registers : registers :=
  map Int.repr  [1779033703; 3144134277; 1013904242; 2773480762;
                        1359893119; 2600822924; 528734635; 1541459225].

Definition nthi (il: list int) (t: Z) := nth (Z.to_nat t) il Int.zero.

Definition rnd_function (x : registers) (k : int) (w : int) : registers:=
  match x with
  |  [a; b; c; d; e; f; g; h] =>
     let T1 := Int.add (Int.add (Int.add (Int.add h (Sigma_1 e)) (Ch e f g)) k) w in
     let T2 := Int.add (Sigma_0 a) (Maj a b c) in
       [Int.add T1 T2; a; b; c; Int.add d T1; e; f; g]
  | _ => nil  (* impossible *)
  end.

Function Round  (regs: registers) (M: Z ->int) (t: Z)
        {measure (fun t => Z.to_nat(t+1)) t} : registers :=
 if zlt t 0 then regs
 else rnd_function (Round regs M (t-1)) (nthi K256 t) (W M t).
Proof. intros; apply Z2Nat.inj_lt; omega.
Qed.

Definition hash_block (r: registers) (block: list int) : registers :=
      map2 Int.add r (Round r (nthi block) 63).

Function hash_blocks (r: registers) (msg: list int) {measure length msg} : registers :=
  match msg with
  | nil => r
  | _ => hash_blocks (hash_block r (firstn 16 msg)) (skipn 16 msg)
  end.
Proof. intros.
 destruct (lt_dec (length msg) 16).
 rewrite skipn_length_short. simpl; omega. subst; simpl in *; omega.
 rewrite <- teq; auto.
 rewrite skipn_length. simpl; omega.
Qed.

Definition SHA_256 (str : list byte) : list byte :=
    intlist_to_bytelist (hash_blocks init_registers (generate_and_pad str)).


Require Import WildCat.
Require Import Algebra.Congruence.
Require Import Algebra.AbGroups.
Require Import Algebra.Rings.CRing.
Require Import Algebra.Rings.Ideal.

(** In this file we define the quotient of a commutative ring by an ideal *)

Import Ideal.Notation.
Local Open Scope ring_scope.
Local Open Scope wc_iso_scope.

(** In this file we define the quotient of a commutative ring by an ideal and prove some basic facts. *)

Section QuotientRing.

  Context (R : CRing) (I : Ideal R).

  Instance plus_quotient_group : Plus (QuotientAbGroup R I) := group_sgop.

  Instance iscong_mult_incosetL
    : @IsCongruence R cring_mult (in_cosetL I).
  Proof.
    snrapply Build_IsCongruence.
    intros x x' y y' p q.
    change (I ( - (x * y) + (x' * y'))).
    change (I (-x + x')) in p.
    change (I (-y + y')) in q.
    rewrite <- (left_identity (op:=(+)) (x' * y') : 0 + (x' * y') = x' * y').
    rewrite <- (right_inverse (op:=(+)) (x' * y) : (x' * y) - (x' * y) = 0).
    rewrite 2 simple_associativity.
    rewrite negate_mult_distr_l.
    rewrite <- simple_distribute_r.
    rewrite <- simple_associativity.
    rewrite negate_mult_distr_r.
    rewrite <- simple_distribute_l.
    rapply subgroup_in_op.
    1: rewrite (commutativity _ y).
    all: by rapply isideal.
  Defined.

  Instance mult_quotient_group : Mult (QuotientAbGroup R I).
  Proof.
    intro x.
    srapply Quotient_rec.
    { intro y; revert x.
      srapply Quotient_rec.
      { intro x.
        apply class_of.
        exact (x * y). }
      intros x x' p.
      apply qglue.
      by rapply iscong. }
    intros y y' q.
    revert x.
    srapply Quotient_ind_hprop.
    intro x.
    simpl.
    apply qglue.
    by rapply iscong.
  Defined.

  Instance zero_quotient_abgroup : Zero (QuotientAbGroup R I) := class_of _ zero.
  Instance one_quotient_abgroup : One (QuotientAbGroup R I) := class_of _ one.

  Instance isring_quotient_abgroup : IsRing (QuotientAbGroup R I).
  Proof.
    split.
    1: exact _.
    1: repeat split.
    1: exact _.
    (** Associativity follows from the underlying operation *)
    { intros x y.
      snrapply Quotient_ind_hprop; [exact _ | intro z; revert y].
      snrapply Quotient_ind_hprop; [exact _ | intro y; revert x].
      snrapply Quotient_ind_hprop; [exact _ | intro x ].
      unfold sg_op, mult_is_sg_op, mult_quotient_group; simpl.
      apply ap.
      apply associativity. }
    (* Left and right identity follow from the underlying structure *)
    1,2: snrapply Quotient_ind_hprop; [exact _ | intro x].
    1-2: unfold sg_op, mult_is_sg_op, mult_quotient_group; simpl.
    1-2: apply ap.
    1: apply left_identity.
    1: apply right_identity.
    (** Commutativity also follows *)
    { intros x.
      snrapply Quotient_ind_hprop; [exact _ | intro y; revert x].
      snrapply Quotient_ind_hprop; [exact _ | intro x].
      unfold sg_op, mult_is_sg_op, mult_quotient_group; simpl.
      apply ap.
      apply commutativity. }
    (** Finally distributivity also follows *)
    { intros x y.
      snrapply Quotient_ind_hprop; [exact _ | intro z; revert y].
      snrapply Quotient_ind_hprop; [exact _ | intro y; revert x].
      snrapply Quotient_ind_hprop; [exact _ | intro x ].
      unfold sg_op, mult_is_sg_op, mult_quotient_group,
        plus, mult, plus_quotient_group; simpl.
      apply ap.
      apply simple_distribute_l. }
  Defined.

  Definition QuotientRing : CRing
    := Build_CRing (QuotientAbGroup R I) _ _ _ _ _ _.

End QuotientRing.

Infix "/" := QuotientRing : ring_scope.

(** Quotient map *)
Definition rng_quotient_map {R : CRing} (I : Ideal R)
  : CRingHomomorphism R (R / I).
Proof.
  snrapply Build_CRingHomomorphism'.
  1: rapply grp_quotient_map.
  repeat split.
Defined.

Global Instance issurj_rng_quotient_map {R : CRing} (I : Ideal R)
  : IsSurjection (rng_quotient_map I).
Proof.
  exact _.
Defined.

(** *** Specialized induction principles *)

(** We provide some specialized induction principes for [QuotientRing] that require cleaner hypotheses than the ones given by [Quotient_ind]. *)
Definition QuotientRing_ind {R : CRing} {I : Ideal R} (P : R / I -> Type)
  `{forall x, IsHSet (P x)}
  (c : forall (x : R), P (rng_quotient_map I x))
  (g : forall (x y : R) (h : I (- x + y)), qglue h # c x = c y)
  : forall (r : R / I), P r
  := Quotient_ind _ P c g.

(** And a version eliminating into hprops. This one is especially useful. *)
Definition QuotientRing_ind_hprop {R : CRing} {I : Ideal R} (P : R / I -> Type)
  `{forall x, IsHProp (P x)} (c : forall (x : R), P (rng_quotient_map I x))
  : forall (r : R / I), P r
  := Quotient_ind_hprop _ P c.

(** ** Quotient thoery *)

(** First isomorphism theorem for commutative rings *)
Definition rng_first_iso `{Funext} {A B : CRing} (f : A $-> B)
  : A / ideal_kernel f ≅ rng_image f.
Proof.
  snrapply Build_CRingIsomorphism''.
  1: rapply abgroup_first_iso.
  split.
  { intros x y.
    revert y; srapply QuotientRing_ind_hprop; intros y.
    revert x; srapply QuotientRing_ind_hprop; intros x.
    srapply path_sigma_hprop.
    exact (rng_homo_mult _ _ _). }
  srapply path_sigma_hprop.
  exact (rng_homo_one _).
Defined.

(** Invariance of equal ideals *)
Lemma rng_quotient_invar {R : CRing} {I J : Ideal R} (p : (I ↔ J)%ideal)
  : R / I ≅ R / J.
Proof.
  snrapply Build_CRingIsomorphism'.
  { srapply equiv_quotient_functor'.
    1: exact equiv_idmap.
    intros x y; cbn.
    apply p. }
  repeat split.
  1,2: intros x; simpl.
  1,2: srapply QuotientRing_ind_hprop.
  1,2: intros y; revert x.
  1,2: srapply QuotientRing_ind_hprop.
  1,2: intros x; rapply qglue.
  1: change (J ( - (x + y) + (x + y))).
  2: change (J (- ( x * y) + (x * y))).
  1,2: rewrite rng_plus_negate_l.
  1,2: apply ideal_in_zero.
Defined.

(** We phrase the first ring isomorphism theroem in a slightly differnt way so that it is easier to use. This form specifically asks for a surjective map *)
Definition rng_first_iso' `{Funext} {A B : CRing} (f : A $-> B)
  (issurj_f : IsSurjection f)
  (I : Ideal A) (p : (I ↔ ideal_kernel f)%ideal)
  : A / I ≅ B.
Proof.
  etransitivity.
  1: apply (rng_quotient_invar p).
  etransitivity.
  2: rapply (rng_image_issurj f).
  apply rng_first_iso.
Defined.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Trivial.
Require Import Logic.ModalLogic.Syntax.
Require Import Logic.ModalLogic.Model.KripkeModel.
Require Import Logic.ModalLogic.Model.OrderedKripkeModel.
Require Import Logic.ModalLogic.Semantics.Kripke.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import ModalLanguageNotation.
Import KripkeModelFamilyNotation.

Section Sound_Kripke.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {mL: ModalLanguage L}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {SM: Semantics L MD}
        {tminSM: TrivialMinimunSemantics L MD SM}
        {tpSM: TrivialPropositionalSemantics L MD SM}
        {kmSM: KripkeModalSemantics L MD M SM}.

Lemma sound_axiom_K:
  forall x y (m: Kworlds M),
    KRIPKE: M, m |= boxp (x --> y) --> (boxp x --> boxp y).
Proof.
  intros.
  rewrite !sat_impp, !sat_boxp.
  intros.
  specialize (H _ H1).
  specialize (H0 _ H1).
  rewrite sat_impp in H.
  auto.
Qed.

Lemma sound_rule_N:
  forall x,
    (forall (m: Kworlds M), KRIPKE: M, m |= x) ->
    (forall (m: Kworlds M), KRIPKE: M, m |= boxp x).
Proof.
  intros.
  rewrite sat_boxp.
  intros; apply H; auto.
Qed.

Lemma sound_boxp_orp {pf_R: PartialFunctional KM.Krelation}:
  forall x y (m: Kworlds M),
    KRIPKE: M, m |= boxp (x || y) <--> (boxp x || boxp y).
Proof.
  intros.
  unfold iffp.
  rewrite sat_andp, !sat_impp, !sat_orp, !sat_boxp.
  split; intros.
  + apply NNPP.
    intro.
    apply not_or_and in H0; destruct H0.
    apply not_all_ex_not in H0; destruct H0 as [n1 ?].
    apply not_all_ex_not in H1; destruct H1 as [n2 ?].
    apply imply_to_and in H0; destruct H0.
    apply imply_to_and in H1; destruct H1.
    pose proof partial_functionality _ _ _ H0 H1.
    subst n2; clear H1.
    specialize (H _ H0).
    rewrite sat_orp in H.
    tauto.
  + rewrite sat_orp.
    destruct H; [left | right]; auto.
Qed.

End Sound_Kripke.


(* Pythagorean.v *)

(***********************)
(* Pythagorean triples *)
(***********************)

Require Export Tactics.

(* A non nul predicate *)
Definition nnl_triple (a b c : Z) := ~(a = 0) /\ ~(b = 0) /\ ~(c = 0).

(* A positive predicate *)
Definition pos_triple (a b c : Z) := (a >= 0) /\ (b >= 0) /\ (c >= 0).

(* A Pythagorean predicate *)
Definition is_pytha (a b c : Z) := (pos_triple a b c) /\ a * a + b * b = c * c.

(* Unit circle and D_r *)
Definition in_ucirc (x y : R) := (x * x + y * y = 1)%R.
Definition D_r (r x y : R) := (y = r * (x + 1))%R.

(******************************)
(* Set of Pythagorean triples *)
(******************************)

(* step1 *)

Lemma pytha_ucirc1 : forall a b c : Z,
  (c > 0) -> (is_pytha a b c) -> (in_ucirc (frac a c) (frac b c)).
Proof.
  intros; unfold in_ucirc; unfold frac; field_simplify_eq.
  unfold is_pytha in H0; elim H0; intros.
  repeat rewrite pow_IZR. rewrite <- plus_IZR. simpl Z_of_nat.
  ring_simplify [(sym_eq H2)] (c^2);trivial.
  discrR; auto with zarith.
Qed.

Lemma pytha_ucirc2 : forall a b c : Z, (a >= 0) /\ (b >= 0) /\ (c > 0) ->
  (in_ucirc (frac a c) (frac b c)) -> (is_pytha a b c).
Proof.
  unfold in_ucirc; unfold frac; unfold is_pytha; intros; split.
  unfold pos_triple; auto with zarith.
 apply eq_IZR; apply (Rmult_eq_reg_l (/ (IZR c * IZR c))).
 pattern (IZR c * IZR c)%R at 2; rewrite <- mult_IZR;rewrite Rinv_l.
 rewrite Rinv_mult_distr.
 rewrite <- H0; rewrite plus_IZR; repeat rewrite mult_IZR; field.
 discrR; auto with zarith.
 discrR; auto with zarith.
 discrR; auto with zarith.
 rewrite mult_IZR; split_Rmult; discrR; auto with zarith.
 apply Rinv_neq_0_compat; split_Rmult; discrR; auto with zarith.
Qed.

(* step 2 *)

(* Intersection between the unit circle and D_r *)
Definition interCDr (r x y : R) := (in_ucirc x y) /\ (D_r r x y).

(* Points of the intersection *)
Definition p1 := (-1,0)%R.
Definition p2 (r : R) :=
  let den := (1 + r * r)%R in
  ((1 - r * r) / den, 2 * r / den)%R.

(* Equality over points *)
Definition eqp (p1 p2 : R * R) := (fst p1) = (fst p2) /\ (snd p1)= (snd p2).

(* Total order over points (using R) *)
Lemma ordp : forall p1 p2 : R * R, (eqp p1 p2) \/ ~(eqp p1 p2).
Proof.
  intros p3 p4. unfold eqp; elim p3; elim p4; intros; simpl.
  elim (Req_dec a a0); elim (Req_dec b b0); intuition.
Qed.

(* Characterization of the intersection *)
Lemma interCDr_sol : forall r x y : R,
  (interCDr r x y) -> (eqp (x,y) p1) \/ (eqp (x,y) (p2 r)).
Proof.
  unfold interCDr;unfold in_ucirc;unfold D_r;unfold eqp, p1, p2;simpl.
  intros;elim H;intros;rewrite H1 in H0.
  cut (((1 + r * r) * Rsqr x + 2 * r * r * x + (r * r - 1)) = 0)%R.
  intro;cut ((1 + r * r) <> 0)%R.
  intro;cut (Delta_is_pos (mknonzeroreal (1 + r * r) H3) (2 * r * r)
            (r * r - 1))%R.
  intro;generalize (Rsqr_sol_eq_0_0 (mknonzeroreal (1 + r * r) H3) (2 * r * r)
                                    (r * r - 1) x H4 H2)%R.
  unfold sol_x1, sol_x2;unfold Delta;unfold Rsqr;simpl.
  cut ((2 * r * r * (2 * r * r) - 4 * (1 + r * r) * (r * r - 1))%R = 4%R).
  intro;rewrite H5. replace (4)%R with (2*2)%R by auto.
  rewrite sqrt_square.
  induction 1;[right|left].
  split;[rewrite H6;field;assumption
        |rewrite H1;rewrite H6;field;assumption].
  split;[rewrite H6;field;assumption
        |rewrite H1;rewrite H6;field;assumption].
  unfold Rle;left;prove_sup.
  ring.
  unfold Delta_is_pos;unfold Delta;unfold Rsqr;simpl;
    ring_simplify (2 * r * r * (2 * r * r) - 4 * (1 + r * r) * (r * r - 1))%R;
    unfold Rle;left;prove_sup.
  apply Rgt_not_eq;unfold Rgt;rewrite Rplus_comm;apply Rle_lt_0_plus_1;
    fold (Rsqr r);elim (Req_dec r 0);intro;
    [rewrite H3;rewrite Rsqr_0;unfold Rle;right;auto
    |unfold Rle;left;apply Rsqr_pos_lt;assumption].
  pattern 1%R at 2;rewrite <- H0;unfold Rsqr;ring.
Qed.

(* step 3 *)

Lemma rat_coo1 : forall x y : R, (in_ucirc x y) /\
  (exists r : R, (is_rat r) /\ (interCDr r x y)) -> (is_ratp (x,y)).
Proof.
  unfold in_ucirc, is_ratp, is_rat.
  unfold frac; intros; elim H; intros; elim H1; intros; elim H2; intros;
    elim H3; intro; elim x1;intros; elim H5; intros;
    elim (interCDr_sol x0 x y H4); unfold eqp, p1, p2; simpl; intro; elim H8;
    intros; rewrite H9; rewrite H10.
  split.
  exists (-1,1); split; [ auto with zarith | simpl; field; discrR ].
  exists (0,1); split; [ auto with zarith | simpl; field; discrR ].
  split.
  exists (b * b - a * a, a * a + b * b); split.
  auto with zarith.
  rewrite H7; rewrite <- Z_R_minus; rewrite plus_IZR; repeat rewrite mult_IZR;
    field; split;discrR; auto with zarith reals.
  exists (2 * a * b * b, (a * a + b * b) * b); split.
  apply not_IZR_0; rewrite mult_IZR; split_Rmult; discrR; auto with zarith.
  rewrite H7; repeat rewrite mult_IZR; rewrite plus_IZR;
    repeat rewrite mult_IZR; simpl; field; split; discrR;
    auto with zarith reals.
Qed.

Lemma rat_coo2 : forall x y : R, (in_ucirc x y) /\ (is_ratp (x,y)) ->
  exists r : R, (is_rat r) /\ (interCDr r x y).
Proof.
  unfold in_ucirc, is_ratp, is_rat, interCDr.
  unfold frac, in_ucirc, D_r; intros.
  elim (Req_dec x (-1)%R); intro.
  exists 1%R; split.
  exists (1,1); split; [ auto with zarith | field; discrR ].
  elim H; intros; split.
  assumption.
  rewrite H0; rewrite H0 in H1; ring_simplify (1 * (-1 + 1))%R;
    cut ((1 + y * y) = 1)%R;
    [ intro; apply Rsqr_0_uniq; unfold Rsqr;
      apply (Rplus_0_r_uniq 1 (y * y) H3)%R
    | pattern 1%R at 2; rewrite <- H1; ring ].
  exists (y / (x + 1))%R; cut ((x + 1) <> 0)%R;
    [ intro; split
    | rewrite <- (Ropp_involutive 1); fold (x - -1)%R; apply Rminus_eq_contra;
      assumption ].
  elim H; intros; elim H3; intros; elim H4; intro; elim x0; intros; elim H6;
    intros; elim H5; intro; elim x1; intros; elim H9; intros; rewrite H8;
    rewrite H11.
  cut (a + b <> 0);
    [ intro
    | apply not_IZR_0;
      cut (((IZR a / IZR b + 1) * IZR b)%R = (IZR a + IZR b)%R);
        [ intro; rewrite plus_IZR; rewrite <- H12; split_Rmult;
          [ rewrite <- H8; assumption
          | discrR; assumption ]
        | field; discrR; assumption ] ].
  exists (a0 * b, b0 * (a + b)); split.
  apply not_IZR_0; rewrite mult_IZR; rewrite plus_IZR; split_Rmult; discrR;
    assumption.
  repeat rewrite mult_IZR; rewrite plus_IZR; field; discrR; try assumption.
  repeat split; discrR; try assumption; fold (IZR a / IZR b)%R;
    rewrite <- H8; assumption.
  split; [ elim H; intros; assumption | field; assumption ].
Qed.

(* step 4 *)

(* Positivity predicate over points *)
Definition is_posp (c : R * R) := (fst c >= 0)%R /\ (snd c >= 0)%R.

(* Predicate for the positive rational coordinates of the unit circle *)
Definition is_ucp (c : R * R) :=
  (in_ucirc (fst c) (snd c)) /\ (is_ratp c) /\ (is_posp c).

(* Positive rational coordinates of the unit circle *)
Definition ucp (p q : Z) :=
  let pr := (IZR p) in
  let qr := (IZR q) in
  let den := (pr * pr + qr * qr)%R in
  ((qr * qr - pr * pr) / den, (2 * pr * qr) / den)%R.

(* A basic condition over p and q *)
Definition cond_pqb (p q : Z) := p >= 0 /\ q > 0 /\ p <= q /\ (rel_prime p q).

(* Set of positive rational coordinates of the unit circle *)
Definition in_ucp_setb (x y : R) :=
  exists p : Z, exists q : Z,
  x = (fst (ucp p q)) /\ y = (snd (ucp p q)) /\ (cond_pqb p q).

Lemma rat_pos_coo1 : forall x y : R, (is_ucp (x,y)) ->
  exists r : R, (is_rat r) /\ (r >= 0)%R /\ (r <= 1)%R /\ x = (fst (p2 r)) /\
  y = (snd (p2 r)).
Proof.
  intros; unfold is_ucp in H; elim H; intros; elim H1; intros;
    elim (rat_coo2 x y (conj H0 H2)); intros; elim H4; intros.
  elim (interCDr_sol x0 x y).
  unfold eqp; simpl; intro; elim H7; intros; elim H3; simpl; intros;
    rewrite H8 in H10; elimtype False; generalize (Rge_le (-1) 0 H10)%R;
    fold (~ (0 <= -1)%R); apply Rlt_not_le; prove_sup.
  cut (0 < / (1 + x0 * x0))%R;
    [ intro
    | apply Rinv_0_lt_compat; rewrite <- (Rplus_0_r 0)%R;
      apply Rplus_lt_le_compat;
        [ prove_sup
        | fold (Rsqr x0); elim (Req_dec x0 0); intro;
          [ rewrite H7; rewrite Rsqr_0; unfold Rle; right; auto
          | unfold Rle; left; apply Rsqr_pos_lt; assumption ] ] ].
  unfold eqp; simpl; intro; elim H8; intros; elim H3; simpl; rewrite H9;
    rewrite H10; intros; exists x0; split.
  assumption.
  split.
  generalize (Rge_le (2 * x0 / (1 + x0 * x0)) 0 H12); intro;
    rewrite Rmult_comm in H13;
    rewrite <- (Rmult_0_l (2 / (1 + x0 * x0))) in H13;
    cut (0 < 2 / (1 + x0 * x0))%R;
      [ intro; rewrite Rmult_comm in H13; unfold Rdiv in H13;
        rewrite (Rmult_assoc x0 2) in H13;
        rewrite (Rmult_comm x0 (2 * / (1 + x0 * x0)))%R in H13;
        generalize (Rmult_le_reg_l (2 / (1 + x0 * x0)) 0 x0 H14 H13); intro;
        apply Rle_ge; assumption
      | unfold Rdiv; prove_sup; assumption ].
  split.
  generalize (Rge_le ((1 - x0 * x0) / (1 + x0 * x0)) 0 H11); intro;
    unfold Rdiv in H13; rewrite Rmult_comm in H13;
    rewrite <- (Rmult_0_r (/ (1 + x0 * x0)))%R in H13;
    generalize (Rmult_le_reg_l (/ (1 + x0 * x0)) 0 (1 - x0 * x0) H7 H13)%R;
    intro; generalize (Rplus_le_compat_r (x0 * x0) 0 (1 - x0 * x0) H14)%R;
    intro; rewrite Rplus_0_l in H15; unfold Rminus in H15;
    rewrite Rplus_assoc in H15; rewrite Rplus_opp_l in H15;
    rewrite Rplus_0_r in H15; rewrite <- (Rmult_1_r 1) in H15;
    fold (Rsqr x0) in H15; fold (Rsqr 1) in H15;
    apply (Rsqr_incr_0_var x0 1 H15); unfold Rle; left; prove_sup.
  auto.
  assumption.
Qed.

Lemma rat_pos_coo2 : forall x y : R, (is_ucp (x,y)) -> (in_ucp_setb x y).
Proof.
  intros; elim (rat_pos_coo1 x y H); simpl; intros; elim H0; intros; elim H2;
    intros; elim H4; intros; elim H6; intros; elim (relp_rat x0 H1 H3 H5);
    intro; elim x1; unfold frac; intros; elim H9; intros; elim H11; intros;
    elim H13; intros; elim H15; intros; unfold in_ucp_setb; simpl;
    unfold cond_pqb; exists a; exists b; rewrite H7; rewrite H8; rewrite H17.
  cut (b <> 0); auto with zarith; intro.
  split.
  field; split; discrR; auto with zarith reals.
  split.
  field; split; discrR; auto with zarith reals.
  tauto.
Qed.

(* Step 5 *)

(* The full condition over p and q *)
Definition cond_pq (p q : Z) := cond_pqb p q /\ (distinct_parity p q).

(* The (new) set of positive rational coordinates of the unit circle *)
Definition in_ucp_set (x y : R) :=
  exists p : Z, exists q : Z,
  (x = (fst (ucp p q)) /\ y = (snd (ucp p q)) \/
   x = (snd (ucp p q)) /\ y = (fst (ucp p q))) /\ (cond_pq p q).

(* Inclusion of in_ucp_set in in_ucp_setb *)
Lemma nrat_pos_coo1 : forall x y : R, (in_ucp_set x y) -> (in_ucp_setb x y).
Proof.
  unfold in_ucp_set, in_ucp_setb, cond_pq, cond_pqb; simpl; intros; elim_hyps.
  exists x0; exists x1; intuition.
  exists (x1 - x0); exists (x0 + x1); rewrite plus_IZR; rewrite <- Z_R_minus;
    rewrite H; rewrite H5.
  replace
   ((IZR x1 - IZR x0) * (IZR x1 - IZR x0) +
    (IZR x0 + IZR x1) * (IZR x0 + IZR x1))%R with
   (2 * (IZR x0 * IZR x0 + IZR x1 * IZR x1))%R by  ring.
  split;[idtac|split]; try (field; neq_0;apply sqr_sum; auto with zarith).
  do 3 try split; auto with zarith.
  generalize (prop1 _ _ H4 H1); auto with zarith.
Qed.

(* Inclusion of in_ucp_setb in in_ucp_set *)
Lemma nrat_pos_coo2 : forall x y : R, (in_ucp_setb x y) -> (in_ucp_set x y).
Proof.
  unfold in_ucp_setb, in_ucp_set, cond_pq, cond_pqb, distinct_parity; simpl;
    intros; elim_hyps.
  elim (relp_parity x0 x1 H4); intro.
  exists x0; exists x1; intuition.
  unfold both_odd in H5; elim_hyps; generalize (Zodd_def1 _ H5); clear H5;
    intro; generalize (Zodd_def1 _ H6); clear H6; intro; elim_hyps.
  exists (x2 - x3); exists (x2 + x3 + 1); split;
    [ right; rewrite H; rewrite H0; rewrite H5; rewrite H6; atomic_IZR; simpl;
      split; field; split; neq_0; apply sqr_sum; auto with zarith
    | rewrite H5 in H1; rewrite H6 in H2; rewrite H5 in H3; rewrite H6 in H3;
      do 4 try split; auto with zarith ].
  apply rel_prime_sym; apply relp_sum; ring_simplify (x2 + x3 + 1 + (x2 - x3));
    ring_simplify (x2 + x3 + 1 - (x2 - x3)); generalize H5; clear H5;
    ring_simplify (2 * x3 + 1);
    intro; generalize H6; clear H6; ring_simplify (2 * x2 + 1); intro;
    rewrite <- H5; rewrite <- H6; auto with zarith.
  elim (Zeven_odd_dec x2); intro; elim (Zeven_odd_dec x3); intro; Zparity_hyps;
    rewrite H7; rewrite H8;
    [ left; split; [ apply Zeven_def2; exists (x4 - x5)
                   | apply Zodd_def2; exists (x4 + x5) ]
    | right; split; [ apply Zodd_def2; exists (x5 - x4 - 1)
                    | apply Zeven_def2; exists (x5 + x4 + 1) ]
    | right; split; [ apply Zodd_def2; exists (x4 - x5)
                    | apply Zeven_def2; exists (x4 + x5 + 1) ]
    | left; split; [ apply Zeven_def2; exists (x4 - x5)
                   | apply Zodd_def2; exists (x4 + x5 + 1) ] ]; ring.
Qed.

(* step 6 *)

(* The set of Pythagorean triples *)
Definition pytha_set (a b c : Z) :=
  exists p : Z, exists q : Z, exists m : Z,
    (a = m * (q * q - p * p) /\ b = 2 * m * (p * q) \/
     a = 2 * m * (p * q) /\ b = m * (q * q - p * p)) /\
    c = m * (p * p + q * q) /\ m >= 0 /\ (cond_pq p q).

(* Relative primality and fractions *)
Lemma relp_frac : forall a b c d : Z,
  (b <> 0) -> (d <> 0) -> (frac a b) = (frac c d) -> (rel_prime c d) ->
  exists m : Z, m <> 0 /\ b = m * d.
Proof.
  unfold frac; intros.
  cut (c * b = a * d).
  intro; cut (d | c * b);
    [ intro; cut (rel_prime d c);
        try (intro; generalize (Gauss d c b H4 H5); intro; destruct H6 as (q,H6);
        exists q; intuition; rewrite H7 in H6); auto with zarith
    | apply (Zdivide_intro _ _ a H3) ].
  generalize (Rmult_eq_compat_l (IZR b * IZR d) _ _ H1); clear H1; intro;
    replace (IZR b * IZR d * (IZR a / IZR b))%R
            with ((IZR a) * (IZR d))%R in H1;
      [ replace (IZR b * IZR d * (IZR c / IZR d))%R
                with ((IZR c) * (IZR b))%R in H1;
        [ repeat rewrite <- mult_IZR in H1; generalize (eq_IZR _ _ H1); auto
        | field; discrR; assumption ]
      | field; discrR; assumption ].
Qed.

Lemma pytha_thm1 : forall a b c : Z, (is_pytha a b c) -> (pytha_set a b c).
Proof.
  do 3 intro; elim (Z_gt_dec c 0); [ idtac
    | unfold is_pytha, pytha_set, pos_triple, cond_pq, cond_pqb ]; intros.
  generalize (pytha_ucirc1 _ _ _ a0 H); intro;
    cut (is_ucp (frac a c, frac b c));
      [ clear H0; intro; generalize (rat_pos_coo2 _ _ H0); clear H0; intro;
        generalize (nrat_pos_coo2 _ _ H0); clear H0; intro;
        unfold in_ucp_set, cond_pq, cond_pqb in H0;
        unfold pytha_set, cond_pq, cond_pqb; simpl in H0; elim_hyps;
        generalize (relp_pq1 _ _ H1 H4 H5 H2); intro;
        generalize (Zgt_lt _ _ a0); intro; generalize (Zlt_not_eq _ _ H8);
        clear H8; intro; generalize (sym_not_eq H8); clear H8; intro;
        generalize (Zgt_lt _ _ H3); intro; generalize (Zlt_not_eq _ _ H9);
        clear H9; intro; generalize (sym_not_eq H9); clear H9; intro;
        (cut (x * x + x0 * x0 <> 0); [ intro | auto with zarith ];
        (cut ((IZR x0 * IZR x0 - IZR x * IZR x) /
             (IZR x * IZR x + IZR x0 * IZR x0) =
             frac (x0 * x0 - x * x) (x * x + x0 * x0))%R;
          [ intro | head_IZR; auto ];
        (cut (2 * IZR x * IZR x0 / (IZR x * IZR x + IZR x0 * IZR x0) =
             frac (2 * x * x0) (x * x + x0 * x0))%R;
          [ intro | head_IZR; auto ])))
      | idtac ].
  rewrite H11 in H0; clear H11; rewrite H12 in H6; clear H12;
    generalize (relp_frac _ _ _ _ H8 H10 H0 H7); intro; elim_hyps;
    rewrite H12 in H0; rewrite H12 in H6; exists x; exists x0; exists x1;
    generalize (frac_eq _ _ _ _ H11 H10 H0); clear H0; intro;
    generalize (frac_eq _ _ _ _ H11 H10 H6); clear H6; intro;
    rewrite H0; rewrite H6; rewrite H12; intuition; (left; split; ring) ||
    (cut (x1 * (x * x + x0 * x0) > 0);
      [ intro; rewrite Zmult_comm in H13; cut (x * x + x0 * x0 > 0);
        try (intro; generalize (Zmult_gt_0_reg_l _ _ H14 H13));
        auto with zarith
      | rewrite <- H12; assumption ]).
  rewrite H11 in H6; clear H11; rewrite H12 in H0; clear H12;
    generalize (relp_frac _ _ _ _ H8 H10 H6 H7); intro; elim_hyps;
    rewrite H12 in H0; rewrite H12 in H6; exists x; exists x0; exists x1;
    generalize (frac_eq _ _ _ _ H11 H10 H0); clear H0; intro;
    generalize (frac_eq _ _ _ _ H11 H10 H6); clear H6; intro;
    rewrite H0; rewrite H6; rewrite H12; intuition; (right; split; ring) ||
    (cut (x1 * (x * x + x0 * x0) > 0);
      [ intro; rewrite Zmult_comm in H13; cut (x * x + x0 * x0 > 0);
        try (intro; generalize (Zmult_gt_0_reg_l _ _ H14 H13));
        auto with zarith
      | rewrite <- H12; assumption ]).
  unfold is_ucp, is_ratp, is_posp; simpl; intuition; unfold is_rat;
    unfold is_pytha, pos_triple in H; elim_hyps; generalize (Zgt_lt _ _ a0);
    intro; generalize (IZR_lt _ _ H4); intro; simpl in H5;
    fold (IZR c > 0)%R in H5;
    [ exists (a, c); intuition | exists (b, c); intuition
    | unfold frac; generalize (IZR_ge _ _ H); clear H; intro; simpl in H
    | unfold frac; generalize (IZR_ge _ _ H2); clear H2; intro; simpl in H2 ];
    auto with reals.
  elim_hyps; cut (c = 0);
    [ intro; exists 0; exists 1; exists 0; rewrite H3; simpl; intuition;
      (left; rewrite H3 in H0; simpl in H0; progress auto with zarith)
      || (compute; auto with zarith)
    | auto with zarith ].
Qed.

Lemma pytha_thm2 : forall a b c : Z, (pytha_set a b c) -> (is_pytha a b c).
Proof.
  unfold pytha_set, is_pytha, cond_pq, cond_pqb, pos_triple; intros; elim_hyps;
    rewrite H; rewrite H7; rewrite H0; split; ring || (intuition; apply Zle_ge;
    generalize (Zge_le _ _ H2); clear H2; intro; generalize (Zgt_lt _ _ H4);
    clear H4; intro; generalize (Zlt_le_weak _ _ H4); intro;
    repeat apply Zmult_le_0_compat; auto with zarith).
Qed.

(* A specific case *)

Definition pytha_set_even (a b c : Z) :=
  exists p : Z, exists q : Z, exists m : Z,
    a = m * (q * q - p * p) /\ b = 2 * m * (p * q) /\
    c = m * (p * p + q * q) /\ m >= 0 /\ (cond_pq p q).

Lemma pytha_thm3 : forall a b c : Z,
  is_pytha a b c -> Zodd a -> pytha_set_even a b c.
Proof.
  intros; elim (pytha_thm1 _ _ _ H); clear H; intros;
    unfold cond_pq, cond_pqb in H; elim_hyps;
    unfold pytha_set_even, cond_pq, cond_pqb; exists x; exists x0; exists x1;
    try solve [ intuition ].
  elimtype False; rewrite <- Zmult_assoc in H;
  generalize (Zeven_def2 _ (ex_intro (fun x => a = 2 * x) (x1 * (x * x0)) H));
  intro; generalize (Zeven_not_Zodd _ H9); auto.
Qed.