Require Import EqNat.
Require Import List.
Require Import ListSet.
Require Import Coq.Bool.BoolEq.
Require Import Arith.Peano_dec.

Section background.

  (********** Atoms **********)

  Inductive atomic :=
  | A : nat -> atomic.

  Definition beq_atomic (a : atomic) (b : atomic) :=
    match a, b with
      | A n, A m => beq_nat n m
    end.

  (* This is needed to use ListSet *)
  Definition atomic_eq :
    forall a b : atomic, {a = b} + {a <> b}.
    decide equality.
    apply eq_nat_dec.
  Defined.

  (********** Formulae **********)

  Inductive formula :=
  | Atom : atomic -> formula
  | Negation : formula -> formula
  | Disjunction : formula -> formula -> formula.

  Notation "A_[ i ]" :=
    (Atom (A i))
      (at level 200, right associativity).
  Check (Atom (A 1)).

  Notation "'Conjunction' A B " :=
    (Negation (Disjunction (Negation A) (Negation B)))
      (at level 80, left associativity).
  Check (Negation (Disjunction (Negation (A_[1])) (Negation (A_[2])))).

  Notation "'Implies' A B" :=
    (Disjunction (Negation A) B)
      (at level 60, left associativity).
  Check (Disjunction (Negation (A_[1])) (A_[2])).

  Fixpoint get_all_atoms_formula (f : formula) : set atomic :=
    match f with
      | Atom foo => set_add atomic_eq foo (@empty_set atomic)
      | Negation foo => get_all_atoms_formula foo
      | Disjunction foo bar => set_union atomic_eq (get_all_atoms_formula foo) (get_all_atoms_formula bar)
    end.

  Fixpoint in_formula (a : atomic) (f : formula) : Prop :=
    match f with
      | Atom atm => match atomic_eq atm a with
                        | left _ => True
                        | right _ => False
                    end
      | Negation f' => in_formula a f'
      | Disjunction f' f'' => in_formula a f' \/ in_formula a f''
    end.

  Theorem in_formula_in_all_atoms:
    forall f a,
      In a (get_all_atoms_formula f) <-> in_formula a f.
  Proof.
    split; induction f; simpl; intros; try (inversion H);
      try (destruct (atomic_eq a0 a));
      try (trivial).
    + unfold not in n.
      apply n.
      apply H0.
    + apply IHf in H.
      apply H.
    + left.
      apply IHf1.
      (* need to relate set union and append in H *)

  Theorem in_formula_disjunction_commute:
    forall a f g,
      in_formula a (Disjunction f g) <-> in_formula a (Disjunction g f).
  Proof.
    split; unfold in_formula; intros; induction f; destruct g; fold in_formula;
     try (apply or_comm; apply H);
     try (destruct (atomic_eq a0 a)).
  Qed.

  Theorem in_formula_disjunction_add:
    forall a f g,
      in_formula a f -> in_formula a (Disjunction f g).
  Proof.
    intros.
    simpl.
    left.
    apply H.
  Qed.

  (********** Assignments & Suitability  **********)

  Definition assignment : Set := list (atomic * bool).

  Fixpoint generate_all_assignments (a : list atomic) : (list assignment) :=
    let f := fun atm v assign => (atm, v)::assign in
    match a with
         | nil => nil::nil
         | h::t => let f' := f h
                   in (map (f' true) (generate_all_assignments t))
                        ++ (map (f' false) (generate_all_assignments t))
       end.

  Fixpoint in_assignment (a : atomic) (ays : assignment) : Prop :=
    match ays with
      | nil => False
      | (h,_)::t =>  match atomic_eq a h with
                       | left _ => True
                       | right _ => in_assignment a t
                     end
    end.

  Definition suitable (f : formula) (ays : assignment) : Prop :=
    forall a,
      in_formula a f -> in_assignment a ays.

  Theorem generated_assignments_are_suitable:
    forall f ays,
      In ays (generate_all_assignments (get_all_atoms_formula f)) -> suitable f ays.
  Proof.
    unfold suitable; intros; induction ays; destruct f; simpl in H; try (inversion H); simpl.
    + inversion H1.
    + inversion H1; inversion H2.
    + unfold In in H.
      unfold generate_all_assignments in H.
      unfold get_all_atoms_formula in H.

  Theorem suitable_negation_invariant:
    forall f ays,
      suitable f ays <-> suitable (Negation f) ays.
  Proof.
    split; intros; unfold suitable; unfold suitable in H; intros; apply H; simpl in H0.
    + apply H0.
    + simpl; apply H0.
  Qed.

  Theorem suitable_disjunction_invariant:
    forall f g ays,
    suitable (Disjunction f g) ays -> suitable f ays /\ suitable g ays.
  Proof.
    unfold suitable; intros.
    split.
    + intros.
      apply in_formula_disjunction_add with (g:=g) in H0.
      generalize H0.
      apply H.
    + intros.
      apply in_formula_disjunction_add with (g:=f) in H0.
      apply in_formula_disjunction_commute in H0.
      generalize H0.
      apply H.
  Qed.

  Lemma in_empty : forall a, in_assignment a nil -> False.
    intros; compute in H; apply H.
  Qed.

  (* Thanks to @arjunguha *)
  Lemma in_partition : forall (a k : atomic) (tv : bool) (ays : assignment),
                         in_assignment a ((k,tv)::ays) ->
                         a <> k ->
                         in_assignment a ays.
  Proof with auto using list.
    intros; induction ays; simpl in H; destruct (atomic_eq a k); try contradiction.
    simpl. apply H.
  Qed.

  Fixpoint find_assignment a (ays : assignment) { struct ays }: in_assignment a ays -> bool.
  refine (match ays with
            | nil => _
            | (h,tv)::t =>
              match atomic_eq a h with
                | left eq_proof => fun _ => tv
                | right neq_proof => fun pf => find_assignment a t (@in_partition a h tv t pf neq_proof)
              end
          end).
  Proof.
    + intros.
      apply in_empty in H.
      inversion H.
  Qed.

  (********** Truth Tables **********)

  Definition truth_table_entry := (bool * assignment)%type.

  (* Truth tables are tied to evaluation *)
  Fixpoint eval_formula (phi : formula) (ays : assignment) : suitable phi ays -> bool.
  refine (match phi with
            | Atom atm => fun _ => find_assignment atm ays _
            | Negation phi' => fun _ => negb (eval_formula phi' ays _)
            | Disjunction phi' phi'' => fun _ => orb (eval_formula phi' ays _)
                                                      (eval_formula phi'' ays _)
          end).
  Proof.
    intros; unfold suitable in _H; apply _H; simpl.
    destruct (atomic_eq atm atm); trivial.
    + unfold not in n; apply n; trivial.
    + apply suitable_negation_invariant; apply _H.
    + apply suitable_disjunction_invariant in _H; inversion _H.
      apply H.
    + apply suitable_disjunction_invariant in _H; inversion _H.
      apply H0.
  Qed.

  Definition generate_truth_table (f : formula) : list truth_table_entry :=
    let atoms := (get_all_atoms_formula f) in
    let assignments := (generate_all_assignments atoms) in
    map (fun assignment =>
           let pf := suitable f assignment in
           ((eval_formula f assignment pf), assignment))
        assignments.

  Fixpoint atoms_equal (f_atoms g_atoms : set atomic) : bool :=
    match f_atoms, g_atoms with
      | nil, nil  => true
      | nil, _ | _, nil => false
      | h::t, _ => if set_mem atomic_eq h g_atoms
                   then atoms_equal t (set_remove atomic_eq h g_atoms)
                   else false
    end.

 (********** Formula Equality **********)

  Fixpoint beq_formula (f g : formula) : bool :=
    let f_atoms := get_all_atoms_formula f in
    let g_atoms := get_all_atoms_formula g in
    if atoms_equal f_atoms g_atoms
    then
      let f_assignments := generate_all_assignments f_atoms in
      let g_assignments := generate_all_assignments g_atoms in

    else false.

  Definition formula_eq : forall f g : formula,
                            {f = g} + {f <> g}.
    decide equality.
    apply atomic_eq.
  Defined.

  (* Later when we have truth tables, we can use those to define another, better  equality function. *)

  Theorem disjunction_commute : forall f g,
                                  Disjunction f g = Disjunction g f.

  Inductive eq_formula : formula -> formula -> Prop :=
  | atom_eq : forall a1 a2, a1 = a2 -> eq_formula (Atom a1) (Atom a2)
  | neg_eq : forall f g, eq_formula f g -> eq_formula (Negation f) (Negation g)
  | disj_eq : forall f g h, eq_formula f g -> eq_formula (Disjunction f h) (Disjunction g h).

  Proof.
    induction f; simpl.
    destruct g.

  Fixpoint bsub_formula (F : formula) (G : formula) : bool :=
    if beq_formula F G
    then true
    else match G with
           | Atom _ => false
           | Negation foo => bsub_formula F foo
           | Disjunction foo bar => orb (bsub_formula F foo) (bsub_formula F bar)
         end.

  Inductive sub_formula: formula -> formula -> Prop :=
  | base_subf : forall f g, eq_formula f g -> sub_formula f g
  | neg_subf : forall f g, sub_formula f g -> sub_formula f (Negation g)
  | disj_subf : forall f g h, sub_formula f g -> sub_formula f (Disjunction g h).

  Fixpoint count_atoms (a : atomic) (lst : list atomic) :=
    match lst with
      | nil => 0
      | h::tl => if (beq_atomic h a)
                 then 1 + (count_atoms a tl)
                 else count_atoms a tl
    end.

  Definition min (F G : option bool) : option bool :=
    match F, G with
      | _ , None | None, _ => None
      | _, Some false | Some false, _ => Some false
      | _, _ => Some true
    end.

  (* This doesn't solve the problem we had before with defining things in terms of option types.
     It just temporarily commutes the problem. We will need to get dependent types working in order
     to really prove things in a way that looks like "informal" proofs. *)
  (* Inductive truth_value := *)
  (* | Top : True -> truth_value *)
  (* | TV : bool -> truth_value *)
  (* | Bot : False -> truth_value. *)

  (* Inductive in_assignment (a : atomic) : assignment -> Prop := *)
  (*   | asgn_found : forall h tv ays ays', *)
  (*                    h = a -> in_assignment a (ays'++(h,tv)::ays). *)

  Fixpoint in_assignment_bool (a : atomic) (ays : assignment) : bool :=
    match ays with
      | nil => false
      | (h,_)::t => if beq_atomic h a
                    then true
                    else in_assignment_bool a t
    end.

  Fixpoint in_assignment_prop (a : atomic) (ays : assignment) : Prop :=
    match ays with
      | nil => False
      | (h, _)::t => if beq_atomic h a
                     then True
                     else in_assignment_prop a t
    end.

  Theorem in_assignment_bool_eq_in_assignment_prop : forall a ays,
                                                       in_assignment_bool a ays = true <-> in_assignment_prop a ays.
  Proof.
    split.
    (* in_assignment_bool a ays = true -> in_assignment_prop a ays *)
    induction ays; intros.
    simpl in H; inversion H.
    destruct a0.
    simpl.
    remember (beq_atomic a0 a) as hcmp.
    destruct hcmp.
    apply I.
    simpl in H.
    rewrite <- Heqhcmp in H.
    generalize H.
    apply IHays.
    (* in_assignment_prop a ays -> in_assignment_bool a ays = true *)
    induction ays; intros.
    simpl in H; inversion H.
    destruct a0.
    simpl.
    remember (beq_atomic a0 a) as hcmp.
    destruct hcmp.
    reflexivity.
    simpl in H.
    rewrite <- Heqhcmp in H.
    generalize H.
    apply IHays.
  Qed.

  (* Fixpoint in_assignment (a : atomic) (ays : assignment) : Prop := *)
  (*   match ays with *)
  (*     | nil => False *)
  (*     | (h,_)::t => if beq_atomic h a *)
  (*               then True *)
  (*               else in_assignment a t *)
  (*   end. *)

  Definition in_empty : forall a, in_assignment_prop a nil -> False.
    intros.
    inversion H.
  Qed.

  Lemma index_atomic_equal : forall n m,
                               n = m -> A n = A m.
    intros. rewrite H. reflexivity.
  Qed.

  Lemma beq_atomic_true : forall a,
                            beq_atomic a a = true.
    destruct a.
    simpl. apply beq_nat_true_iff. reflexivity.
  Qed.

  Lemma eq_beq_atomic_true : forall a b,
                               a = b -> beq_atomic a b = true.
    intros.
    rewrite H. apply beq_atomic_true.
  Qed.

  (* Lemma atomic_index_equal : forall n m, *)
  (*                              A n = A m -> n = m. *)
  (*   intros; induction n; remember m; destruct m as [|foo]. *)
  (*   rewrite Heqn. *)
  (*   reflexivity. *)
  (*   apply eq_beq_atomic_true in H.  *)
  (*   simpl in H. *)
  (*   rewrite Heqn in H. *)
  (*   inversion H. *)
  (*   rewrite Heqn0. *)
  (*   rewrite Heqn0 in H. *)
  (*   rewrite Heqn0 in IHn. *)

  (* Lemma in_assignment_head_or_tail: forall a t h tv, *)
  (*                                     in_assignment_prop a ((h,tv)::t) -> *)
  (*                                     a = h \/ in_assignment_prop a t. *)
  (*   intros. *)
  (*   unfold in_assignment_prop in H. *)
  (*   remember (beq_atomic h a). *)
  (*   destruct b. *)
  (*   destruct a; destruct h. *)
  (*   simpl in Heqb. *)
  (*   left. *)

  Lemma in_assignment_additive: forall a t h P,
                                  in_assignment_prop a t -> P -> (in_assignment_prop a (h::t) -> P).
    (* need to prive in_assignment_head_or_tail first *)
  Admitted.

  (* I think what we need here is to somehow provide a proof that
     in_assignment_prop a t -> boolin_assignment_prop a t -> bool
     implies
     in_assignment_prop a ((h, tv) :: t) -> bool *)
  Fixpoint find_assignment (a : atomic) (ays : assignment) : in_assignment_prop a ays -> bool :=
    match ays with
      | nil => fun pf => match (in_empty a) pf with end
      | (h,tv)::t => if beq_atomic a h
                     then fun _ => tv
                     else in_assignment_additive a t (h,tv) bool (find_assignment a t)
    end.

  Definition get_first_atom_in_assignment (ays : assignment) :=
    match ays with
      | nil => None
      | (h,_)::t => Some h
    end.

  (* Lemma in_assignment_head_or_rest : forall a b ays, *)
  (*                                      in_assignment a ays -> *)
  (*                                      get_first_atom_in_assignment ays = Some a  *)
  (*                                      \/ in_assignment a (b::ays). *)
  (*   intros. *)

  (* Lemma in_assignment_additive : forall a h ays, *)
  (*                                  in_assignment a ays -> in_assignment a (h::ays). *)
  (*   induction ays. *)
  (*   intros. *)
  (*   apply in_empty in H. *)
  (*   inversion H. *)
  (*   intros. *)

  (* Fixpoint find_assignment (a : atomic) (ays : assignment) : in_assignment a ays -> bool := *)
  (*   match ays with *)
  (*     | nil => fun pf => match (in_empty a) pf with end *)
  (*     | (h, tv)::t => if beq_atomic a h *)
  (*                     then fun _ => tv *)
  (*                     else (fun _ => find_assignment a t) (find_assignment a ays) *)
  (*   end. *)

  Fixpoint find_assignment (a : atomic) (ays : assignment) : option bool :=
    match ays with
      | nil => None
      | (h,tv)::t => if beq_atomic h a
                     then Some tv
                     else find_assignment a t
    end.

  (* Fixpoint find_assignment (a : atomic) (ays : { x : assignment | in_assignment a x }) : bool := *)
  (*   (* (sig (fun x => in_assignment a x)) *) *)
  (*   match ays with *)
  (*     | exist nil pf => match (in_empty a) pf with end *)
  (*     | exist ((h, tv)::t) pf  => if beq_atomic a h *)
  (*                                 then tv *)
  (*                                 else find_assignment a (exist (in_assignment a) t pf) *)
  (*   end. *)

  Fixpoint get_all_atoms_assignment (a : assignment) : set atomic :=
    (* assignment is not a set; new assignments shadow others. we only return teh newest *)
    match a with
      | nil => @empty_set atomic
      | (h, _)::t => match find_assignment h t with
                       | None => set_add atomic_eq h (get_all_atoms_assignment t)
                       | _ =>  get_all_atoms_assignment t
                     end
    end.

  (* this thing is totally wrong; will think about it more later *)
  (* Definition none_found : forall a ays, find_assignment (Atom a) ays = None -> False. *)
  (*   (* we need something like this to be able to run eval_formula using dependent types*) *)
  (* Admitted. *)

  (* in progress *)

  Definition formula_eq : forall F G a,
                            { eval_formula F a = eval_formula G a } + { eval_formula F a <> eval_formula G a}.
    decide equality.
    apply eq_dec with (beq:=fun a b => (orb (andb a b) (andb (negb a) (negb b)))).
    intros. destruct x. simpl. reflexivity.
    simpl. reflexivity.
    destruct x; destruct y; simpl; try (intros; reflexivity); try (intros; inversion H).
  Defined.

  Lemma assignment_atomic_eq : forall a1 a2 ays,
                                 find_assignment a1 ays = find_assignment a2 ays -> a1 = a2.
    intros.
    induction ays; destruct a1; destruct a2.
    simpl in H.

  Definition eval_formula_eq : forall F G a,
                                 eval_formula F a = eval_formula G a -> F = G.
    induction F; destruct G; intros.
    simpl in H.
    unfold find_assignment in H.

  Theorem disjunction_commute : forall F G,
                                  Disjunction F G = Disjunction G F.
  Proof.
    induction F; destruct G.
    apply formula_eq.

  (*Definition suitable (f : formula) (a : assignment) := eval_formula f a <> None. *)

  Lemma get_all_atoms_negation_invariant : forall F,
                                             get_all_atoms_formula F = get_all_atoms_formula (Negation F).
    induction F; simpl; reflexivity.
  Qed.

  Lemma suitable_negation_invariant : forall F a,
                                        suitable F a <-> suitable (Negation F) a.
    intros. split; unfold suitable; intros.
    rewrite <- get_all_atoms_negation_invariant; apply H.
    rewrite <- get_all_atoms_negation_invariant in H; apply H.
  Qed.

  Lemma suitable_disjunction_constituants : forall F G a,
                                              suitable (Disjunction F G) a ->

  Lemma suitable_disjunction_constituants : forall F G a,
                                              ~ suitable F a -> ~ suitable (Disjunction F G) a.
    induction F as [atm |F' IHF'| F1 IHF1 F2 IHF2].
    unfold not; unfold suitable; simpl.
    intros.
    apply H.
    destruct (set_mem atomic_eq atm (get_all_atoms_assignment a)).
    compute. reflexivity.
    compute.

  Lemma empty_assignment_not_suitable : forall F,
                                          eval_formula F nil = None -> ~ suitable F nil.
  Proof.
    induction F as [|F' IHF| F1 IHF1 F2 IHF2]; simpl; intros; try (unfold not); try (unfold suitable); simpl.
    (* atomic *)
    compute; intros; inversion H0.
    (* negation *)
    destruct (eval_formula F' nil) as [somebool|].
    inversion H.
    apply IHF in H. unfold not in H. unfold suitable in H. simpl in H. apply H.
    (* disjunction *)
    destruct (eval_formula F1 nil) as [abool|]; destruct (eval_formula F2 nil) as [bbool|].
    inversion H.
    apply IHF2 in H.

  Definition models (f : formula) (a : assignment) := eval_formula f a = Some true.

  Definition satisfiable (f : formula) := exists a,
                                            suitable f a -> eval_formula f a = Some true.

  Definition unsatisfiable (f : formula) := forall a,
                                              suitable f a -> eval_formula f a = Some false.

  Definition valid (f : formula) := forall a,
                                      suitable f a -> eval_formula f a = Some true.

  Definition form_equiv (F G : formula) a b :=
                          eval_formula F a = b <-> eval_formula G a = b.

  Qed.

Lemma  suitable_invariant_negation : forall F a,
                                       suitable F a <-> suitable (Negation F) a.
Proof.
  intros. split.
  + induction F; unfold suitable; unfold not; intros;  simpl in H; simpl in H0.
    (* atomic *)
    destruct (find_assignment a0 a).
    inversion H0.
    (* negation *)
    apply H; apply H0.
    destruct (eval_formula F a).
    inversion H0.
    (* disjunction *)
    apply H; apply H0.
    destruct (eval_formula F1 a).
    destruct (eval_formula F2 a).
    inversion H0.
    apply H; apply H0.
    apply H; apply H0.
  + induction F; unfold suitable; unfold not; intros.
    (* atomic *)
    simpl in H0.
    destruct (find_assignment a0 a) eqn:stuff.
    inversion H0.
    apply H.
    simpl.
    rewrite stuff.
    reflexivity.
    (* negation *)
    simpl in H0.
    destruct (eval_formula F a) eqn:stuff.
    inversion H0.
    apply H.
    simpl.
    rewrite stuff.
    reflexivity.
    (* disjunction *)
    simpl in H. simpl in H0.
    destruct (eval_formula F1 a) eqn:stuff1.
    destruct (eval_formula F2 a) eqn:stuff2.
    inversion H0.
    apply H; apply H0.
    apply H; apply H0.
Qed.

Lemma atom_eq : forall a b,
                  beq_atomic a b = true -> a = b.
Proof.
  intros.
  induction a. destruct b.
  inversion H.
  apply beq_nat_true_iff in H1.
  rewrite H1. reflexivity.
Qed.

Lemma eq_nat_beq : forall n m,
                     n = m -> beq_nat n m = true.
Proof.
  intros. rewrite H. symmetry. apply beq_nat_refl.
Qed.

Lemma eval_Negation: forall (b:bool) (F:formula) (a:assignment), suitable F a -> ((eval_formula F a = Some b) <-> (eval_formula (Negation F) a = Some (negb b))).
Proof.
  intros.
  split.
  unfold suitable in H. intros.
  destruct F.
  (* atom *)
  simpl. simpl in H0. rewrite H0. destruct b; simpl; reflexivity.
  (* negation *)
  simpl. simpl in H0. simpl in H.
    destruct (eval_formula F a).
     destruct b. simpl.
      destruct b0. simpl. rewrite <- H0; simpl. reflexivity. simpl. reflexivity.
      destruct b0. simpl. reflexivity. simpl. rewrite <- H0. simpl. reflexivity.
     inversion H0.
  (* disjunction *)
  simpl. simpl in H. simpl in H0.
    destruct (eval_formula F1 a).
     destruct (eval_formula F2 a).
      destruct b.
       simpl. destruct b0. simpl. reflexivity. simpl. simpl in H0. destruct b1. simpl. reflexivity. simpl. rewrite H0. reflexivity.
       simpl. destruct b0. simpl. simpl in H0. rewrite H0. reflexivity. simpl. simpl in H0. destruct b1. simpl. rewrite H0. reflexivity. simpl. reflexivity.
      inversion H0.
      inversion H0.
  simpl. unfold suitable in H.
  intros.
  destruct (eval_formula F a).
   destruct b.
    destruct b0. reflexivity. simpl in H0. rewrite H0. reflexivity.
    destruct b0. simpl in H0. rewrite H0. reflexivity. reflexivity.
   inversion H0.
Qed.

Theorem tautology : forall F,
                      valid F <-> unsatisfiable (Negation F).
Proof.
  intros.
  split.
  (* -> *)
  unfold unsatisfiable.
  unfold valid.
  intros.
  destruct F;
    unfold eval_formula;
    unfold eval_formula in H;
    rewrite <- suitable_invariant_negation in H0;
    apply H in H0;
    rewrite H0;
    simpl; reflexivity.
  (* <- *)
  unfold unsatisfiable.
  unfold valid.
  intros.
  rewrite suitable_invariant_negation in H0.
  apply H in H0.
  rewrite eval_Negation.
  rewrite H0.
  simpl.
  reflexivity.
  rewrite suitable_invariant_negation.
  unfold suitable.
  rewrite H0.
  unfold not.
  intros.
  inversion H1.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


(*****************************************************************

 Posets

 In this file, we give some constructions on posets.

 Contents
 1. Accessors
 2. The unit poset
 3. The product of posets
 4. Monotone functions
 5. Examples of monotone functions
 6. The poset of monotone functions
 7. The equalizer of posets
 8. Type indexed products of posets

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

(**
 1. Accessors
 *)
Proposition trans_PartialOrder
            {X : hSet}
            (R : PartialOrder X)
            {x₁ x₂ x₃ : X}
            (p : R x₁ x₂)
            (q : R x₂ x₃)
  : R x₁ x₃.
Proof.
  exact (pr112 R _ _ _ p q).
Qed.

Proposition refl_PartialOrder
            {X : hSet}
            (R : PartialOrder X)
            (x : X)
  : R x x.
Proof.
  exact (pr212 R x).
Qed.

Proposition antisymm_PartialOrder
            {X : hSet}
            (R : PartialOrder X)
            {x y : X}
            (p : R x y)
            (q : R y x)
  : x = y.
Proof.
  exact (pr22 R _ _ p q).
Qed.

(**
 2. The unit poset
 *)
Definition unit_PartialOrder
  : PartialOrder unitset.
Proof.
  use make_PartialOrder.
  - exact (λ _ _, htrue).
  - repeat split.
    intros x y p q.
    apply isapropunit.
Defined.

(**
 3. The product of posets
 *)
Section ProdOrder.
  Context {X₁ X₂ : hSet}
          (R₁ : PartialOrder X₁)
          (R₂ : PartialOrder X₂).

  Let R : hrel (X₁ × X₂)%set := λ x y, R₁ (pr1 x) (pr1 y) ∧ R₂ (pr2 x) (pr2 y).

  Proposition prod_PartialOrderLaws
    : isPartialOrder R.
  Proof.
    simple refine ((_ ,, _) ,, _).
    - refine (λ x y z p q, _ ,, _).
      + exact (trans_PartialOrder R₁ (pr1 p) (pr1 q)).
      + exact (trans_PartialOrder R₂ (pr2 p) (pr2 q)).
    - refine (λ x, _ ,, _).
      + exact (refl_PartialOrder R₁ (pr1 x)).
      + exact (refl_PartialOrder R₂ (pr2 x)).
    - refine (λ x y p q, _).
      use pathsdirprod.
      + exact (antisymm_PartialOrder R₁ (pr1 p) (pr1 q)).
      + exact (antisymm_PartialOrder R₂ (pr2 p) (pr2 q)).
  Qed.

  Definition prod_PartialOrder
    : PartialOrder (X₁ × X₂)%set.
  Proof.
    use make_PartialOrder.
    - exact R.
    - exact prod_PartialOrderLaws.
  Defined.
End ProdOrder.

(**
 4. Monotone functions
 *)
Definition is_monotone
           {X₁ X₂ : hSet}
           (R₁ : PartialOrder X₁)
           (R₂ : PartialOrder X₂)
           (f : X₁ → X₂)
  : UU
  := ∏ (x₁ x₂ : X₁), R₁ x₁ x₂ → R₂ (f x₁) (f x₂).

Proposition isaprop_is_monotone
            {X₁ X₂ : hSet}
            (R₁ : PartialOrder X₁)
            (R₂ : PartialOrder X₂)
            (f : X₁ → X₂)
  : isaprop (is_monotone R₁ R₂ f).
Proof.
  repeat (use impred ; intro).
  apply (pr1 R₂).
Qed.

Definition monotone_function
           {X₁ X₂ : hSet}
           (R₁ : PartialOrder X₁)
           (R₂ : PartialOrder X₂)
  : UU
  := ∑ (f : X₁ → X₂), is_monotone R₁ R₂ f.

Definition  monotone_function_to_function
            {X₁ X₂ : hSet}
            {R₁ : PartialOrder X₁}
            {R₂ : PartialOrder X₂}
            (f : monotone_function R₁ R₂)
  : X₁ → X₂
  := pr1 f.

Coercion monotone_function_to_function : monotone_function >-> Funclass.

Proposition eq_monotone_function
            {X₁ X₂ : hSet}
            {R₁ : PartialOrder X₁}
            {R₂ : PartialOrder X₂}
            (f g : monotone_function R₁ R₂)
            (p : ∏ (x : X₁), f x = g x)
  : f = g.
Proof.
  use subtypePath.
  {
    intro.
    apply isaprop_is_monotone.
  }
  use funextsec.
  exact p.
Qed.

Definition monotone_function_hSet
           {X₁ X₂ : hSet}
           (R₁ : PartialOrder X₁)
           (R₂ : PartialOrder X₂)
  : hSet.
Proof.
  use make_hSet.
  - exact (monotone_function R₁ R₂).
  - use isaset_total2.
    + use funspace_isaset.
      exact (pr2 X₂).
    + intro f.
      apply isasetaprop.
      apply isaprop_is_monotone.
Defined.

(**
 5. Examples of monotone functions
 *)
Proposition idfun_is_monotone
            {X : hSet}
            (R : PartialOrder X)
  : is_monotone R R (idfun X).
Proof.
  exact (λ x₁ x₂ p, p).
Qed.

Proposition comp_is_monotone
            {X₁ X₂ X₃ : hSet}
            {R₁ : PartialOrder X₁}
            {R₂ : PartialOrder X₂}
            {R₃ : PartialOrder X₃}
            {f : X₁ → X₂}
            {g : X₂ → X₃}
            (Hf : is_monotone R₁ R₂ f)
            (Hg : is_monotone R₂ R₃ g)
  : is_monotone R₁ R₃ (λ z, g(f z)).
Proof.
  exact (λ x₁ x₂ p, Hg _ _ (Hf _ _ p)).
Qed.

Proposition dirprod_pr1_is_monotone
            {X₁ X₂ : hSet}
            (R₁ : PartialOrder X₁)
            (R₂ : PartialOrder X₂)
  : is_monotone (prod_PartialOrder R₁ R₂) R₁ pr1.
Proof.
  exact (λ x₁ x₂ p, pr1 p).
Qed.

Proposition dirprod_pr2_is_monotone
            {X₁ X₂ : hSet}
            (R₁ : PartialOrder X₁)
            (R₂ : PartialOrder X₂)
  : is_monotone (prod_PartialOrder R₁ R₂) R₂ pr2.
Proof.
  exact (λ x₁ x₂ p, pr2 p).
Qed.

Proposition prodtofun_is_monotone
            {W X₁ X₂ : hSet}
            {RW : PartialOrder W}
            {R₁ : PartialOrder X₁}
            {R₂ : PartialOrder X₂}
            {f : W → X₁}
            {g : W → X₂}
            (Hf : is_monotone RW R₁ f)
            (Hg : is_monotone RW R₂ g)
  : is_monotone RW (prod_PartialOrder R₁ R₂) (prodtofuntoprod (f,, g)).
Proof.
  exact (λ x y p, Hf _ _ p ,, Hg _ _ p).
Qed.

(**
 6. The poset of monotone functions
 *)
Section FunctionOrder.
  Context {X Y : hSet}
          (RX : PartialOrder X)
          (RY : PartialOrder Y).

  Definition monotone_function_order
    : hrel (monotone_function_hSet RX RY).
  Proof.
    intros f g ; cbn in *.
    use make_hProp.
    - exact (∏ (x : X), RY (f x) (g x)).
    - abstract
        (use impred ; intro ;
         apply (pr1 RY)).
  Defined.

  Proposition monotone_function_isPartialOrder
    : isPartialOrder monotone_function_order.
  Proof.
    simple refine ((_ ,, _) ,, _).
    - exact (λ f g h p q x, trans_PartialOrder RY (p x) (q x)).
    - exact (λ f x, refl_PartialOrder RY (pr1 f x)).
    - intros f g p q.
      use eq_monotone_function.
      intro x.
      exact (antisymm_PartialOrder RY (p x) (q x)).
  Qed.

  Definition monotone_function_PartialOrder
    : PartialOrder (monotone_function_hSet RX RY).
  Proof.
    use make_PartialOrder.
    - exact monotone_function_order.
    - exact monotone_function_isPartialOrder.
  Defined.

  Definition eval_monotone_function
    : monotone_function
        (prod_PartialOrder RX monotone_function_PartialOrder)
        RY.
  Proof.
    simple refine (_ ,, _) ; cbn.
    - exact (λ xf, pr2 xf (pr1 xf)).
    - abstract
        (intros xf yg pq ;
         induction xf as [ x f ] ;
         induction yg as [ y g ] ;
         induction pq as [ p q ] ;
         cbn in * ;
         exact (trans_PartialOrder RY (q x) (pr2 g x y p))).
  Defined.

  Definition lam_monotone_function
             {Z : hSet}
             {RZ : PartialOrder Z}
             (f : monotone_function (prod_PartialOrder RX RZ) RY)
    : monotone_function RZ monotone_function_PartialOrder.
  Proof.
    simple refine (_ ,, _) ; cbn.
    - intro z.
      simple refine (_ ,, _).
      + exact (λ x, f (x ,, z)).
      + abstract
          (intros x₁ x₂ p ;
           apply f ; cbn ;
           refine (p ,, _) ;
           apply refl_PartialOrder).
    - abstract
        (intros z₁ z₂ p x ; cbn ;
         apply f ; cbn ;
         exact (refl_PartialOrder RX x ,, p)).
  Defined.
End FunctionOrder.

(**
 7. The equalizer of posets
 *)
Section Equalizer.
  Context {X : hSet}
          (RX : PartialOrder X)
          (Y : hSet)
          (f g : X → Y).

  Let Eq : hSet
    := (∑ (x : X), f x = g x) ,, isaset_total2 _ (pr2 X) (λ _, isasetaprop (pr2 Y _ _)).

  Definition Equalizer_order
    : PartialOrder Eq.
  Proof.
    simple refine (_ ,, ((_ ,, _) ,, _)).
    - exact (λ x y, RX (pr1 x) (pr1 y)).
    - abstract
        (exact (λ x y z p q, trans_PartialOrder RX p q)).
    - abstract
        (exact (λ x, refl_PartialOrder RX (pr1 x))).
    - abstract
        (intros x y p q ;
         use subtypePath ; [ intro ; apply (pr2 Y) | ] ;
         exact (antisymm_PartialOrder RX p q)).
  Defined.

  Proposition Equalizer_pr1_monotone
    : is_monotone
        Equalizer_order
        RX
        (λ z, pr1 z).
  Proof.
    intros x y p.
    exact p.
  Qed.

  Proposition Equalizer_map_monotone
              {W : hSet}
              (RW : PartialOrder W)
              {h : W → X}
              (Rh : is_monotone RW RX h)
              (p : ∏ (w : W), f(h w) = g(h w))
    : is_monotone
        RW
        Equalizer_order
        (λ w, h w ,, p w).
  Proof.
    intros w₁ w₂ q.
    apply Rh.
    exact q.
  Qed.
End Equalizer.

(**
 8. Type indexed products of posets
 *)
Definition depfunction_poset
           {X : UU}
           (Y : X → hSet)
           (RY : ∏ (x : X), PartialOrder (Y x))
  : PartialOrder (forall_hSet Y).
Proof.
  use make_PartialOrder.
  - exact (λ f g, ∀ (x : X), RY x (f x) (g x)).
  - repeat split.
    + abstract
        (intros f g h p q x ;
         exact (trans_PartialOrder (RY x) (p x) (q x))).
    + abstract
        (intros f x ;
         exact (refl_PartialOrder (RY x) (f x))).
    + abstract
        (intros f g p q ;
         use funextsec ;
         intro x ;
         exact (antisymm_PartialOrder (RY x) (p x) (q x))).
Defined.

Proposition is_monotone_depfunction_poset_pr
            {X : UU}
            (Y : X → hSet)
            (RY : ∏ (x : X), PartialOrder (Y x))
            (x : X)
  : is_monotone (depfunction_poset Y RY) (RY x) (λ f, f x).
Proof.
  intros f g p.
  exact (p x).
Qed.

Proposition is_monotone_depfunction_poset_pair
            {W : hSet}
            {X : UU}
            {Y : X → hSet}
            {RW : PartialOrder W}
            {RY : ∏ (x : X), PartialOrder (Y x)}
            (fs : ∏ (x : X), W → Y x)
            (Hfs : ∏ (x : X), is_monotone RW (RY x) (fs x))
  : is_monotone RW (depfunction_poset Y RY) (λ w x, fs x w).
Proof.
  intros w₁ w₂ p x.
  exact (Hfs x _ _ p).
Qed.


From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

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

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

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

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

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

Theorem theorem0 : forall (x : lst), eq (rev (append (rev x) Nil)) x.
Proof.
   intro.
   rewrite append_nil.
   apply rev_involutive.
Qed.


Require Import QArith.
Require Import QArith.Qcanon.

Open Scope Qc_scope.

From F4 Require Export misc.

Inductive Triple :=
  | triple : forall (x y z : Qc), Triple.

Definition isNotZero t :=
  match t with
  | triple x y z => x <> 0 \/ y <> 0 \/ z <> 0
  end.

Definition isOrthogonal_b (t t' : Triple) :=
  match t, t' with
  | triple x y z, triple x' y' z' => Qc_eq_bool (x*x' + y*y' + z*z') 0
  end.

Lemma isOrthogonal_b_symmetric : forall (t t' : Triple),
  isOrthogonal_b t t' = isOrthogonal_b t' t.
Proof.
  intros [x y z] [x' y' z']. unfold isOrthogonal_b.
  rewrite -> (Qcmult_comm x x').
  rewrite -> (Qcmult_comm y y').
  rewrite -> (Qcmult_comm z z').
  reflexivity.
Defined.

Definition polar (t1 t2 : Triple) : Triple :=
  match t1, t2 with
  | triple x1 y1 z1, triple x2 y2 z2 => triple (det2 y1 z1 y2 z2) (det2 z1 x1 z2 x2) (det2 x1 y1 x2 y2)
  end.

Lemma polar_is_orthogonal : forall t t' : Triple,
  isOrthogonal_b t (polar t t') = true /\ isOrthogonal_b t' (polar t t') = true.
Proof.
  intros [x y z] [x' y' z'].
  unfold polar. unfold isOrthogonal_b. unfold det2.
  (* It's a bit gross / brittle being so explicit with H1, H2 below. Maybe should factor through general det3 results. *)
  assert (H1 : x * (y * z' - z * y') + y * (z * x' - x * z') + z * (x * y' - y * x') = 0). { ring. } rewrite -> H1.
  assert (H2 : x' * (y * z' - z * y') + y' * (z * x' - x * z') + z' * (x * y' - y * x') = 0). { ring. } rewrite -> H2.
  split; reflexivity.
Defined.

Definition eqt_b (t1 t2 : Triple) : bool :=
  match polar t1 t2 with
  | triple x y z => (Qc_eq_bool x 0) && (Qc_eq_bool y 0) && (Qc_eq_bool z 0)
  end.

Definition eqt (t1 t2 : Triple) := eqt_b t1 t2 = true.

Lemma eqt_refl : forall t1 t2 : Triple,
  eqt_b t1 t2 = true <-> eqt t1 t2.
Proof. intros. unfold eqt. apply iff_refl. Defined.

Lemma isNotZero_equiv : forall (x y z : Qc),
  isNotZero (triple x y z) <-> ~(x = 0 /\ y = 0 /\ z = 0).
Proof.
  unfold isNotZero. intros x y z. split.
  - intros [Hx | [Hy | Hz]]; unfold not; intros [Hx' [Hy' Hz']]; contradiction.
  - intros H.
    assert (Hx : x = 0 \/ x <> 0). { apply Qc_eq_zero_dec. }
    assert (Hy : y = 0 \/ y <> 0). { apply Qc_eq_zero_dec. }
    assert (Hz : z = 0 \/ z <> 0). { apply Qc_eq_zero_dec. }
    destruct Hx.
    + destruct Hy.
      * destruct Hz.
        -- subst. exfalso. apply H. split; [reflexivity | split; reflexivity].
        -- right. right. assumption.
      * right. left. assumption.
    + left. assumption.
Defined.

Lemma polar_not_zero : forall t1 t2 : Triple,
  isNotZero t1 -> isNotZero t2 -> ~eqt t1 t2 -> isNotZero (polar t1 t2).
Proof.
  intros [x1 y1 z1] [x2 y2 z2] ev1 ev2 Hne.
  unfold polar. rewrite -> isNotZero_equiv. unfold not. intros [Hx [Hy Hz]].
  unfold not in Hne. apply Hne. unfold eqt. unfold eqt_b. unfold polar.
  rewrite -> Hx. rewrite -> Hy. rewrite -> Hz.
  reflexivity.
Defined.

Lemma eqt_spec: forall (x y z x' y' z' : Qc) (ev : isNotZero (triple x y z)) (ev' : isNotZero (triple x' y' z')),
  eqt (triple x y z) (triple x' y' z') <-> exists t, t<>0 /\ x' = t*x /\ y' = t*y /\ z' = t*z.
Proof.
  intros. subst. unfold eqt. unfold eqt_b. unfold polar. split.
  - intros Heq. repeat (rewrite -> andb_true_iff in Heq). destruct Heq as [[Hyz Hzx] Hxy].
    rewrite -> det2_vanish_bool in Hyz.
    rewrite -> det2_vanish_bool in Hzx.
    rewrite -> det2_vanish_bool in Hxy.
    (* Alternative proof (relies on Qc having a norm via its ordering) uses:
    exists (x*x' + y*y' + z*z' / (x*x + y*y + z*z)). *)
    destruct (Qc_eq_bool z 0) eqn:Hz0.
    + apply Qc_eq_bool_correct in Hz0. subst.
      rewrite -> Qcmult_0_l in Hzx. apply symmetry in Hzx. apply Qcmult_integral in Hzx.
      rewrite -> Qcmult_0_l in Hyz. apply Qcmult_integral in Hyz.
      destruct (Qc_eq_bool y 0) eqn:Hy0.
      * apply Qc_eq_bool_correct in Hy0. subst.
        rewrite -> Qcmult_0_l in Hxy. apply Qcmult_integral in Hxy.
        assert (Hx : x <> 0). {
          unfold isNotZero in ev.
          destruct ev as [H | [H | H]]; [assumption | contradiction | contradiction].
        }
        exists (x'/x). rewrite -> Qcmult_0_r. split.
        -- assert (Hy' : y' = 0). { destruct Hxy; [contradiction | assumption]. }
           assert (Hz' : z' = 0). { destruct Hzx; [contradiction | assumption]. }
           assert (Hx' : x' <> 0). { destruct ev' as [H | [H | H]]; [assumption | contradiction | contradiction]. }
           apply Qc_quot_non_zero; assumption.
        -- split.
           ++ rewrite -> (test_field x' x Hx). reflexivity.
           ++ split.
              ** destruct Hxy; [contradiction | assumption].
              ** destruct Hzx; [contradiction | assumption].
      * exists (y'/y).
        assert (Hyn0: y <>0). { apply Qc_eq_bool_correct'. assumption. } split.
        -- apply (Qc_quot_non_zero y' y Hyn0). destruct (Qc_eq_zero_dec y') as [Hy'|Hy']; try assumption.
           exfalso. subst. rewrite -> Qcmult_0_r in Hxy. apply symmetry in Hxy. apply Qcmult_integral in Hxy.
           assert (Hx' : x' = 0). { destruct Hxy; [contradiction | assumption]. }
           assert (Hz' : z' = 0). { destruct Hyz; [contradiction | assumption]. }
           subst. destruct ev' as [H | [H | H]]; contradiction.
        -- split.
           ++ apply symmetry in Hxy. apply solve_det2; assumption.
           ++ split.
              ** rewrite -> (test_field y' y Hyn0). reflexivity.
              ** rewrite -> Qcmult_0_r. destruct Hyz; [contradiction | assumption].
    + exists (z'/z).
      assert (Hzn0: z<>0). { apply Qc_eq_bool_correct'. assumption. } split.
      * apply (Qc_quot_non_zero z' z Hzn0). destruct (Qc_eq_zero_dec z') as [Hz'|Hz']; try assumption.
        exfalso. subst.
        rewrite -> Qcmult_0_r in Hzx. apply Qcmult_integral in Hzx.
        assert (Hx' : x' = 0). { destruct Hzx; [contradiction | assumption]. }
        rewrite -> Qcmult_0_r in Hyz. apply symmetry in Hyz. apply Qcmult_integral in Hyz.
        assert (Hy' : y' = 0). { destruct Hyz; [contradiction | assumption]. }
        subst. destruct ev' as [H | [H | H]]; contradiction.
      * split.
        -- apply solve_det2; assumption.
        -- split.
           ** apply symmetry in Hyz. apply solve_det2; assumption.
           ** rewrite -> (test_field z' z Hzn0). reflexivity.
  - intros [t [Ht0 [Htx [Hty Htz]]]]. subst. unfold det2.
    repeat (apply andb_true_intro; (try split)); rewrite -> Qc_eq_bool_correct'''; ring.
Defined.

Inductive Point :=
  | point : forall t : Triple, isNotZero t -> Point.

Inductive Line :=
  | line : forall t : Triple, isNotZero t -> Line.

Definition eqp_b (p1 p2 : Point) :=
  match p1, p2 with
  | point t1 _, point t2 _ => eqt_b t1 t2
  end.

Definition eqp (p1 p2 : Point) := eqp_b p1 p2 = true.

Definition eql_b (l1 l2 : Line) :=
  match l1, l2 with
  | line t1 _, line t2 _ => eqt_b t1 t2
  end.

Definition eql (l1 l2 : Line) := eql_b l1 l2 = true.

Lemma eql_refl : forall l1 l2 : Line,
  eql_b l1 l2 = true <-> eql l1 l2.
Proof. intros. unfold eql. apply iff_refl. Defined.

Lemma eqt_b_symmetric : forall t t' : Triple,
  eqt_b t t' = eqt_b t' t.
Proof.
  intros [x y z] [x' y' z']. unfold eqt_b. simpl.
  rewrite -> (det2_vanishing_symmetry y z y' z').
  rewrite -> (det2_vanishing_symmetry z x z' x').
  rewrite -> (det2_vanishing_symmetry x y x' y').
  reflexivity.
Defined.

Corollary eqp_symmetric : forall p p' : Point,
  eqp p p' <-> eqp p' p.
Proof.
  intros [t ev] [t' ev']. unfold eqp. unfold eqp_b. rewrite -> eqt_b_symmetric. reflexivity.
Defined.

Corollary eql_symmetric : forall l l' : Line,
  eql l l' <-> eql l' l.
Proof.
  intros [t ev] [t' ev']. unfold eql. unfold eql_b. rewrite -> eqt_b_symmetric. reflexivity.
Defined.

Lemma eqt_transitive : forall (t t' t'' : Triple) (ev : isNotZero t) (ev' : isNotZero t') (ev'' : isNotZero t''),
  eqt t t' -> eqt t' t'' -> eqt t t''.
Proof.
  intros [x y z] [x' y' z'] [x'' y'' z''] ev ev' ev'' Heq Heq'.
  rewrite -> (eqt_spec _ _ _ _ _ _ ev ev') in Heq.
  rewrite -> (eqt_spec _ _ _ _ _ _ ev' ev'') in Heq'.
  rewrite -> (eqt_spec _ _ _ _ _ _ ev ev'').
  destruct Heq as [t [Ht [Hx [Hy Hz]]]].
  destruct Heq' as [t' [Ht' [Hx' [Hy' Hz']]]].
  exists (t' * t).
  repeat split.
  - unfold not. intros contra. apply Qcmult_integral in contra. destruct contra; contradiction.
  - rewrite <- Qcmult_assoc. rewrite <- Hx. assumption.
  - rewrite <- Qcmult_assoc. rewrite <- Hy. assumption.
  - rewrite <- Qcmult_assoc. rewrite <- Hz. assumption.
Defined.

Corollary eql_transitive : forall l l' l'' : Line,
  eql l l' -> eql l' l'' -> eql l l''.
Proof.
  intros [t ev] [t' ev'] [t'' ev'']. unfold eql. unfold eql_b. repeat (rewrite -> eqt_refl). apply eqt_transitive; assumption.
Defined.

Definition isPointOnLine_b (p : Point) (l : Line) : bool :=
  match p, l with
  | point t _, line t' _ => isOrthogonal_b t t'
  end.

Definition isPointOnLine (p : Point) (l : Line) := isPointOnLine_b p l = true.

Lemma isPointOnLine_refl : forall (p : Point) (l : Line),
  isPointOnLine_b p l = true <-> isPointOnLine p l.
Proof. intros. unfold isPointOnLine. apply iff_refl. Defined.

Lemma incidence_equality_compatible : forall t1 t1' t2 : Triple,
  isNotZero t1 -> isNotZero t1' -> eqt t1 t1' -> isOrthogonal_b t1 t2 = true -> isOrthogonal_b t1' t2 = true.
Proof.
  intros [x y z] [x' y' z'] [u v w] Hn0 Hn0' Heq Hinc.
  rewrite -> (eqt_spec x y z x' y' z' Hn0 Hn0') in Heq.
  destruct Heq as [t [Ht [Hx [Hy Hz]]]]. subst.
  simpl in Hinc. apply Qc_eq_bool_correct in Hinc.
  simpl. assert (H : t * x * u + t * y * v + t * z * w = t * (x * u + y * v + z * w)). { ring. }
  rewrite -> H. rewrite -> Hinc. rewrite Qcmult_0_r. reflexivity.
Defined.

Corollary equal_points_on_line : forall (p p' : Point) (l : Line),
  eqp p p' -> isPointOnLine p l -> isPointOnLine p' l.
Proof.
  intros [t1 evT1] [t1' evT1'] [t2 evT2] Heq Hinc.
  unfold eqp in Heq. unfold isPointOnLine in Hinc. unfold isPointOnLine_b in Hinc.
  unfold isPointOnLine. unfold isPointOnLine_b.
  apply (incidence_equality_compatible t1 t1' t2 evT1 evT1' Heq Hinc).
Defined.

Corollary equal_lines_contain_same_points : forall (l l' : Line) (p : Point),
  eql l l' -> isPointOnLine p l -> isPointOnLine p l'.
Proof.
  intros [t1 evT1] [t1' evT1'] [t2 evT2] Heq Hinc.
  unfold eql in Heq. unfold isPointOnLine in Hinc. unfold isPointOnLine_b in Hinc.
  unfold isPointOnLine. unfold isPointOnLine_b.
  rewrite isOrthogonal_b_symmetric in Hinc.  rewrite isOrthogonal_b_symmetric.
  apply (incidence_equality_compatible t1 t1' t2 evT1 evT1' Heq Hinc).
Defined.

Corollary line_pair_distinct_point : forall (p : Point) (l l' : Line),
  isPointOnLine p l -> ~isPointOnLine p l' -> ~eql l l'.
Proof.
  unfold not. intros p l l' H H' Heq. apply H'. apply (equal_lines_contain_same_points l l' p Heq H).
Defined.

Inductive LinePair :=
  | linePair : forall (l l' : Line), ~eql l l' -> LinePair.

Inductive PointPair :=
  | pointPair : forall (p p' : Point), ~eqp p p' -> PointPair.

Definition linePairIntersection (lp : LinePair) : Point :=
  match lp with
  | linePair (line t evT) (line t' evT') evLp => point (polar t t') (polar_not_zero t t' evT evT' evLp)
  end.

Definition pointPairLine (pp : PointPair) : Line :=
  match pp with
  | pointPair (point t evT) (point t' evT') evPp => line (polar t t') (polar_not_zero t t' evT evT' evPp)
  end.

Lemma intersection_on_lines : forall (l l' : Line) (ev : ~eql l l'),
  isPointOnLine (linePairIntersection (linePair l l' ev)) l /\
  isPointOnLine (linePairIntersection (linePair l l' ev)) l'.
Proof.
  intros [t evT] [t' evT'] Hne.
  unfold linePairIntersection. unfold isPointOnLine. unfold isPointOnLine_b.
  rewrite (isOrthogonal_b_symmetric _ t). rewrite (isOrthogonal_b_symmetric _ t').
  apply polar_is_orthogonal.
Defined.

Lemma end_points_on_line : forall (p p' : Point) (ev : ~eqp p p'),
  isPointOnLine p (pointPairLine (pointPair p p' ev)) /\
  isPointOnLine p' (pointPairLine (pointPair p p' ev)).
Proof.
  intros [t evT] [t' evT'] Hne.
  unfold pointPairLine. unfold isPointOnLine. unfold isPointOnLine_b. apply polar_is_orthogonal.
Defined.

Lemma two_points_characterise_line' : forall (l : Line) (p q : Point) (evDistinct : ~eqp p q),
  isPointOnLine p l -> isPointOnLine q l -> eql l (pointPairLine (pointPair p q evDistinct)).
Proof.
  intros [[x y z] evl] [[u v w] ev] [[u' v' w'] ev'] evDistinct evInc evInc'.
  unfold isPointOnLine in evInc. simpl in evInc. apply Qc_eq_bool_correct in evInc.
  unfold isPointOnLine in evInc'. simpl in evInc'. apply Qc_eq_bool_correct in evInc'.
  unfold pointPairLine. unfold polar. unfold eql. unfold eql_b. unfold eqt_b. unfold polar. unfold det2.
  assert (Hx : y * (u*v' - v*u') - z * (w*u' - u*w') = u * (u'*x + v'*y + w'*z) - u' * (u*x + v*y + w*z)). { ring. }
  assert (Hy : z * (v*w' - w*v') - x * (u*v' - v*u') = v * (u'*x + v'*y + w'*z) - v' * (u*x + v*y + w*z)). { ring. }
  assert (Hz : x * (w*u' - u*w') - y * (v*w' - w*v') = w * (u'*x + v'*y + w'*z) - w' * (u*x + v*y + w*z)). { ring. }
  rewrite -> Hx. rewrite -> Hy. rewrite -> Hz. rewrite -> evInc. rewrite -> evInc'.
  repeat (rewrite -> Qcmult_0_r). repeat (rewrite -> Qcmult_0_l). reflexivity.
Defined.

Corollary two_points_characterise_line : forall (l l' : Line) (p q : Point) (evDistinct : ~eqp p q),
  isPointOnLine p l -> isPointOnLine q l -> isPointOnLine p l' -> isPointOnLine q l' -> eql l l'.
Proof.
  intros l l' p q Hpq Hp Hq Hp' Hq'.
  assert (Hl := two_points_characterise_line' l p q Hpq Hp Hq).
  assert (Hl' := two_points_characterise_line' l' p q Hpq Hp' Hq'). rewrite -> eql_symmetric in Hl'.
  apply (eql_transitive l _ l' Hl Hl').
Defined.

Definition isAffine_b p :=
  match p with
  | point (triple x y z) _ => negb (Qc_eq_bool z 0)
  end.

Definition isAffine p := isAffine_b p = true.

Inductive LineSeg :=
  | lineSeg : forall (p q : Point), ~eqp p q -> isAffine p -> isAffine q -> LineSeg.

Definition lineFromLineSeg (ls : LineSeg) :=
  match ls with
  | lineSeg p p' evDistinct evAff evAff' => pointPairLine (pointPair p p' evDistinct)
  end.

Definition dotProd2 (x1 y1 x2 y2 : Qc) := x1*x2 + y1*y2.

Definition isPointOnLineSeg_b (p : Point) (l : LineSeg) : bool :=
  match (isAffine_b p && isPointOnLine_b p (lineFromLineSeg l)) with
  | false => false
  | true => match p, l with
    | point (triple x y z) _, lineSeg (point (triple x1 y1 z1) _) (point (triple x2 y2 z2) _) _ _ _ =>
      let u := x/z - x1/z1 in
      let v := y/z - y1/z1 in
      let u' := x2/z2 - x1/z1 in
      let v' := y2/z2 - y1/z1 in
      let t := dotProd2 u v u' v' / (dotProd2 u' v' u' v') in
        (Qc_lt_bool 0 t) && (Qc_lt_bool t 1)
    end
  end.

Definition isPointOnLineSeg (p : Point) (l : LineSeg) := isPointOnLineSeg_b p l = true.

Lemma isPointOnLineSeg_refl : forall (p : Point) (l : LineSeg),
  isPointOnLineSeg_b p l = true <-> isPointOnLineSeg p l.
Proof. intros. unfold isPointOnLineSeg. apply iff_refl. Defined.

Definition det3pt p q r :=
  match p, q, r with
  | point (triple a b c) _,
    point (triple d e f) _,
    point (triple g h i) _ =>
      det3 a b c
           d e f
           g h i
  end.

Lemma det3pt_permute : forall p q r : Point,
  det3pt p q r = det3pt r p q.
Proof.
  intros [[x1 y1 z1] ev1] [[x2 y2 z2] ev2] [[x3 y3 z3] ev3].
  simpl. unfold det3. unfold det2. ring.
Defined.

Lemma det3pt_permute_sign : forall p q r : Point,
  det3pt p q r = -det3pt p r q.
Proof.
  intros [[x1 y1 z1] ev1] [[x2 y2 z2] ev2] [[x3 y3 z3] ev3].
  unfold det3pt. unfold det3. unfold det2. ring.
Defined.

Lemma point_on_line_seg_det : forall (p1 p2 p3 : Point) (evL : ~eqp p2 p3),
  det3pt p1 p2 p3 = 0 <-> isPointOnLine p1 (pointPairLine (pointPair p2 p3 evL)).
Proof.
  intros [[x1 y1 z1] ev1] [[x2 y2 z2] ev2] [[x3 y3 z3] ev3] evL.
  unfold isPointOnLine. unfold isPointOnLine_b. unfold pointPairLine. unfold isOrthogonal_b. unfold polar. unfold det3pt.
  rewrite -> Qc_eq_bool_correct'''. unfold det3. apply iff_refl.
Defined.

Definition lineSegMeetsLine_b ls l (evLp : ~eql (lineFromLineSeg ls) l) :=
  let lp := linePair (lineFromLineSeg ls) l evLp in
    isPointOnLineSeg_b (linePairIntersection lp) ls.

Definition lineSegMeetsLineSeg_b (l m : LineSeg) : bool.
refine (
  let sameLine := eql_b (lineFromLineSeg l) (lineFromLineSeg m) in
    match sameLine as sameLine' return (sameLine = sameLine' -> _) with
    | true => fun _ => false
    | false => fun evDistinct => (lineSegMeetsLine_b l (lineFromLineSeg m) _) && (lineSegMeetsLine_b m (lineFromLineSeg l) _)
    end (eq_refl sameLine)
);
  [| rewrite eql_symmetric];
  unfold not; intros contra; rewrite <- eql_refl in contra;
  unfold sameLine in evDistinct; rewrite -> evDistinct in contra;
  inversion contra.
Defined.

Definition lineSegMeetsLineSegClosed_b (l m : LineSeg) :=
  match l, m with
  | lineSeg p q _ _ _, lineSeg p' q' _ _ _ =>
    lineSegMeetsLineSeg_b l m ||
    isPointOnLineSeg_b p m || isPointOnLineSeg_b q m ||
    isPointOnLineSeg_b p' l || isPointOnLineSeg_b q' l ||
    eqp_b p p' || eqp_b p q' || eqp_b q p' || eqp_b q q'
  end.

Definition flipLineSeg (l : LineSeg) : LineSeg.
refine (
  match l with
  | lineSeg p p' evNe evAff evAff' => lineSeg p' p _ evAff' evAff
  end
).
  rewrite eqp_symmetric. assumption.
Defined.

Lemma flipped_line_seg_same_line : forall l : LineSeg,
  eql (lineFromLineSeg (flipLineSeg l)) (lineFromLineSeg l).
Proof.
  intros [[[x y z] evT] [[x' y' z'] evT'] evNe evAff evAff'].
  unfold flipLineSeg. unfold lineFromLineSeg. unfold pointPairLine.
  unfold eql. unfold eql_b. unfold eqt_b. unfold polar.
  repeat (rewrite andb_true_iff; split); apply Qc_eq_bool_correct'''; unfold det2; ring.
Defined.


Module StandardLib.

Definition comp {A B C} (f: B -> C) (g: A -> B) := fun x => f (g x).
Definition id {A:Type} : A -> A := fun a => a.

Definition curry {A B C} : (A -> B -> C) -> (A * B) -> C :=
  fun f '(a, b) => f a b.
Definition uncurry {A B C} : (A * B -> C) -> A -> B -> C :=
  fun f a b => f (a, b).

Definition fun_eq {A B} (f g: A -> B) := forall a, f a = g a.

Notation "f \o g" := (comp f g)
  (at level 50, left associativity).

Notation "f =1 g" := (fun_eq f g) (at level 50).

End StandardLib.

Module StandardCat.
Import StandardLib.

Definition iso {A B} (f: A -> B) :=
  exists g, f \o g =1 id /\ exists h, h \o f =1 id.

Definition eiso A B := exists f, @iso A B f.

End StandardCat.


Require Import XR_R.
Require Import XR_Rle.
Require Import XR_Rle_dec.
Require Import XR_Rmin.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma Rmin_case_strong : forall r1 r2 (P:R -> Type),
  (r1 <= r2 -> P r1) -> (r2 <= r1 -> P r2) -> P (Rmin r1 r2).
Proof.
  intros x y p px py.
  unfold Rmin.
  destruct (Rle_dec x y) as [ hminl | hminr ].
  {
    apply px.
    exact hminl.
  }
  {
    apply py.
    left.
    apply Rnot_le_lt.
    exact hminr.
  }
Qed.


(** Coq coding by choukh, July 2022 **)

Require Export Meta.
Require Import Setoid.

Class 等价关系 (T : Type) := {
  R : T → T → Prop;
  R等价 : Equivalence R
}.

Arguments R _ {_} _ _.
Global Existing Instance R等价.

Notation "a ≡{ T } b" := (@R T _ a b) (format "a  ≡{ T }  b", at level 70).

Global Instance 自然数同一性 : 等价关系 ℕ := {| R := eq |}.

Global Instance 布尔值同一性 : 等价关系 bool := {| R := eq |}.

Global Instance 命题外延 : 等价关系 Prop := {| R := iff |}.

Global Instance 函数外延 {A B} `{等价关系 B} : 等价关系 (A → B).
Proof.
  exists (λ f g : A → B, ∀ x, f x ≡{B} g x). split.
  - intros f x. reflexivity.
  - intros f g fg x. now symmetry.
  - intros f g h fg gh x. now transitivity (g x).
Defined.

Global Instance 共值域 {A B} : 等价关系 (A → B?).
Proof.
  exists (λ f g, ∀ x, (∃ n, f n = Some x) ↔ (∃ n, g n = Some x)). split.
  - intros f x. reflexivity.
  - intros f g fg x. now symmetry.
  - intros f g h fg gh x. now transitivity (∃ n : A, g n = Some x).
Defined.

Notation "f ≡{ran} g" := (@R _ 共值域 f g) (format "f  ≡{ran}  g", at level 80).


(** Context: verification of cryptographic protocols using formal methods
    Goals: 1. define -in a nice way- the term algebra used to model messages
             exchanged by protocols.
             -> Basically a \Sigma-algebra equipped with an equational theory
                NOT necessarily convergent (e.g., xor is assoc+comm).
           2. define the notion of *static equivalence* (crucial in security)
              -> Basically a symetric predicate over sequences S1 S2 of terms
                 saying that S1 S2 have same length and we cannot build two
                 terms M M' whose atoms are positions in S1 such that
                 M S1 = M S1 but M S2 \neq M' S2 (modulo the equational theory).
           3. prove some static equivalences and non-equivalences
           4. see what can be automatized using tactics. *)

(**  ======= Σ-ALGEBRA ========
Definition of a specific \Sigma-algebra (Σ = {hash/1;xor/2}):
   Var : countably many variables
   Name : countably many names (intuitively terms that look random and not
          known from the attacker)
   Const : countably many constants (on paper function symbols of arity 0)
           (intuitively terms that are publicly known)
   N : neutral of xor (same as above)
   Xor : intuitively eXclusive OR on bistrings
   Hash : basically a one-way function *)
Require Import Setoid Morphisms.

(* [NOTE] ici il faut faire un choix entre un ensemble de constante fini ou
   infini. Dans le cas fini, le plus propre serait de définir un
    Inductive cst := blank | ok.
   et l'utiliser dans term. Je garde les nat car *)
Definition cst := nat.          (* moralement csts. 1,2,3 ... *)
Definition var := nat.
Definition name := nat.
Inductive term :=
  | Var : var -> term
  | Name : name -> term
  | Const : cst -> term
  | Hash : term -> term
  | Xor : term -> term -> term
  | N : term.
(* Notations *)
Infix "xor" := Xor (at level 70).
Notation "'h' X" := (Hash X) (at level 60).
(* Some keys *)
Notation "'k'" := (Name 0).
Notation "'k1'" := (Name 1).
Notation "'k2'" := (Name 2).
(* Some nonces (Number ONCE ~ random values) *)
Notation "'n'" := (Name 3).
Notation "'n1'" := (Name 4).
Notation "'n2'" := (Name 5).
(* Some constants  *)
Notation "'ok'" := (Const 1).
Notation "'no'" := (Const 2).
Notation "'error'" := (Const 3).
Notation "'blank'" := (Const 0).  (* garbage (for later) *)

(**
Equations from which the equational theory will be defined.
(On paper, equations is a finite relation over terms without names.) *)
Inductive EqualE : term -> term -> Prop :=
| xorAssoc : forall t1 t2 t3: term, EqualE ((t1 xor t2) xor t3) (t1 xor (t2 xor t3))
| xorComm : forall t1 t2: term, EqualE (t1 xor t2) (t2 xor t1)
| xorI : forall t, EqualE (t xor N) t
| xorN : forall t, EqualE (t xor t) N.

(**
The main equivalence relation =E we build on EqualE is (on paper):
the least equivalence relation containing EqualE that is stable by application
of a constructor (ui =E vi implies f (ui ) =E f (vi) for any f ∈ Σ) and stable by substitution
(i.e., u =E v implies uσ =E vσ for any substitution σ = {t\x} for some variable x and term t). *)
Inductive EqE : term -> term -> Prop :=
| Base : forall t1 t2, EqualE t1 t2 -> EqE t1 t2
| EHash : Proper (EqE ==> EqE) Hash
| EXor : Proper (EqE ==> EqE ==> EqE) Xor
| Trans : forall t1 t2 t3, EqE t1 t2 -> EqE t2 t3 -> EqE t1 t3
| Refl : forall t, EqE t t
| Sym : forall t1 t2, EqE t1 t2 -> EqE t2 t1.
(* <HINTS> We help Coq to understand how to deal with rewrite on EqE. *)
Existing Instance EHash.
Existing Instance EXor.
Instance EqE_todo : subrelation EqualE EqE.
Proof. constructor;auto. Qed.
Instance EqE_equivalence: Equivalence EqE.
Proof. constructor.
intro;apply Refl.
intro; apply Sym.
intro;apply Trans.
Qed.

Infix "==E" := EqualE (at level 80).
Infix "=E" := EqE (at level 81).

(* Small example *)
Lemma ex1 : ((Var 3 xor h(Var 6)) xor h(Var 6)) =E (Var 3).
  transitivity  (Var 3 xor (h(Var 6) xor h(Var 6))).
  rewrite xorAssoc;reflexivity.
  rewrite (xorN).
  rewrite xorI. reflexivity.
Qed.

(** ====== STATIC EQUIVALENCE =======
We define what a frame is. On paper a frame is a substitution from (preserved and fresh)
'handles' (like variables) to terms. Handles are kinds of pointers to positions in the frame.
Intuitively, handles are used for referring to previously output terms.
On paper, we would define recipes on frames that are terms whose atoms are handles
(positions in the frame) plus subsitution [recipe frame] gives a term.
Here, we use (nat -> term) for frames (positions to terms) and define a predicate
[subR frame recipe term] saying that [recipe frame] gives [term]. Our recipes are
terms but subR interpret [Var n] as positions [n]. *)
Definition frame := nat -> term.
Inductive subR : frame -> term -> term -> Prop :=
| Atom : forall f : frame, forall atom:nat,
           subR f (Var atom) (f atom)
| SConst : forall f i, subR f (Const i) (Const i)
| SHash : forall f t1 t2, subR f t1 t2 -> subR f (h t1) (h t2)
| SXor : forall f t11 t12 t21 t22,
           subR f t11 t12 ->
           subR f t21 t22 ->
           subR f (t11 xor t21) (t12 xor t22).

(**
We now turns to the main property we would like to prove for some frames: static equivalence.
 *)
Definition EqS (f1 f2 : frame) : Prop :=
          (forall m1 m2, forall f1t1 f1t2 f2t1 f2t2,
             subR f1 m1 f1t1 ->        (* [m1 f1 =E f1t1] *)
             subR f1 m2 f1t2 ->        (* [m2 f1 =E f1t2] *)
             subR f2 m1 f2t1 ->        (* [m1 f2 =E f2t1] *)
             subR f2 m2 f2t2 ->        (* [m2 f2 =E f2t2] *)
             ((f1t1 =E f1t2) <-> (f2t1 =E f2t2))). (* [m1 f1 =E m2 f1 <-> m1 f2 =E m2 f2] *)

Infix "~~" := EqS (at level 80).

Lemma EqS_sym : forall f1 f2, EqS f1 f2 -> EqS f2 f1.
Proof.
  admit.                        (* TODO *)
Admitted.

(* Let's see examples of static equ. *)
Load data.
(* frame1 = {k1}
   frame1 = {k2}  *)
Definition NeS (f1 f2 : frame) :=
  (forall m, forall f1t1 f2t1,
     subR f1 m f1t1 ->        (* [m1 f1 =E f1t1] *)
     subR f2 m f2t1 ->        (* [m1 f2 =E f2t1] *)
     ((f1t1 =E N) <-> (f2t1 =E N))). (* [m1 f1 =E m2 f1 <-> m1 f2 =E m2 f2] *)
Lemma ex2_b : NeS frame1 frame2.
Proof.
induction m.
- (* VAR *)
  intros; split. intros H1.
  assert (H3: v=0 \/ not (v=0)) by admit;destruct H3 as [Hb | Hnb].
  rewrite Hb in *.
  inversion H;simpl in *.
  inversion H0;simpl in *.
  rewrite <-H3 in *.
  rewrite <-H6 in *.
  clear H2 H3 H4 f0 atom0 H5 H6 H7 atom f Hb.
  Print EqE.
  inversion H1.
  inversion H2.
  (* je pars dans une boucle à cause de la transitivité: induction sur les pas inductifs ....
      MASSE DE CHOSES relous *)
  inversion H1.
  unfold EqE in *.
- (* Name *)    (* facile *)
- (* Hash *)
- (* Cst *)

Lemma ex2: frame1 ~~ frame2.    (* very easy one *)
Proof.
  do 6 intro; intros S11 S12 S21 S22.
  split; intro Eq.
  induction m1.
  - (* VAR *)
    assert (H: v=0 \/ not (v=0)) by admit;destruct H as [Hb | Hnb].
    + (* VAR 0 =ki *)
      rewrite Hb in *.
      inversion S11.
      simpl in *.
      rewrite <-H0 in Eq.
      clear f atom H H1 Hb H0.
      (* ICI on veut f1t2 sous une forme 'normale' = k1.
         Induction sur m2 sous une forme 'normale': Const, hash -> absurde.
         xor: montrer le lemme décrit plus bas -> absurde
         Var n ->  n=1. Et tout va bien de l'autre côté. *)
      admit.
    + assert (f1t1 = blank) by admit. (* devrait être OK *)
      rewrite H in *.
      admit. (* ici on fait comme dans le cas Var 0: 1. xor hash impossible
                2. cas Const -> OK mais alors du côté f2 aussi
                3. cas Var v: v=0 contredit Eq, v<>0 -> OK côté f2 aussi  *)
  - (* NAME *)
    inversion S11.              (* impossible (vient du fait que l'on a surchargé recettes et messages *)
  - (* CONST *)
    assert (c<>0) by admit.      (* le cas blank par un lemme? *)
    assert (Const c <> blank) by admit.
    assert (H2: f1t1 = Const c) by admit; rewrite H2 in *; clear H2.
    assert (H2: f2t1 = Const c) by admit; rewrite H2 in *; clear H2.
    (* Ici encore j'ai envie de dire que Eq => f1t2 pris dans sa forme 'normale' est = Const c.
       S12 => *)
    admit.

Lemma ex2: f1 ~~ f2.
Proof.
  apply eqS.
  do 6 intro. intros S11 S12 S21 S22.
  split; intro Eq.                        (* TWO SYMETRIC CASES *)
  -
(* Idea if the proof:
induction sur m1 (avec quantification sur tout le reste!):
Je vais supposer que je peux toujours prendre des recettes sous une forme "normale" (attention ma théorie eq.
ne sera pas toujours orientable et convergente!).
Ici une espèce de \xor_i (t_i) tel que t_i\neq t_j si i\neq j et t_i\neq xor(_,_).
On a aussi la prop cruciale: t ss cette forme avec i > 1 implique que
t \neq_E t' pour tout t' atomique (Var ou Name).
+ [m1 = Const i] => f1t1 = Const i
  ===> m2 = Const i (deux cas (m1 = blank ou pas))
  ======> f2t1 = f2t2 = Const i
+ [m1 = Name] => impossible de dériver S11 -> absurde
+ [m1 = Var atom] alors 4 cas selon que f1t1 = k1, h(k1 xor n1), ok ou blank
  détaillons le cas f1t1 = h(k1 xor n1). On a donc f1t2 =E = h(k1 xor n1)
  ==> On montre que [m2 = Var atom] en distinguant les cas sur m2 plus deux lemmes:
      L1: h(X) =E h(Y) -> x =E Y
      L2: not (exists m t, subR frame1 m t /\ t =E k1 xor n1)
+ [m1 = h(m1')] alors on distingue deux cas sur f1t1 qui est soit égal à h(k1 xor n2) soit pas.
  Si c'est le cas alors [m1' frame =E k1 xor n2] on montre que c'est absurde.
  Si ce n'est pas le cas alors m2 ne peut pas = Var i donc on peut montrer que m2 = h(m2') et
  on récure sur m1'.
+ [m1 = m11 xor m12]  => dans ce cas f1t1 est aussi un "vrai xor". m2 ne peut pas être un var car
  pas de xor dans frame1. De cette façon on a que m2 a la même structure XOR que m1 on se ramène donc
  aux atomes et hash déjà traités.
 *)

Admitted.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require  Import area_method.

(** Transitivity of the parallel predicate expressed constructively *)

Theorem parallel_transitivity :
 forall A B C D E F : Point,
 A <> B ->
 on_parallel C D A B ->
 on_parallel E F C D ->
 parallel A B E F.
Proof.
area_method.
Qed.

(** Pseudo-transitivity of the parallel predicate expressed constructively *)

Theorem parallel_pseudo_transitivity :
 forall A B C D E F : Point,
 A <> B ->
 on_parallel C D A B ->
 on_parallel E F A B ->
 parallel C D E F.
Proof.
area_method.
Qed.

(** If AB and CD are two parallel and congruent segments then
AC is parallel to BD *)

Theorem parallellogram_second_parallel :
 forall A B C D : Point,
 on_parallel_d D C A B 1 ->
 parallel A C B D.
Proof.
area_method.
Qed.

(** The construction of a parallelogram using the fact that the diagonals intersect
in the midpoint *)

Theorem parallellogram_construction :
 forall A B C D I : Point,
 is_midpoint I A C ->
 on_line_d D I B (-(1)) ->
 parallel C D A B.
Proof.
area_method.
Qed.

(** An example where a complex sequence of constructions is compiled
into higher level constructions to ease the elimination process *)

Lemma example_construction_simplification:
forall A B C D E F G Line_3_b Line_6_b,
 on_line C A B ->
 on_parallel Line_3_b C A D ->
 inter_ll E C Line_3_b B D ->
 on_parallel Line_6_b C F A ->
 inter_ll G C Line_6_b F B  ->
 parallel E G D F.
Proof.
area_method.
Qed.

Theorem parallellogram_construction_2 :
 forall A B C D I : Point,
 is_midpoint I A C ->
 on_line_d D I B (-(1)) ->
 parallel C D A B /\ parallel A D B C.
Proof.
area_method.
Qed.

(** We show that the diagonals of a parallelogram intersect in the midpoint *)

Theorem parallelogram_midpoint :
  forall A B C D I : Point,
  on_parallel_d D C A B (0-1) ->
  inter_ll  I A C B D ->
  A<>C ->
  A<>I ->
  parallel A I A C ->
  A ** I / A**C = 1 / 2.
Proof.
am_before_field.
intuition.
Ffield.
Qed.

Theorem Prop51Hartsshornebis :
  forall A B C D E : Point,
  ~ Col D A C ->
  ~ Col A B C ->
  is_midpoint D A B ->
  is_midpoint E A C ->
  parallel D E B C ->
  B <> C ->
  D ** E / B ** C = 1 / 2.
Proof.
area_method.
Qed.


Require Import Coq.Program.Basics.

Require Import Coq.Setoids.Setoid.

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.

Require Import Graph.

Definition incl {A} (R: relation (Graph A)) (x y : Graph A) : Prop := R (Overlay x y) y.

Lemma incl_antisymmetry A R `(EqG A R) x y: incl R x y -> incl R y x -> R x y.
Proof.
  intros r r'.
  unfold incl in r; unfold incl in r'.
  rewrite (symmetry r).
  rewrite (symmetry r') at 1.
  rewrite EqG_PlusCommut.
  reflexivity.
Qed.

Lemma incl_transitivity A R `(EqG A R): forall x y z, incl R x y -> incl R y z -> incl R x z.
Proof.
  intros x y z r r'.
  unfold incl; unfold incl in r; unfold incl in r'.
  rewrite (symmetry r').
  rewrite (symmetry r).
  rewrite EqG_PlusAssoc.
  rewrite ((EqG_PlusAssoc x x y)).
  rewrite (plus_Idempotence x).
  reflexivity.
Qed.

Lemma incl_ov_in_connect A R `(EqG A R): forall x y, incl R (Overlay x y) (Connect x y).
Proof.
  intros x y.
  unfold incl.
  rewrite EqG_PlusCommut.
  rewrite EqG_PlusAssoc.
  rewrite (symmetry (containmentLeft x y)).
  rewrite (symmetry (containmentRight x y)).
  reflexivity.
Qed.

Lemma incl_overlay_right_cong A R `(EqG A R): forall x y z, incl R x y -> incl R (Overlay x z) (Overlay y z).
Proof.
  intros x y z r.
  unfold incl.
  rewrite EqG_PlusAssoc.
  rewrite EqG_PlusCommut.
  rewrite EqG_PlusAssoc.
  rewrite EqG_PlusCommut.
  rewrite (EqG_PlusCommut z (Overlay x z)).
  rewrite (symmetry (EqG_PlusAssoc x z z)).
  rewrite (plus_Idempotence z).
  unfold incl in r.
  rewrite EqG_PlusAssoc.
  rewrite (EqG_PlusCommut y x).
  rewrite r.
  reflexivity.
Qed.

Lemma incl_overlay_left_cong A R `(EqG A R): forall x y z, incl R x y -> incl R (Overlay z x) (Overlay z y).
Proof.
  intros x y z r.
  unfold incl.
  rewrite EqG_PlusAssoc.
  rewrite (EqG_PlusCommut (Overlay z x) z).
  rewrite (EqG_PlusAssoc z z x).
  rewrite (plus_Idempotence z).
  unfold incl in r.
  rewrite (symmetry (EqG_PlusAssoc z x y)).
  rewrite r.
  reflexivity.
Qed.

Add Parametric Morphism A (R: relation (Graph A)) `(EqG A R) : Overlay
  with signature incl R ==> incl R ==> incl R
    as overlay_incl_morph.
Proof.
  intros x y r x' y' r'.
  apply (incl_overlay_left_cong A R H x' y' x) in r'.
  apply (incl_overlay_right_cong A R H x y y') in r.
  apply (incl_transitivity A R H (Overlay x x') (Overlay x y') (Overlay y y')).
  exact r'.
  exact r.
Qed.

Lemma incl_connect_right_cong A R `(EqG A R): forall x y z, incl R x y -> incl R (Connect x z) (Connect y z).
Proof.
  intros x y z r.
  unfold incl.
  rewrite (symmetry (EqG_RightDistributivity x y z)).
  unfold incl in r.
  rewrite r.
  reflexivity.
Qed.

Lemma incl_connect_left_cong A R `(EqG A R): forall x y z, incl R x y -> incl R (Connect z x) (Connect z y).
Proof.
  intros x y z r.
  unfold incl.
  rewrite (symmetry (EqG_LeftDistributivity z x y)).
  unfold incl in r.
  rewrite r.
  reflexivity.
Qed.

Add Parametric Morphism A (R: relation (Graph A)) `(EqG A R) : Connect
  with signature incl R ==> incl R ==> incl R
    as connect_incl_morph.
Proof.
  intros x y r x' y' r'.
  apply (incl_connect_left_cong A R H x' y' x) in r'.
  apply (incl_connect_right_cong A R H x y y') in r.
  apply (incl_transitivity A R H (Connect x x') (Connect x y') (Connect y y')).
  exact r'.
  exact r.
Qed.

Lemma incl_least_elem A R `(EqG A R) : forall x, incl R Empty x.
Proof.
  intro x.
  unfold incl.
  rewrite EqG_PlusCommut.
  rewrite (id_Plus x).
  reflexivity.
Qed.

Lemma ov_incl A R `(EqG A R) : forall x y z, incl R (Overlay x y) z -> incl R x z.
Proof.
  intros x y z r.
  unfold incl in r.
  unfold incl.
  rewrite (symmetry r).
  rewrite EqG_PlusAssoc.
  rewrite (EqG_PlusAssoc x x y).
  rewrite (plus_Idempotence x).
  reflexivity.
Qed.

Lemma co_incl_left A R `(EqG A R) : forall x y z, incl R (Connect x y) z -> incl R x z.
Proof.
  intros x y z r.
  unfold incl in r.
  unfold incl.
  rewrite (symmetry r).
  rewrite EqG_PlusAssoc.
  rewrite (EqG_PlusCommut x (Connect x y)).
  rewrite (symmetry (containmentLeft x y)).
  reflexivity.
Qed.

Lemma co_incl_right A R `(EqG A R) : forall x y z, incl R (Connect x y) z -> incl R y z.
Proof.
  intros x y z r.
  unfold incl in r.
  unfold incl.
  rewrite (symmetry r).
  rewrite EqG_PlusAssoc.
  rewrite (EqG_PlusCommut y (Connect x y)).
  rewrite (symmetry (containmentRight x y)).
  reflexivity.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (x : natural) (y : natural) : natural := plus Zero (mult x y).


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (x : natural) (lf1 : natural) : natural :=
  mult y x.


Set Implicit Arguments.

Require Import FCF.
Require Import CompFold.
Require Import RndListElem.
Require Import Permutation.

Local Open Scope list_scope.

Theorem removeFirst_In_length :
  forall (A : Set)(eqd : EqDec A)(ls : list A)(a : A),
    In a ls ->
    length (removeFirst (EqDec_dec _ ) ls a) = pred (length ls).

  induction ls; intuition; simpl in *.
  intuition; subst.
  destruct (EqDec_dec eqd a0 a0); intuition.

  destruct (EqDec_dec eqd a0 a); subst.
  trivial.
  simpl.
  rewrite IHls.
  destruct ls; simpl in *; intuition.

  trivial.
Qed.

Fixpoint addInAllLocations(A : Type)(a : A)(ls : list A) :=
  match ls with
    | nil =>  (a :: nil) :: nil
    | a' :: ls' =>
      (a :: ls) :: map (fun x => a' :: x) (addInAllLocations a ls')
  end.

Fixpoint getAllPermutations(A : Type)(ls : list A) :=
  match ls with
    | nil => nil :: nil
    | a :: ls' =>
      let perms' := getAllPermutations ls' in
        flatten (map (addInAllLocations a) perms')
  end.

Theorem addInAllLocations_not_nil :
  forall (A : Type) l (a : A),
    addInAllLocations a l = nil -> False.

  induction l; intuition; unfold addInAllLocations in *; simpl in *.
  inversion H.
  inversion H.

Qed.

Theorem getAllPermutations_not_nil :
  forall (A : Type)(ls : list A),
    getAllPermutations ls = nil -> False.

  induction ls; intuition; simpl in *.
  inversion H.

  case_eq (getAllPermutations ls); intuition.
  rewrite H0 in H.
  simpl in *.
  apply app_eq_nil in H.
  intuition.
  eapply addInAllLocations_not_nil; eauto.
Qed.

Theorem addInAllLocations_perm :
  forall (A : Type) x0 (a : A) ls2,
    In ls2 (addInAllLocations a x0) ->
    Permutation ls2 (a :: x0).

  induction x0; intuition; simpl in *.
  intuition; subst.
  eapply Permutation_refl.

  intuition; subst.
  eapply Permutation_refl.

  eapply in_map_iff in H0.
  destruct H0.
  intuition; subst.
  eapply perm_trans.
  Focus 2.
  eapply perm_swap.
  eapply perm_skip.
  eapply IHx0.
  trivial.

Qed.

Theorem getAllPermutations_perms :
  forall (A : Set)(ls1 ls2 : list A),
    In ls2 (getAllPermutations ls1) ->
    Permutation ls1 ls2.

  induction ls1; intuition; simpl in *.
  intuition.
  subst.
  econstructor.

  eapply in_flatten in H.
  destruct H.
  intuition.
  eapply in_map_iff in H0.
  destruct H0.
  intuition.
  subst.
  eapply addInAllLocations_perm in H1.
  eapply perm_trans.
  Focus 2.
  eapply Permutation_sym.
  eauto.
  eapply perm_skip.
  eapply IHls1.
  trivial.

Qed.

Section ShuffleList.

  Variable A : Set.
  Hypothesis A_EqDec : EqDec A.

  Definition shuffle(ls : list A) :=
    o <-$ rndListElem _ (getAllPermutations ls);
    ret
    match o with
      | None => nil
      | Some x => x
    end.

  Theorem shuffle_perm :
    forall (ls1 ls2 : list A),
      In ls2 (getSupport (shuffle ls1)) ->
      Permutation ls2 ls1.

    intuition.
    unfold shuffle in *.
    repeat simp_in_support.
    destruct x.
    eapply Permutation_sym.
    eapply getAllPermutations_perms.
    apply rndListElem_support in H0.
    trivial.

    apply rndListElem_support_None in H0.
    exfalso.
    eapply getAllPermutations_not_nil.
    eauto.

  Qed.

   Fixpoint permute(ls : list A)(sigma : list nat) : list A :=
    match sigma with
      | nil => nil
      | n :: sigma' =>
        match (nth_error ls n) with
          | None => nil
          | Some a => a :: (permute ls sigma')
        end
  end.

   Theorem permute_length_eq :
     forall (sigma : list nat)(ls : list A),
       (forall n, In n sigma -> n < length ls) ->
       length (permute ls sigma) = length sigma.

     induction sigma; intuition; simpl in *.
     case_eq (nth_error ls a); intuition.
     simpl.
     f_equal.
     eapply IHsigma; intuition.

     Theorem nth_error_not_None :
       forall (ls : list A)(n : nat),
         n < length ls ->
         nth_error ls n = None ->
         False.

       induction ls; destruct n; intuition; simpl in *.
       omega.
       omega.
       inversion H0.
       eapply IHls; eauto.
       omega.
     Qed.

     exfalso.
     eapply nth_error_not_None.
     eapply H.
     intuition.
     trivial.
   Qed.

   Theorem shuffle_Permutation :
     forall (ls1 ls2 : list A),
       In ls2 (getSupport (shuffle ls1)) ->
       Permutation ls1 ls2.

     intuition.

     unfold shuffle in *.
     repeat simp_in_support.
     destruct x.
     eapply rndListElem_support in H0.
     eapply getAllPermutations_perms.
     trivial.

     eapply rndListElem_support_None in H0.
     exfalso.
     eapply getAllPermutations_not_nil.
     eauto.

    Qed.

    Theorem shuffle_wf :
      forall ls,
        well_formed_comp (shuffle ls).

      intuition.
      unfold shuffle.
      wftac.
      eapply rndListElem_wf.

    Qed.

End ShuffleList.

Definition RndPerm(n : nat) :=
  shuffle _ (allNatsLt n).

Theorem list_pred_map_both':
  forall (A B C D : Set) (lsa : list A) (lsb : list B)
    (P : C -> D -> Prop) (f : A -> C)(g : B -> D),
  list_pred (fun (a : A) (b : B) => P (f a) (g b)) lsa lsb ->
  list_pred P (map f lsa) (map g lsb).

  intuition.
  eapply list_pred_impl.
  eapply list_pred_map_both.
  eauto.
  intuition.
  destruct H0.
  destruct H0.
  intuition; subst.
  trivial.

Qed.

Theorem addInAllLocations_pred :
  forall (A B : Set) (R : A -> B -> Prop) (a : list A) (b : list B),
    list_pred R a b ->
    forall a1 a2,
      R a1 a2 ->
  list_pred (list_pred R) (addInAllLocations a1 a) (addInAllLocations a2 b).

  induction 1; intuition; simpl in *.

  econstructor.
  econstructor.
  trivial.
  econstructor.
  econstructor.

  econstructor.
  repeat econstructor;assumption.

  eapply list_pred_map_both'.
  eapply list_pred_impl.
  eauto.
  intuition.
  econstructor; assumption.

Qed.

Theorem getAllPermutations_pred :
  forall (A B : Set)(R : A -> B -> Prop)(lsa : list A)(lsb : list B),
  list_pred R lsa lsb ->
     list_pred (list_pred R) (getAllPermutations lsa) (getAllPermutations lsb).

  induction 1; intuition; simpl in *.
  econstructor.
  econstructor.
  econstructor.

  eapply list_pred_flatten_both.
  eapply list_pred_map_both'.
  eapply list_pred_impl.
  eauto.
  intuition.

  eapply addInAllLocations_pred; intuition.
Qed.

Theorem allNats_nth_pred :
  forall (A : Set)(ls : list A),
   list_pred (fun (a : A) (b : nat) => nth_error ls b = Some a) ls
     (allNatsLt (length ls)).

  induction ls using rev_ind; intuition; simpl in *.
  econstructor.

  rewrite app_length.
  simpl.
  rewrite plus_comm.
  simpl.

  eapply list_pred_app_both.
  eapply list_pred_impl.
  eapply IHls.
  intuition.

  Theorem nth_error_app_Some :
    forall (A : Set)(ls : list A) n (a a' : A),
      nth_error ls n = Some a ->
      nth_error (ls ++ (a' :: nil)) n = Some a.

    induction ls; destruct n; intuition; simpl in *.
    inversion H.
    inversion H.

    eapply IHls.
    trivial.

  Qed.

  eapply nth_error_app_Some; intuition.

  econstructor.

  Theorem nth_error_app_length :
    forall (A : Set)(ls : list A) (a : A),
      nth_error (ls ++ (a :: nil)) (length ls) = Some a.

    induction ls; intuition; simpl in *.

  Qed.

  eapply  nth_error_app_length .

  econstructor.

Qed.

Theorem permute_nth_equiv :
  forall (A : Set)(ls : list A) a b,
  list_pred (fun (a0 : A) (b0 : nat) => nth_error ls b0 = Some a0) a b ->
  a = permute ls b.

  induction a; inversion 1; intuition; simpl in *.
  subst.

  rewrite H2.
  f_equal.
  eapply IHa.
  trivial.
Qed.

Theorem getAllPerms_permute_eq :
  forall (A : Set)(ls : list A),
  list_pred (fun (a : list A) (b : list nat) => a = permute ls b)
     (getAllPermutations ls) (getAllPermutations (allNatsLt (length ls))).

  intuition.

  generalize (@getAllPermutations_pred _ _ (fun a b => nth_error ls b = Some a) ls (allNatsLt (length ls))) ; intros.
  eapply list_pred_impl.
  eapply H.

  eapply allNats_nth_pred.

  intuition.

  eapply permute_nth_equiv.
  trivial.

Qed.

Theorem rndListElem_pred :
  forall (A B : Set)(eqda : EqDec A)(eqdb : EqDec B)(P : A -> B -> Prop)(lsa : list A)(lsb : list B),
    list_pred P lsa lsb ->
    comp_spec (fun a b =>
      match a with
        | None => b = None
        | Some a' => exists b', b = Some b' /\ P a' b'
      end) (rndListElem _ lsa) (rndListElem _ lsb).

  intuition.
  unfold rndListElem in *.
  case_eq (length lsa); intuition.
  erewrite <- list_pred_length_eq; eauto.
  rewrite H0.
  eapply comp_spec_ret; intuition.

  erewrite <- list_pred_length_eq; eauto.
  rewrite H0.
  comp_skip.
  apply None.
  apply None.
  eapply comp_spec_ret; intuition.

  case_eq (nth_option lsa b); intuition.

  Theorem list_pred_nth_exists :
    forall (A B : Set)(P : A -> B -> Prop) lsa lsb,
      list_pred P lsa lsb ->
      forall n a,
        nth_option lsa n = Some a -> exists b, nth_option lsb n = Some b /\ P a b.

    induction 1; intuition; simpl in *.
    discriminate.

    destruct n.
    inversion H1; clear H1; subst.
    econstructor; intuition.

    edestruct IHlist_pred; eauto.

  Qed.

  edestruct list_pred_nth_exists; eauto.

  exfalso.
  eapply nth_option_not_None; eauto.
  apply RndNat_support_lt in H1.
  omega.
Qed.

Theorem shuffle_RndPerm_spec :
  forall (A : Set)(eqd : EqDec A)(ls : list A),
    comp_spec (fun a b => a = permute ls b)
    (shuffle eqd ls)
    (shuffle _ (allNatsLt (length ls))).

  intuition.
  unfold shuffle in *.

  comp_skip.
  eapply rndListElem_pred.
  eapply getAllPerms_permute_eq.

  simpl in H1.
  eapply comp_spec_ret; intuition.
  destruct a.
  destruct H1.
  intuition.
  subst.
  trivial.

  subst.
  simpl.
  intuition.
Qed.

Theorem shuffle_RndPerm_spec_eq :
  forall (A : Set)(eqd : EqDec A)(ls : list A),
    comp_spec eq
    (shuffle eqd ls)
    (x <-$ RndPerm (length ls); ret permute ls x).

  intuition.
  eapply comp_spec_eq_trans.
  eapply comp_spec_eq_symm.
  eapply comp_spec_right_ident.
  comp_skip.
  eapply shuffle_RndPerm_spec.
  eapply comp_spec_ret; intuition.

Qed.

Theorem RndPerm_In_support :
  forall n ls,
    In ls (getSupport (RndPerm n)) ->
    Permutation (allNatsLt n) ls.

  intuition.
  eapply shuffle_Permutation.
  eapply H.
Qed.

Theorem RndPerm_In_support_length :
  forall n ls,
    In ls (getSupport (RndPerm n)) ->
    length ls = n.

  intuition.
  erewrite Permutation_length.
  Focus 2.
  eapply Permutation_sym.
  eapply RndPerm_In_support.
  eauto.
  eapply allNatsLt_length.
Qed.

Theorem RndPerm_wf :
  forall n,
    well_formed_comp (RndPerm n).

  intuition.
  unfold RndPerm.
  eapply shuffle_wf.

Qed.


Require Import Coq.omega.Omega.
Require Import Rsequence_def.
Require Import Rsequence_base_facts Rsequence_sums_facts.
Require Import Rsequence_rewrite_facts.
Require Import Lra.
Require Import MyRIneq.

Open Scope R_scope.
Open Scope Rseq_scope.

(** * Boundedness compatibility. *)

Section Rseq_bound_compatibilities.

Variables (Un Vn : Rseq) (lu lv : R).
Hypothesis (Un_bd : Rseq_bound Un lu) (Vn_bd : Rseq_bound Vn lv).

Lemma Rseq_bound_eq : forall Wn, Un == Wn ->
  Rseq_bound Wn lu.
Proof.
intros Wn Heq n ; rewrite <- Heq ; apply Un_bd.
Qed.

Lemma Rseq_bound_opp : Rseq_bound (- Un) lu.
Proof.
intro n ; unfold Rseq_opp ; rewrite Rabs_Ropp ; apply Un_bd.
Qed.

Lemma Rseq_bound_plus : Rseq_bound (Un + Vn) (lu + lv).
Proof.
intro n ; unfold Rseq_plus ;
 apply Rle_trans with (Rabs (Un n) + Rabs (Vn n))%R ;
 [apply Rabs_triang | apply Rplus_le_compat ; auto].
Qed.

Lemma Rseq_bound_minus : Rseq_bound (Un - Vn) (lu + lv).
Proof.
intro n ; unfold Rseq_minus, Rminus ;
 apply Rle_trans with (Rabs (Un n) + Rabs (- Vn n))%R ;
 [apply Rabs_triang | rewrite Rabs_Ropp ; apply Rplus_le_compat ; auto].
Qed.

Lemma Rseq_bound_mult : Rseq_bound (Un * Vn) (lu * lv).
Proof.
intro n ; unfold Rseq_mult ; rewrite Rabs_mult ;
 apply Rmult_le_compat ; (apply Rabs_pos || auto).
Qed.

Lemma Rseq_bound_sum : Rseq_bound (Rseq_sum Un / Rseq_shift INR) lu.
Proof.
intro n ; induction n ; unfold Rseq_div, Rseq_shift, Rdiv.
 simpl ; rewrite Rinv_1, Rmult_1_r ; apply Un_bd.
 rewrite Rabs_mult, Rabs_Rinv ; [| apply not_0_INR ; omega].
 apply Rmult_Rinv_le_compat ; [apply Rabs_pos_lt ; apply not_0_INR ; omega |].
 rewrite (Rabs_pos_eq (INR (S (S n)))), Rseq_sum_simpl, S_INR,
 Rmult_plus_distr_r, Rmult_1_l ; [| apply pos_INR].
 eapply Rle_trans ; [eapply Rabs_triang |] ; apply Rplus_le_compat.
 rewrite <- (Rabs_pos_eq (INR (S n))) ; [| apply pos_INR].
 apply Rmult_Rinv_le_compat_contravar ; [apply Rabs_pos_lt ; apply not_0_INR ; omega |].
 rewrite <- Rabs_Rinv, <- Rabs_mult ; [apply IHn | apply not_0_INR ; omega].
 apply Un_bd.
Qed.

End Rseq_bound_compatibilities.

Lemma Rseq_bound_prod : forall (Un Vn : Rseq) (lu lv : R),
  Rseq_bound Un lu -> Rseq_bound Vn lv ->
  Rseq_bound ((Un # Vn) / Rseq_shift INR) (lu * lv).
Proof.
intros Un Vn lu lv Un_bd Vn_bd n ; unfold Rseq_prod, Rseq_div ;
 apply Rseq_bound_sum ; apply Rseq_bound_mult ;
 [apply Un_bd | intro p ; apply Vn_bd].
Qed.


(*|
#################################################
How can I read Coq's definition of ``proj1_sig``?
#################################################

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

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

In Coq, ``sig`` is defined as
|*)

Print sig. (* .unfold .messages *)

(*|
Which I read as

    ``A sig P`` is a type, where ``P`` is a function taking an ``A``
    and returning a ``Prop``. The type is defined such that an element
    ``x`` of type ``A`` is of type ``sig P`` if ``P x`` holds.

``proj1_sig`` is defined as
|*)

Print proj1_sig. (* .unfold .messages *)

(*|
I'm not sure what to make of that. Could somebody provide a more
intuitive understanding?

----

**A:** This `question
<http://stackoverflow.com/questions/38777736/how-do-i-read-the-definition-of-ex-intro>`__
is somewhat related. And `this
<http://stackoverflow.com/questions/11593270/coq-extract-witness-from-proposition>`__
one and `this
<http://stackoverflow.com/questions/26493911/how-to-extract-z-from-subset-type-z-z-z-0>`__.
Also, `this
<http://stackoverflow.com/questions/27079513/prove-equality-on-sigma-types>`__
question on equality of sigma types can be of some interest too. I've
added these links because the automatic ones were not too close.
|*)

(*|
Answer
******

Non-dependent pairs vs. ``sig``
===============================

    The type is defined such that an element ``x`` of type ``A`` is of
    type ``sig P`` if ``P x`` holds.

That is not entirely correct: we can't say ``x : sig A P``. An
inhabitant ``e`` of type ``sig A P`` is essentially a *pair* of an
element ``x : A`` and a proof that ``P x`` holds (this is called a
`dependent pair
<https://en.wikipedia.org/wiki/Dependent_type#Dependent_pair_type>`__).
``x`` and ``P x`` are "wrapped" together using the data constructor
``exist``.

To see this let us first consider the non-dependent pair type
``prod``, which is defined as follows:
|*)

Print prod. (* .unfold .messages *)

(*|
``prod``'s inhabitants are pairs, like ``pair 1 true`` (or, using
notations, ``(1, true)``), where the *types* of both components are
*independent* of each other.

Since ``A -> B`` in Coq is just syntactic sugar for ``forall _ : A,
B`` (defined `here
<https://coq.inria.fr/library/Coq.Init.Logic.html>`__), the definition
of ``prod`` can be desugared into
|*)

Inductive prod (A B : Type) : Type :=  pair : forall _ : A, B -> prod A B.

(*|
The above definition, perhaps, can help to see that elements of ``sig
A P`` are (dependent) pairs.

What we can derive from implementation and type of ``proj1_sig``
================================================================

From the implementation we can see that ``proj1_sig e`` unpacks the
pair and returns the *first* component, viz. ``x``, throwing away the
proof of ``P x``.

The `Coq.Init.Specif
<https://coq.inria.fr/library/Coq.Init.Specif.html>`__ module contains
the following comment:

    ``(sig A P)``, or more suggestively ``{x:A | P x}``, denotes the
    subset of elements of the type ``A`` which satisfy the predicate
    ``P``.

If we look at the type of ``proj1_sig``
|*)

Check proj1_sig. (* .unfold *)

(*|
we will see that ``proj1_sig`` gives us a way of recovering an element
of a superset ``A`` from its subset ``{x : A | P x}``.

Analogue between ``fst`` and ``proj1_sig``
==========================================

Also, we can say that in some sense ``proj1_sig`` is analogous to the
`fst <https://coq.inria.fr/library/Coq.Init.Datatypes.html#fst>`__
function, which returns the first component of a pair:
|*)

Check @fst. (* .unfold *)

(*| There is a trivial property of ``fst``: |*)

Goal forall A B (a : A) (b : B),
    fst (a, b) = a.
Proof. reflexivity. Qed.

(*| We can formulate a similar statement for ``proj1_sig``: |*)

Goal forall A (P : A -> Prop) (x : A) (prf : P x),
    proj1_sig (exist P x prf) = x.
Proof. reflexivity. Qed.

(*|
----

**Q:** Okay, so suppose I have an element ``x`` of ``sig P``. Is
``proj1_sig x`` just ``x``?

**A:** No, it's not. ``x`` is a "pair". You probably meant something
like this ``proj1_sig (exist P x prf) = x``, which is an analogue of
``fst (a, b) = a``.
|*)


Add LoadPath "." as PDCoq.
Require Export quotient_proofs.
(* OrderedTypeEx.*)

(** %{\em Regular expressions}% are defined by the following inductive type: *)

(*Generalizable All Variables.*)

Inductive re : Type :=
| re0 : re
| re1 : re
| re_sy : Z -> re
| re_union : re -> re -> re
| re_conc : re -> re -> re
| re_star : re -> re.

(*Generate OrderedType re.*)
Hint Constructors re : lre.
Notation "0"      := re0.
Notation "1"      := re1.
Notation "\! s" := (re_sy s)(at level 10).
Notation "x + y"  := (re_union x y)(at level 50,left associativity).
Notation "x · y"  := (re_conc x y)(at level 58,left associativity).
Notation "x ⋆"    := (re_star x)(at level 45).

(* Length of regular expressions *)

Fixpoint len_re  (r:re) : nat :=
  match r with
    | 0 => (S O)
    | 1 =>  (S O)
    | \!_ => (S O)
    | x + y => S (len_re x + len_re y)
    | x · y => S (len_re x + len_re y)
    | x ⋆ => S (len_re x)
  end.

(** Symbol-length of regular expressions *)
Reserved Notation "|< x >|".
Fixpoint sylen  (r:re) : nat :=
  match r with
    | 0 => O
    | 1 => O
    | \!_ => (S O)
    | x + y => plus (sylen x) (sylen y)
    | x · y => plus (sylen x) (sylen y)
    | x ⋆ => (sylen x)
  end.
Notation "|< x >|" := (sylen x).

Fixpoint re2rel  (x:re) : language :=
  match x with
    | 0 => ∅
    | 1 => {ε}
    | \!a => {{a}}
    | X + Y => (re2rel X) ∪ (re2rel Y)
    | X · Y => (re2rel X) • (re2rel Y)
    | X ⋆ => (re2rel X) ∗
  end.

Coercion re2rel : re >-> language.

Global Instance re2rel_m : Proper(eq ==> leq) re2rel.
Proof.
  repeat red.
  split_eq;subst;
  eauto with lgs.
Qed.

Theorem re2rel_is_RL : forall r:re, rl r.
Proof.
  induction r;simpl;intros;try constructor;try auto.
Qed.

(** Word of the language of regular expressions is well formed  *)
Lemma re_wf : forall r:re, language_wf (r).
Proof.
  induction r;simpl;auto with lgs.
Qed.

(** Decidable syntactical equality of regular expressions is available
     (through definitional equality of $\Coq$), and they also form an
     ordered set. The ordering of regular expressions is a
     lexicografical one, and is defined in the following code block:
     *)

Lemma re_sy_dec : forall r1 r2:re, {r1=r2}+{r1<>r2}.
Proof.
  decide equality;auto with zarith.
  apply Z_eq_dec.
Qed.

  (** Determining the empty word property for regular expressions is a syntactical version of the [cases_epsilon] function.*)

Reserved Notation "ε( y )" (at level 45,right associativity).
Fixpoint c_of_re  (r:re) : bool :=
  match r with
    | 0 => false
    | 1 => true
    | \!_ => false
    | _⋆ => true
    | x + y => ε(x) || ε(y)
    | x · y => ε(x) && ε(y)
  end
  where "ε( y )" := (c_of_re y).

Add Morphism c_of_re : c_of_re_m.
Proof.
  repeat red;intros;subst;auto.
Qed.

  (** We now determine the language of [c_of_re]. This means that, when [c_of_re] returns [true] then it must
     represent $\{\epsilon\}$. Otherwise, if [c_of_re] returns [false], then it should describe the language
     $\emptyset$. We define [lc_of_re] as such a function, and relate it to the [cases_epsilon] function to ensure
     its correctness *)

Definition lc_of_re  (r:re) := if ε(r) then {ε} else ∅.
Notation "ε'( x )" := (lc_of_re x)(at level 45).

Instance lc_of_re_m : Proper(eq ==> leq) lc_of_re.
Proof.
  unfold lc_of_re.
  intro;intros.
  subst.
  destruct(ε(y));reflexivity.
Qed.

(** Production of the re. corresponding to the emptyness of the re. given
     as argument *)
Definition c_c_of_re (r:re) := if ε(r) then 1 else 0.
Notation "ε''( x )" := (c_c_of_re x)(at level 45).

Lemma c_of_c_c_true  :
  forall r,
    ε(r) = true -> ε''(r) = 1.
Proof.
  intros r H;unfold c_c_of_re;rewrite H;auto.
Qed.

Lemma c_of_c_c_false :
  forall r,
    ε(r) = false -> ε''(r) = 0.
Proof.
  intros r H;unfold c_c_of_re;rewrite H;auto.
Qed.

Lemma c_c_of_c_true :
  forall r,
    ε''(r) = 1 -> ε(r) = true.
Proof.
  intros r H;unfold c_c_of_re in H;destruct(ε(r));congruence.
Qed.

Lemma c_c_of_c_false :
  forall r,
    ε''(r) = 0 -> ε(r) = false.
Proof.
  intros r H;unfold c_c_of_re in H;destruct(ε(r));congruence.
Qed.

Hint Resolve
  c_of_c_c_true
  c_of_c_c_false
  c_c_of_c_true
  c_c_of_c_false : res.

(** Decidability of emptyness testing for an re. *)
Lemma c_of_re_dec :
  forall r,
    {ε(r) = false}+{ε(r) = true}.
Proof.
  intro r;destruct(ε(r));auto.
Qed.

(** Nullability and epsilon membership *)
Lemma null_eps_in_l :
  forall r:re,
   ε(r) = true -> [] ∈ re2rel r.
Proof.
  induction r;simpl;intros;try congruence;auto with lgs.
  simpl_bool;destruct H as [H1|H2];[apply IHr1 in H1|apply IHr2 in H2];
    solve_trivial_union.
  simpl_bool;destruct H as [H1 H2];apply IHr1 in H1;apply IHr2 in H2.
  rewrite app_nil_end;auto with lgs.
  constructor 1 with (n:=0%nat);simpl;auto with lgs.
Qed.

Lemma eps_in_l_null :
  forall r:re,
   [] ∈ re2rel r -> ε(r) = true.
Proof.
  induction r;simpl;intros;try congruence;try now(inv H);auto with lgs.
  simpl_bool;invc H;eauto.
  simpl_bool;inv H.
  apply app_eq_nil in H0;destruct H0;subst;eauto.
Qed.

Lemma not_eps_not_in_l :
  forall r:re,
   ε(r) = false -> ~[] ∈ re2rel r.
Proof.
  induction r;simpl;intros;try congruence;try (now(intro H1;inv H1));
    auto with lgs.
  simpl_bool;destruct H as [H1 H2];intro;apply IHr1 in H1;apply IHr2 in H2;
    inv H.
  simpl_bool;destruct H as [H1|H2];intro;[apply IHr1 in H1|apply IHr2 in H2];
    inv H; apply app_eq_nil in H0;destruct H0;subst;eauto.
Qed.

Lemma neg_not_in_conc :
  forall r1 r2:re,
  ~ [] ∈ (r1 • r2) -> ~[] ∈ (re2rel r1) \/ ~[] ∈ (re2rel r2).
Proof.
  intros r1 r2 H;destruct(c_of_re_dec r1).
  apply not_eps_not_in_l in e;auto.
  right;intro;apply H;apply null_eps_in_l in e;
    rewrite app_nil_end;auto with lgs.
Qed.

Lemma not_in_l_not_eps :
  forall r:re,
   ~[] ∈ re2rel r -> ε(r) = false.
Proof.
  induction r;simpl;intros;try congruence;try (now(intro H1;inv H1));
    auto with lgs.
  assert([] ∈ {ε}) by auto with lgs;contradiction.
  apply neg_not_nil_aux_1 in H;simpl_bool;destruct H;eauto.
  simpl_bool;apply neg_not_in_conc in H;destruct H;eauto.
  assert([] ∈ (r ∗)) by (constructor 1 with O;simpl;eauto with lgs);
    contradiction.
Qed.

Hint Resolve
  null_eps_in_l
  eps_in_l_null
  not_eps_not_in_l
  neg_not_in_conc
  not_in_l_not_eps : res lgs.