(** Celia Picard with contributions by Ralph Matthes,
    I.R.I.T.,  University of Toulouse and CNRS*)

(**  provides an implementation of the segments of natural numbers
     NatSeg. It also provides various properties
     and lemmas about it *)

(** this is code that conforms to the description in the article
    " Coinductive graph representation: the problem of embedded lists"
    by the authors *)

Require Export Arith.
Require Import Utf8.
Require Import Setoid.
Require Import Morphisms.

Set Implicit Arguments.

(* We represent segments of natural numbers.
   NatSeg n is the Set containing all naturals number lower than n. *)
Definition NatSeg (n: nat):= {m | m < n}.

(* And we define basic operation over these segments *)
Definition elem (n: nat)(f: NatSeg n): nat := proj1_sig f.
Definition proof_lt(n: nat)(f: NatSeg n): elem f < n := proj2_sig f.

Lemma elem_lt_n: forall (n: nat)(ns: NatSeg n), elem ns < n.
Proof.
  intros n [m h].
  assumption.
Qed.

(* We define an equivalence relation over NatSeg.
   And proove it is one. *)
Inductive natSeg_eq (n: nat) (ns1 ns2: NatSeg n): Prop :=
  is_natSeg_eq: elem ns1 = elem ns2 -> natSeg_eq ns1 ns2.

Infix "~" := natSeg_eq (at level 60).

Lemma natSeg_eq_refl(n: nat): forall (ns: NatSeg n), ns ~ ns.
Proof.
  intros ns.
  apply is_natSeg_eq.
  reflexivity.
Qed.

Lemma natSeg_eq_sym (n: nat): forall (ns1 ns2: NatSeg n),
  ns1 ~ ns2 -> ns2 ~ ns1.
Proof.
  intros ns1 ns2 [h].
  apply is_natSeg_eq.
  apply (sym_eq h).
Qed.

Lemma natSeg_eq_trans (n: nat): forall (ns1 ns2 ns3: NatSeg n),
  ns1 ~ ns2 -> ns2 ~ ns3 -> ns1 ~ ns3.
Proof.
  intros ns1 ns2 ns3 [h1] [h2].
  apply is_natSeg_eq.
  apply (trans_eq h1 h2).
Qed.

Add Parametric Relation (n: nat): (NatSeg n) (natSeg_eq (n:= n))
  reflexivity proved by (natSeg_eq_refl(n:= n))
  symmetry proved by (natSeg_eq_sym(n:= n))
  transitivity proved by (natSeg_eq_trans(n:= n))
   as natSeg_eq_Rel.

Add Parametric Morphism (n: nat): (elem(n:= n))
  with signature (natSeg_eq (n:= n)) ==> (eq (A:= nat))
  as elemM.
Proof.
  intros x y [h].
  assumption.
Qed.

Lemma NatSeg_0_empty: forall ns: NatSeg 0, False.
Proof.
  intros [n h].
  inversion h.
Qed.

(* We declare another relation that is more general, but that is not
   really an equivalence relation. *)

Inductive natSeg_eq_gen (n1 n2: nat) (ns1: NatSeg n1) (ns2: NatSeg n2): Prop:=
  is_natSeg_eq_gen: elem ns1 = elem ns2 -> natSeg_eq_gen ns1 ns2.

Infix "~~" := natSeg_eq_gen (at level 60).

Lemma natSeg_eq_gen_refl: forall (n: nat) (ns: NatSeg n), ns ~~ ns.
Proof.
  intros n ns.
  apply is_natSeg_eq_gen.
  reflexivity.
Qed.

Lemma natSeg_eq_gen_sym:
  forall (n1 n2: nat) (ns1: NatSeg n1) (ns2: NatSeg n2),
  ns1 ~~ ns2 -> ns2 ~~ ns1.
Proof.
  intros n1 n2 ns1 ns2 [h].
  apply is_natSeg_eq_gen.
  apply (sym_eq h).
Qed.

Lemma natSeg_eq_gen_trans: forall (n1 n2 n3: nat)
  (ns1: NatSeg n1) (ns2: NatSeg n2) (ns3: NatSeg n3),
  ns1 ~~ ns2 -> ns2 ~~ ns3 -> ns1 ~~ ns3 .
Proof.
  intros n1 n2 n3 ns1 ns2 ns3 [h1] [h2].
  apply is_natSeg_eq_gen.
  apply (trans_eq h1 h2).
Qed.

(* Functions that allow to create a NatSeg *)
Definition makeNatSeg (m n: nat) (h: m < n): NatSeg n.
Proof.
  exists m.
  assumption.
Defined.

Program Definition makeNatSeg' (m n: nat) (h: m < n): NatSeg n := m.

(* Transforms a function i so that i
   makeNatSeg ((n-1) < n) = makeNatSeg ((n'-1) < n') *)
Definition transformI (n n': nat)(i: NatSeg n -> NatSeg n')
  (ns: NatSeg n): NatSeg n'.
Proof.
  destruct n as [|n].
  - apply False_rec.
    apply (NatSeg_0_empty ns).
  - destruct n' as [|n'].
    + apply False_rec.
      apply (NatSeg_0_empty (i ns)).
    + elim (eq_nat_dec (elem (i ns)) n'); intros a.
      * exact (i (makeNatSeg (lt_n_Sn n))).
      * elim (le_lt_eq_dec (elem ns) n (lt_n_Sm_le (elem ns) n (proof_lt ns)));
          intros b.
        -- exact (i ns).
        -- exact ((makeNatSeg (lt_n_Sn n'))).
Defined.

(* Transforms a function i of type : NatSeg (S n) -> NatSeg n' into a
   function of type NatSeg n -> NatSeg n', that for all ns: NatSeg n
   is worth (i ns) *)
Definition mkLessI(n n': nat)(i: NatSeg (S n) -> NatSeg n'):
  NatSeg n -> NatSeg n'.
Proof.
  intros [m h].
  exact (i (makeNatSeg (lt_S m n h))).
Defined.

(* Function that allow to create an element of type (NatSeg n) from an
   element of (NatSeg (S n)) *)
Definition transfoNs(n: nat)(ns: NatSeg (S n))(h: elem ns < n): NatSeg n :=
  makeNatSeg h.

Program Definition transfoNs' (n: nat)(ns: NatSeg (S n))(h: elem ns < n):
  NatSeg n := elem ns.

Lemma transfoNseqNs': transfoNs = transfoNs'.
Proof.
  reflexivity.
Qed.

(* Function that allow to create an element of type (NatSeg (S n)) from an
   element of (NatSeg n) *)
Definition transfoSNs (n: nat) (ns: NatSeg n): NatSeg (S n) :=
  makeNatSeg (lt_S (elem ns) n (proof_lt ns)).

Program Definition transfoSNs' (n: nat) (ns: NatSeg n): NatSeg (S n) :=
  (elem ns).
Next Obligation.
  apply lt_S.
  apply elem_lt_n.
Defined.

Lemma transfoSNseqSNs' (n: nat) (ns: NatSeg n): transfoSNs ns ~ transfoSNs' ns.
Proof.
  apply is_natSeg_eq.
  reflexivity.
Qed.

Definition mkLessI' (n n': nat)(i: NatSeg (S n) -> NatSeg n'):
  NatSeg n -> NatSeg n' := fun ns => i (transfoSNs ns).

Lemma mkLessIeqI' (n n': nat) (i:  NatSeg (S n) -> NatSeg n')(ns: NatSeg n):
  mkLessI i ns = mkLessI' i ns.
Proof.
  destruct ns as [m h].
  reflexivity.
Qed.

Add Parametric Morphism (n: nat): (transfoSNs(n:= n))
  with signature (natSeg_eq (n:= n)) ==> (natSeg_eq (n:= S n))
  as transfoNsM.
Proof.
  intros [n1 h1] [n2 h2] [h].
  apply is_natSeg_eq.
  assumption.
Qed.

(* Lemmas to check that transfoNs and transfoSNs are coherent *)
Lemma transfoSNs_transfoNs_Id:
  forall (n: nat)(ns: NatSeg (S n))(h: elem ns < n),
  transfoSNs (transfoNs ns h) ~ ns.
Proof.
  intros n ns h.
  apply is_natSeg_eq.
  reflexivity.
Qed.

Lemma elem_transfoSNs_n: forall (n: nat) (ns: NatSeg n),
  elem (transfoSNs ns) < n.
Proof.
  intros n [m h].
  assumption.
Qed.

Lemma transfoNs_transfoSNs_Id:
  forall (n: nat)(ns: NatSeg n),
  transfoNs (transfoSNs ns) (elem_transfoSNs_n ns)  ~ ns.
Proof.
  intros n [m h].
  apply is_natSeg_eq.
  reflexivity.
Qed.

Lemma natSeg_eq_gen_transfo_ns:
  forall (n: nat) (ns: NatSeg (S n))(h: elem ns < n),
  elem ns = elem (transfoNs ns h).
Proof.
  reflexivity.
Qed.

Lemma elem_bij: forall (n: nat)(ns1 ns2: NatSeg n),
  elem ns1 = elem ns2 <-> ns1 ~ ns2.
Proof.
  intros n ns1 ns2 ;
  split;
  intros h;
  [apply is_natSeg_eq | destruct h as [h]];
  assumption.
Qed.

(* We show that makeNatSeg is consistent *)
Lemma makeNatSeg_ns: forall (n: nat)(ns: NatSeg n),
  ns ~ makeNatSeg (proof_lt ns).
Proof.
  intros n [m h].
  apply is_natSeg_eq.
  reflexivity.
Qed.

Lemma mkLessI_i_Id:
  forall (n n': nat)(ns: NatSeg (S n))(h: elem ns < n)
  (i: NatSeg (S n) -> NatSeg n')
  (H: forall x y: NatSeg (S n), x ~ y -> i x ~ i y),
  (i ns) ~~ ((mkLessI i) (transfoNs ns h)).
Proof.
  intros n n' ns h i H .
  apply is_natSeg_eq_gen.
  cbn.
  rewrite elem_bij.
  apply H.
  apply is_natSeg_eq.
  reflexivity.
Qed.

(* Another way to create elements of (NatSeg n) without makeNatSeg is to
   use 'exist'. We show here its consistency with the definition of
   natSeg_eq *)
Lemma exist_id: forall (n:nat)(ns: NatSeg n),
  ns ~ (exist (fun m : nat => m < n) (elem ns) (proof_lt ns)).
Proof.
  intros n ns.
  apply is_natSeg_eq.
  reflexivity.
Qed.

Lemma exist_id2: forall (n:nat)(ns: NatSeg n),
  ns = (exist (fun m : nat => m < n) (elem ns) (proof_lt ns)).
Proof.
  intros n [m h].
  reflexivity.
Qed.

Lemma exist_id3: forall (n:nat)(ns: NatSeg n)(h: elem ns < n),
  ns ~ (exist (fun m : nat => m < n) (elem ns) h).
Proof.
  intros n ns h.
  apply is_natSeg_eq.
  reflexivity.
Qed.

Notation Morphism R f := (Proper (R%signature) f).
Definition natSeg_morph (n n': nat) (i: NatSeg n -> NatSeg n'):=
  Morphism(natSeg_eq(n:= n) ==> natSeg_eq(n:=n')) i.

(* Two lemmas to prove that for a 'good' i, ns1 ~ ns2 <-> i ns1 ~ i ns2 *)
Lemma natSeg_eq_surj:
  forall (n n': nat) (ns1 ns2: NatSeg n) (i: NatSeg n -> NatSeg n')
  (Hypi:natSeg_morph i),
  ns1 ~ ns2 -> (i ns1) ~ (i ns2).
Proof.
  intros n n' ns1 ns2 i Hypi h.
  unfold natSeg_morph in Hypi.
  rewrite h.
  reflexivity.
Qed.

Lemma j_i_inj: forall (n n': nat) (ns1 ns2: NatSeg n)
  (i: NatSeg n -> NatSeg n')(j: NatSeg n' -> NatSeg n)
  (Hypj:natSeg_morph j),
  (forall ns: NatSeg n, (j (i ns)) ~ ns) ->
  (i ns1) ~ (i ns2) -> ns1 ~ ns2.
Proof.
  intros n n' ns1 ns2 i j Hypj H1 H2.
  rewrite <- (H1 ns1).
  rewrite <- (H1 ns2).
  unfold natSeg_morph in Hypj.
  rewrite H2.
  reflexivity.
Qed.

Lemma makeNatSeg_ns_natSegeq: forall (n m: nat)(ns: NatSeg n)(h: m < n),
  elem ns = m <-> ns ~ (makeNatSeg h).
Proof.
  intros n m ns h ; split ;
  [intros e; apply is_natSeg_eq | intros [e]];
  assumption.
Qed.

Ltac unfold_transformI :=
  unfold transformI ;
  unfold sumbool_rec;
  unfold sumbool_rect.

Ltac no_NatSeg_0 ns := apply False_rec; apply (NatSeg_0_empty ns).

(* We want to show that if the composition of two functions i and j
   gives the identity, then the composition of the transformation of
   these functions with transformI still gives the identity *)
Lemma transform_Id: forall (n n': nat)
  (i: NatSeg n -> NatSeg n') (j: NatSeg n' -> NatSeg n)
  (Hypi:natSeg_morph i)(Hypj:natSeg_morph j),
  (forall ns: NatSeg n, (j (i ns)) ~ ns) ->
  (forall ns': NatSeg n', (i (j ns')) ~ ns') ->
  (forall ns: NatSeg n,
    (transformI j (transformI i ns)) ~ ns).
Proof.
  intros [|n] n' i j Hypi Hypj Idji Idij ns ;
  unfold natSeg_morph in Hypi;
  unfold natSeg_morph in Hypj.
  - no_NatSeg_0 ns.
  - destruct n' as [|n'].
    + no_NatSeg_0 (i ns).
    + unfold_transformI.
      elim (eq_nat_dec (elem (i ns)) n'); intros a.
      * elim (eq_nat_dec (elem (j (i (makeNatSeg (lt_n_Sn n))))) n);
          intros b.
        -- apply (makeNatSeg_ns_natSegeq (i ns) (lt_n_Sn n')) in a.
           rewrite <- a.
           apply Idji.
        -- rewrite Idji in b.
           contradiction b ; reflexivity.
      * elim (le_lt_eq_dec (elem ns) n); intros b.
        -- elim (eq_nat_dec (elem (j (i ns))) n); intros c.
           ++ rewrite Idji in c.
              rewrite c in b.
              apply False_rec.
              apply (lt_irrefl n b).
           ++ elim (le_lt_eq_dec (elem (i ns)) n'); intros d.
              ** apply Idji.
              ** contradiction d ; reflexivity.
        -- elim (eq_nat_dec (elem (j (makeNatSeg (lt_n_Sn n')))) n); intros c.
           ++ apply is_natSeg_eq.
              rewrite c.
              apply (sym_eq b).
           ++ elim (le_lt_eq_dec (elem (makeNatSeg (lt_n_Sn n'))) n'); intros d.
              ** apply False_rec.
                 apply (lt_irrefl n' d).
              ** symmetry.
                 apply (makeNatSeg_ns_natSegeq ns (lt_n_Sn n)).
                 assumption.
Qed.

Lemma not_NatSeg_eq: forall (n: nat)(ns1 ns2: NatSeg n),
  not (ns1 ~ ns2) <-> elem ns1 <> elem ns2.
Proof.
  intros n ns1 ns2 ; split;
  intros H1 H2;
  [ rewrite elem_bij in H2 | rewrite <- elem_bij in H2 ];
  apply (H1 H2).
Qed.

Lemma i_not_natSeg_eq:
  forall (n n': nat)(ns1 ns2: NatSeg n)
  (i: NatSeg n -> NatSeg n')(j: NatSeg n' -> NatSeg n)
  (Hypj: natSeg_morph j),
  (forall ns: NatSeg n, (j (i ns)) ~ ns) -> not (ns1 ~ ns2) ->
  not (i ns1 ~ i ns2).
Proof.
  intros n n' ns1 ns2 i j Hypj H1 H2 H3.
  apply (H2 (j_i_inj ns1 ns2 i Hypj H1 H3)).
Qed.

Lemma transformI_lt_n: forall (n n': nat)(ns: NatSeg (S n))
  (i: NatSeg (S n) -> NatSeg (S n'))(j: NatSeg (S n') -> NatSeg (S n))
  (Hypj:natSeg_morph j), (forall ns: NatSeg (S n), (j (i ns)) ~ ns)->
  elem ns < n -> elem (transformI i ns) < n'.
Proof.
  intros n n' ns i j Hypj Idji h.
  unfold_transformI.
  elim (eq_nat_dec (elem (i ns)) n'); intros a.
  - elim (eq_nat_dec (elem (ns)) (elem (makeNatSeg (lt_n_Sn n)))); intros b.
    + rewrite b in h.
      apply False_rec.
      apply (lt_irrefl n h).
    + elim (le_lt_eq_dec (elem (i (makeNatSeg (lt_n_Sn n)))) n') ;
        try (intro c).
      * assumption.
      * rewrite <- a in c.
        rewrite elem_bij in c.
        apply (j_i_inj (makeNatSeg (lt_n_Sn n)) ns i Hypj Idji) in c.
        destruct c as [c].
        rewrite c in b.
        contradiction b.
        reflexivity.
      * apply lt_n_Sm_le.
        apply elem_lt_n.
  -  elim (le_lt_eq_dec (elem ns) n); intro b.
     + elim (not_eq (elem (i ns)) n' a); intro c.
       * assumption.
       * apply False_rec.
         apply (lt_irrefl _ (lt_le_trans _ _ _ c (lt_n_Sm_le _ _ (elem_lt_n (i ns))))).
     + rewrite b in h.
       apply False_rec.
       apply (lt_irrefl _ h).
Qed.

(* We define a function that given a function i: NatSeg (S n)-> NatSeg (S n'),
   returns a function i': NatSeg n-> NatSeg n' that gives the same values as
   i *)
Definition mkLessI_transform(n n': nat)
  (i: NatSeg (S n)-> NatSeg (S n'))(j: NatSeg (S n') -> NatSeg (S n))
  (Hypj:natSeg_morph j)(HInv: forall ns: NatSeg (S n), (j (i ns)) ~ ns)
  (ns: NatSeg n): NatSeg n'.
Proof.
  assert (H: elem (transformI i (transfoSNs ns)) < n').
  { apply (transformI_lt_n (transfoSNs ns) i Hypj HInv).
    destruct ns as [m h].
    assumption. }
  exact (transfoNs (transformI i (transfoSNs ns)) H).
Defined.

Program Definition mkLessI_transform' (n n': nat)
  (i: NatSeg (S n)-> NatSeg (S n'))(j: NatSeg (S n') -> NatSeg (S n))
  (Hypj:natSeg_morph j)(HInv: forall ns: NatSeg (S n), (j (i ns)) ~ ns)
  (ns: NatSeg n): NatSeg n':= elem (transformI i (transfoSNs ns)).
Next Obligation.
  fold (transformI i (transfoSNs ns)).
  apply (transformI_lt_n (transfoSNs ns) i Hypj HInv).
  destruct ns as [m h].
  assumption.
Defined.

(* We prove various properties about mkLessI_transform *)
Lemma mkLessI_transform_transformI_id:
  forall (n n': nat) (ns: NatSeg n)
  (i: NatSeg (S n)-> NatSeg (S n'))(j: NatSeg (S n') -> NatSeg (S n))
  (Hypj: natSeg_morph j)(HInv: forall ns: NatSeg (S n), (j (i ns)) ~ ns),
  transfoSNs (mkLessI_transform i Hypj HInv ns) ~
  transformI i (transfoSNs ns).
Proof.
  intros n n' ns i j Hypj HInv.
  apply transfoSNs_transfoNs_Id.
Qed.

Lemma mkLessI_transform_transformI_id2:
  forall (n n': nat) (ns: NatSeg n)
  (i: NatSeg (S n)-> NatSeg (S n'))(j: NatSeg (S n') -> NatSeg (S n))
  (Hypj: natSeg_morph j)(HInv: forall ns: NatSeg (S n), (j (i ns)) ~ ns),
  mkLessI_transform i Hypj HInv ns ~
  transfoNs (transformI i (transfoSNs ns))
  (transformI_lt_n (transfoSNs ns) i Hypj HInv (elem_transfoSNs_n ns)).
Proof.
  intros n n' ns i j Hypj HInv.
  apply is_natSeg_eq.
  reflexivity.
Qed.

Lemma mkLessI_transform_transformI_elem_eq:
  forall (n n': nat) (ns: NatSeg n)
  (i: NatSeg (S n)-> NatSeg (S n'))(j: NatSeg (S n') -> NatSeg (S n))
  (Hypj: natSeg_morph j)(HInv: forall ns: NatSeg (S n), (j (i ns)) ~ ns),
  elem (mkLessI_transform i Hypj HInv ns) =
  elem (transformI i (transfoSNs ns)).
Proof.
  reflexivity.
Qed.

Add Parametric Morphism (n n': nat)(i: NatSeg n -> NatSeg n')
  (j: NatSeg n' -> NatSeg n)(Hypi: natSeg_morph i):
  (transformI (n:= n) (n':= n') i)
  with signature (natSeg_eq (n:= n)) ==> (natSeg_eq (n:= n'))
  as transformIM.
Proof.
  intros x y h.
  unfold natSeg_morph in Hypi.
  destruct n as [|n].
  { no_NatSeg_0 x. }
  destruct n' as [|n'].
  { no_NatSeg_0 (i x). }
  unfold_transformI.
  elim (eq_nat_dec (elem (i x)) n');
   elim (eq_nat_dec (elem (i y)) n'); intros a b ;
   try reflexivity.
  - apply (natSeg_eq_surj Hypi) in h;
      destruct h as [h].
    rewrite b in h.
    symmetry in h.
    contradiction a.
  - apply (natSeg_eq_surj Hypi) in h;
      destruct h as [h].
    rewrite a in h.
    contradiction b.
  - elim (le_lt_eq_dec (elem x) n); elim (le_lt_eq_dec (elem y) n); intros c d.
    + apply (natSeg_eq_surj Hypi) in h;
        destruct h as [h].
      apply (is_natSeg_eq _ _ h).
    + rewrite <- c in d.
      destruct h as [h].
      rewrite h in d.
      apply False_rec; apply (lt_irrefl _ d).
    + rewrite <- d in c.
      destruct h as [h].
      rewrite h in c.
      apply False_rec; apply (lt_irrefl _ c).
    + reflexivity.
Qed.

Lemma transform_bij: forall (n n': nat)(ns ns': NatSeg n)
  (i: NatSeg n -> NatSeg n') (j: NatSeg n' -> NatSeg n)
  (Hypi: natSeg_morph i)(Hypj: natSeg_morph j)
  (Idji: forall ns: NatSeg n, (j (i ns)) ~ ns),
  transformI i ns ~ transformI i ns' <-> ns ~ ns'.
Proof.
  intros n n' ns ns' i j Hypi Hypj Idji.
  unfold natSeg_morph in Hypi; unfold natSeg_morph in Hypj.
  split.
  - destruct n as [|n].
    { no_NatSeg_0 ns. }
    destruct n' as [|n'].
    { no_NatSeg_0 (i ns). }
    unfold_transformI.
    elim (eq_nat_dec (elem (i ns)) n'); elim (eq_nat_dec (elem (i ns')) n');
      intros a b.
    + intro H.
      rewrite <- a in b.
      rewrite elem_bij in b.
      apply (j_i_inj ns ns' i Hypj Idji b).
    + elim (le_lt_eq_dec (elem ns') n ); try (intros c H).
      * apply (j_i_inj (makeNatSeg (lt_n_Sn n)) ns' i Hypj Idji) in H.
        rewrite <- H in c.
        apply False_rec.
        apply (lt_irrefl n c).
      * rewrite (makeNatSeg_ns_natSegeq ns' (lt_n_Sn n)) in c.
        rewrite <- c in H.
        rewrite H in a.
        contradiction a; reflexivity.
    + elim (le_lt_eq_dec (elem ns) n );
        intros c H.
      * apply (j_i_inj ns (makeNatSeg (lt_n_Sn n)) i Hypj Idji) in H.
        rewrite H in c.
        apply False_rec.
        apply (lt_irrefl n c).
      * rewrite (makeNatSeg_ns_natSegeq ns (lt_n_Sn n)) in c.
        rewrite <- c in H.
        rewrite <- H in b.
        contradiction b; reflexivity.
    + elim (le_lt_eq_dec (elem ns) n); elim (le_lt_eq_dec (elem ns') n);
        intros c d H.
      * apply (j_i_inj ns ns' i Hypj Idji H).
      * rewrite H in b.
        contradiction b; reflexivity.
      * rewrite <- H in a.
        contradiction a; reflexivity.
      * apply is_natSeg_eq.
        rewrite c.
        assumption.
  - intros H.
    assert (H1: natSeg_morph (transformI i)).
    { exact (transformIM j Hypi). }
    unfold natSeg_morph in H1.
    rewrite <- H.
    reflexivity.
Qed.

Lemma transform_exist:
  forall (n n': nat)(ns: NatSeg n)(h: elem ns < n)
  (i: NatSeg n -> NatSeg n') (j: NatSeg n' -> NatSeg n)
  (Hypi: natSeg_morph i) (Hypj: natSeg_morph j)
  (Idji: forall ns: NatSeg n, (j (i ns)) ~ ns) ,
  transformI i (exist (fun m : nat => m < n) (elem ns) h) ~ transformI i ns.
Proof.
  intros n n' ns h i j Hypi Hypj Idji.
  rewrite (transform_bij (exist (fun m : nat => m < n) (elem ns) h) ns Hypi Hypj Idji).
  symmetry.
  apply (exist_id3 ns h).
Qed.

Lemma mkLessI_transform_id: forall (n n': nat)
  (i: NatSeg (S n) -> NatSeg (S n')) (j: NatSeg (S n') -> NatSeg (S n))
  (Hypi: natSeg_morph i)(Hypj: natSeg_morph j)
  (Idji: forall ns: NatSeg (S n), (j (i ns)) ~ ns)
  (Idij: forall ns': NatSeg (S n'), (i (j ns')) ~ ns')(ns: NatSeg n),
  mkLessI_transform j Hypi Idij (mkLessI_transform i Hypj Idji ns) ~ ns.
Proof.
  intros n n' i j Hypi Hypj Idji Idij [m h].
  unfold natSeg_morph in Hypi.
  unfold natSeg_morph in Hypj.
  assert (HMi: natSeg_morph (transformI i)).
  { exact (transformIM j Hypi). }
  unfold natSeg_morph in HMi.
  assert (HMj: natSeg_morph (transformI j)).
  { exact (transformIM i Hypj). }
  unfold natSeg_morph in HMj.
  apply is_natSeg_eq.
  rewrite mkLessI_transform_transformI_elem_eq.
  assert (H: (exist (fun m : nat => m < S n')
    (elem (transformI i (exist (fun m : nat => m < S n) m (lt_S m n h))))
    (lt_S (elem
    (transformI i (exist (fun m : nat => m < S n) m (lt_S m n h)))) n'
    (transformI_lt_n (exist (fun m : nat => m < S n) m (lt_S m n h)) i
    Hypj Idji h))) ~
    (transformI i (exist (fun m : nat => m < S n) m (lt_S m n h)))).
  { apply is_natSeg_eq.
    reflexivity. }
  rewrite H.
  apply (makeNatSeg_ns_natSegeq (transformI j
    (transformI i (exist (fun m : nat => m < S n) m (lt_S m n h))))
    (lt_S m n h)).
  apply (transform_Id Hypi Hypj Idji Idij).
Qed.

Add Parametric Morphism (n n': nat)(i: NatSeg (S n) -> NatSeg (S n'))
  (j: NatSeg (S n') -> NatSeg (S n))
  (Hypi: natSeg_morph i)(Hypj: natSeg_morph j)
  (Idji: (forall ns: NatSeg (S n), (j (i ns)) ~ ns)):
  (mkLessI_transform (n:= n) (n':= n') i Hypj Idji)
  with signature (natSeg_eq (n:= n)) ==> (natSeg_eq (n:= n'))
  as mkLessI_transformM.
Proof.
  intros x y H.
  unfold mkLessI_transform.
  assert (HMi: natSeg_morph (transformI i)).
  { exact (transformIM j Hypi). }
  unfold natSeg_morph in HMi.
  unfold natSeg_morph in Hypi.
  apply is_natSeg_eq.
  change (elem (transformI i (transfoSNs x)) =
    (elem (transformI i (transfoSNs y)))).
  rewrite H.
  reflexivity.
Qed.

(* We show that if there is a bijection between NatSeg n and NatSeg n', then
   n <= n' *)
Definition NatSeg_inj_aux: forall (n n':nat)
  (i: NatSeg n -> NatSeg n')(j: NatSeg n' -> NatSeg n)
  (Hypi:natSeg_morph i)
  (Hypj:natSeg_morph j),
  (forall ns: NatSeg n, j ( i ns) ~ ns) ->
  (forall ns': NatSeg n', i ( j ns') ~ ns') -> n <= n'.
Proof.
  induction n as [|n IHn]; destruct n' as [|n'];
  intros i j Hypi Hypj Idji Idij;
  unfold natSeg_morph in Hypi ; unfold natSeg_morph in Hypj.
  - apply le_refl.
  - apply le_O_n.
  - apply False_rec.
    apply (NatSeg_0_empty (i (makeNatSeg (lt_n_Sn n)))).
  - apply (le_n_S n n').
    set (Hypi':= mkLessI_transformM Hypi Hypj Idji ).
    set (Hypj':= mkLessI_transformM Hypj Hypi Idij).
    apply (IHn n' (mkLessI_transform i Hypj Idji) (mkLessI_transform j Hypi Idij)
      Hypi' Hypj' (mkLessI_transform_id Hypi Hypj Idji Idij)
      (mkLessI_transform_id Hypj Hypi Idij Idji)).
Defined.

(* Finally, we show that if there is a bijection between NatSeg n
   and NatSeg n', then n = n' *)
Definition NatSeg_inj: forall (n n':nat)
  (i: NatSeg n -> NatSeg n')(j: NatSeg n' -> NatSeg n)
  (Hypi:natSeg_morph i)
  (Hypj:natSeg_morph j),
  (forall ns: NatSeg n, j ( i ns) ~ ns) ->
  (forall ns': NatSeg n', i ( j ns') ~ ns') -> n = n'.
Proof.
  intros n n' i j Hypi Hypj Idji Idij.
  apply (le_antisym n n'
    (NatSeg_inj_aux Hypi Hypj Idji Idij) (NatSeg_inj_aux Hypj Hypi Idij Idji)).
Defined.


Require Import List Omega Wellfounded Extraction.

Definition app_split { X : Type } (l1 l2 r1 r2 : list X) :
   l1++r1 = l2++r2 -> (exists m, l2 = l1++m /\ r1 = m++r2)
                   \/ (exists m, l1 = l2++m /\ r2 = m++r1).
Proof.
  revert l2 r1 r2.
  induction l1 as [ | x l1 Hl1 ].
  left; exists l2; auto.
  intros [ | y l2 ] r1 r2 H.
  right; exists (x::l1); auto.
  simpl in H; injection H; clear H; intros H ?; subst.
  apply Hl1 in H.
  destruct H as [ (m & H1 & H2) | (m & H1 & H2) ].
  left; exists m; subst; auto.
  right; exists m; subst; auto.
Qed.

Section measure_ind.

  Variable (X : Type) (m : X -> nat) (P : X -> Type)
           (HP : forall x, (forall y, m y < m x -> P y) -> P x).

  Let R x y := m x < m y.

  Theorem measure_rect x : P x.
  Proof.
    cut (Acc R x).
    + revert x.
      exact (fix loop x Hx { struct Hx } := HP x (fun y Hy => loop y (Acc_inv Hx Hy))).
    + unfold R; apply wf_inverse_image, lt_wf.
  Qed.

End measure_ind.

Section measure_double_ind.

  Variable (X Y : Type) (m : X -> Y -> nat) (P : X -> Y -> Type)
           (HP : forall x y, (forall x' y', m x' y' < m x y -> P x' y') -> P x y).

  Let R c d := m (fst c) (snd c) < m (fst d) (snd d).

  Theorem measure_double_rect x y : P x y.
  Proof.
    cut (Acc R (x,y)).
    + revert x y.
      refine (fix loop x y H { struct H } := HP x y (fun x' y' H' => loop x' y' (Acc_inv H _))).
      apply H'.
    + unfold R; apply wf_inverse_image, lt_wf.
  Qed.

End measure_double_ind.

Extraction Inline measure_double_rect.
Extraction Inline measure_rect.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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.
Lemma lem : forall (x : lst) (y : natural), eq (rev (append x (Cons y Nil))) (Cons y (rev x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst) (z : natural), eq (rev (append x (append y (Cons z Nil)))) (Cons z (rev (append x y))).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. simpl. lfind. Admitted.


Require Import Cbase Cabs Carg Ccoj.

Local Open Scope R_scope.

Local Close Scope R_scope.

Definition argminus ( x : R ) ( y : R ) := x +^ -^ y.

Infix " -^ " := argminus ( at level 20 ).

Lemma argnegineq : forall x : R , (-PI < x <= PI)%R -> (-PI < ( -^ x ) <= PI)%R.
Proof.
  intros.
  unfold argneg.
  destruct ( Real_eq_dec x PI ).
  split.
  ring_simplify.
  replace PI with ( 1 * PI )%R ; [idtac|ring].
  rewrite Ropp_mult_distr_l.
  apply Rmult_lt_compat_r.
  apply PI_RGT_0.
  apply Rplus_lt_reg_r  with (r := (1)%R ).
  ring_simplify.
  auto with real.
  auto with real.
  destruct H.
  case H0.
  intros.
  split.
  auto with real.
  left.
  apply Ropp_lt_cancel.
  ring_simplify.
  auto.
  intros.
  contradiction.
Qed.

Lemma argminusineq : forall x y : R , (-PI < x <= PI)%R -> (-PI < y <= PI)%R -> (-PI < ( x -^ y ) <= PI)%R.
Proof.
  intros.
  unfold argminus.
  apply argplusineq.
  auto.
  apply argnegineq.
  auto.
Qed.

Lemma argnegcos : forall x : R , cos ( -^ x ) = cos ( - x )%R.
Proof.
  intros.
  unfold argneg.
  destruct ( Real_eq_dec x PI ).
  rewrite cos_neg.
  rewrite e.
  auto.
  auto.
Qed.

Lemma argnegsin : forall x : R , sin ( -^ x ) = sin ( - x )%R.
Proof.
  intros.
  unfold argneg.
  destruct ( Real_eq_dec x PI ).
  rewrite sin_neg.
  rewrite e.
  rewrite sin_PI.
  ring.
  auto.
Qed.

Lemma argminuscos : forall x y : R , cos ( x -^ y ) = cos ( x - y )%R.
Proof.
  intros.
  unfold argminus.
  rewrite argpluscos.
  rewrite cos_plus.
  rewrite argnegcos.
  rewrite argnegsin.
  unfold Rminus.
  rewrite cos_plus.
  ring.
Qed.

Lemma Ceq_side : forall a b : Complex , (a - b)%C = C0 -> a = b.
Proof.
  intros.
  unfold Cminus in H.
  unfold C0 in H.
  apply eq_sym in H.
  rewrite Cdecompose with ( z := b ) in H.
  unfold Copp in H.
  rewrite Cplus_decompose in H.
  simpl in H.
  apply injective_projections.
  apply eq_sym.
  apply Rminus_diag_uniq_sym.
  replace (fst a - fst b)%R with ( fst ((real_p a + - real_p b)%R, (imag_p a + - imag_p b)%R) ).
  rewrite <- H.
  auto.
  auto.
  apply eq_sym.
  apply Rminus_diag_uniq_sym.
  replace (snd a - snd b)%R with ( snd ((real_p a + - real_p b)%R, (imag_p a + - imag_p b)%R) ).
  rewrite <- H.
  auto.
  auto.
Qed.

Lemma Ceq_side2 : forall a b : Complex , a = b -> ( a - b )%C=C0.
Proof.
  intros.
  rewrite H.
  unfold C0.
  rewrite Cdecompose with ( z:=b).
  unfold Cminus.
  unfold Copp.
  rewrite Cplus_decompose.
  simpl.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
Qed.

Check field_theory.

Lemma complexSFth : field_theory C0 C1 Cplus Cmult Cminus Copp Cdiv Cinv (@eq Complex).
Proof.
  constructor. exact complexSRth.
  exact C1_neq_C0.
  unfold Cdiv.
  auto.
  apply Cinv_l.
Qed.

Add Field complexf : complexSFth.

Lemma CinvnC0 : forall a : Complex , a <> C0 -> (/ a)%C <> C0.
Proof.
  intros.
  unfold not.
  intros.
  assert ( a / a = a * C0 )%C.
  unfold Cdiv.
  rewrite H0.
  auto.
  field_simplify in H1.
  replace (C1 / C1)%C with C1 in H1; [ idtac | field ].
  apply C1_neq_C0.
  rewrite H1.
  replace (R0,R0) with C0.
  field.
  apply C1_neq_C0.
  auto.
  apply C1_neq_C0.
  contradiction.
Qed.

Lemma Cabs2 : forall z : Complex , ((Cabs z)^2 = real_p z * real_p z + imag_p z * imag_p z )%R.
Proof.
  intros.
  unfold Cabs.
  simpl.
  rewrite <- Rmult_assoc.
  rewrite sqrt_def.
  ring.
  apply Ra2b2pos.
Qed.

Lemma Cosine_rule_intro : forall a b : Complex , ( ((real_p a + real_p b) * (real_p a + real_p b) +
   (imag_p a + imag_p b) * (imag_p a + imag_p b))%R = (real_p a * real_p a + imag_p a * imag_p a +
   (real_p b * real_p b + imag_p b * imag_p b) +
   2 * Cabs a * Cabs b *
   (cos (Carg a) * cos (Carg b) + sin (Carg a) * sin (Carg b)) ))%R.
Proof.
  intros.
  ring_simplify.
  replace ( 2 * Cabs a * Cabs b * cos (Carg a) * cos (Carg b) )%R
  with ( 2 * (Cabs a * cos (Carg a)) * (Cabs b * cos (Carg b) ) )%R ; [ idtac | ring ].
  rewrite <- ! Creal_arg.
  replace ( 2 * Cabs a * Cabs b * sin (Carg a) * sin (Carg b) )%R with
  ( 2 * (Cabs a * sin (Carg a)) * (Cabs b * sin (Carg b)) )%R ; [ idtac | ring ].
  rewrite <- ! Cimag_arg.
  ring.
Qed.

Lemma Cosine_rule_pos : forall a c : Complex , (0%R <= Cabs a ^ 2 + Cabs c ^ 2 + 2 * Cabs a * Cabs c * cos (Carg a - Carg c))%R.
Proof.
  intros.
  rewrite ! Cabs2.
  rewrite cos_minus.
  rewrite <- Cosine_rule_intro.
  apply Ra2b2pos.
Qed.

Theorem Cosine_rule : forall a b : Complex , Cabs (a+b)%C = sqrt ( (Cabs a)^2 + (Cabs b)^2 + 2*(Cabs a)*(Cabs b)*cos(Carg a - Carg b) )%R.
Proof.
  intros.
  rewrite ! Cabs2.
  rewrite Cplus_decompose.
  rewrite cos_minus.
  assert ( ((real_p a + real_p b) * (real_p a + real_p b) +
   (imag_p a + imag_p b) * (imag_p a + imag_p b))%R = (real_p a * real_p a + imag_p a * imag_p a +
   (real_p b * real_p b + imag_p b * imag_p b) +
   2 * Cabs a * Cabs b *
   (cos (Carg a) * cos (Carg b) + sin (Carg a) * sin (Carg b)) ))%R.
  apply Cosine_rule_intro.
  rewrite <- H.
  unfold Cabs.
  auto.
Qed.

Theorem Cabs_sum_eq : forall a b c d : Complex , a <> C0 -> c <> C0 -> Cabs a = Cabs b -> Cabs c = Cabs d -> Cabs (a+c)%C = Cabs (b+d)%C -> Rabs ( Carg a -^ Carg c )%R = Rabs ( Carg b -^ Carg d )%R.
Proof.
  intros a b c d an0 cn0.
  intros.
  rewrite Cosine_rule in H1.
  rewrite Cosine_rule in H1.
  apply sqrt_inj in H1.
  rewrite <- H in H1.
  rewrite <- H0 in H1.
  apply Rminus_diag_eq in H1.
  ring_simplify in H1.
  apply Rminus_diag_uniq_sym in H1.
  apply coseq.
  apply argminusineq.
  apply Carg_def.
  apply Carg_def.
  apply argminusineq.
  apply Carg_def.
  apply Carg_def.
  rewrite ! argminuscos.
  apply Rmult_eq_reg_l in H1.
  auto.
  unfold not.
  intros.
  Search ( _ * _ = 0 )%R.
  apply Rmult_integral in H2.
  case H2.
  intros.
  apply Rmult_integral in H3.
  case H3.
  intros.
  assert ( 2 <> 0 )%R.
  auto with real.
  contradiction.
  intros.
  apply Cabs0z0 in H4.
  contradiction.
  intros.
  apply Cabs0z0 in H3.
  contradiction.
  apply Cosine_rule_pos.
  apply Cosine_rule_pos.
Qed.


Require Export Basics.

(** * Naming Cases *)

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1 : forall b c : bool,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".  (* <----- here *)
    reflexivity.
  Case "b = false".  (* <---- and here *)
    rewrite <- H.
    reflexivity.
Qed.

(** **** Exercise: 2 stars (andb_true_elim2) *)
(** Prove [andb_true_elim2], marking cases (and subcases) when
    you use [destruct]. *)

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

(** * Proof by Induction *)

Theorem plus_0_r : forall n : nat, n + 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".     reflexivity.
  Case "n = S n'".  simpl. rewrite -> IHn'. reflexivity.  Qed.

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. reflexivity.  Qed.

(** **** Exercise: 2 stars (basic_induction) *)

(** Prove the following lemmas using induction. You might need
    previously proven results. *)

Theorem mult_0_r : forall n : nat,
  n * 0 = 0.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. reflexivity. Qed.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  intros n m. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. reflexivity. Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m. induction n as [| n'].
  Case "n = 0".
    rewrite -> plus_O_n.
    rewrite -> plus_0_r. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'.
    rewrite -> plus_n_Sm. reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. reflexivity.
Qed.

(** **** Exercise: 2 stars (double_plus) *)

(** Consider the following function, which doubles its argument: *)

Fixpoint double (n : nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

(** Use induction to prove this simple fact about [double]: *)

Lemma double_plus : forall n, double n = n + n .
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = n'".
    simpl. rewrite -> IHn'.
    rewrite -> plus_n_Sm. reflexivity.
Qed.

(** **** Exercise: 1 star (destruct_induction) *)
(** Briefly explain the difference between the tactics
    [destruct] and [induction].

 (* blah blah *)

*)

(** * Proofs Within Proofs *)

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
    Case "Proof of assertion".
    rewrite -> plus_comm. reflexivity.
  rewrite -> H. reflexivity.  Qed.

(** **** Exercise: 4 stars (mult_comm) *)
(** Use [assert] to help prove this theorem.  You shouldn't need to
    use induction. *)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  rewrite -> plus_assoc.
  assert (H1: n + m = m + n).
    Case "Proof of assertion H1".
    rewrite -> plus_comm. reflexivity.
  rewrite -> H1.
  rewrite <- plus_assoc. reflexivity.
Qed.

(** Now prove commutativity of multiplication.  (You will probably
    need to define and prove a separate subsidiary theorem to be used
    in the proof of this one.)  You may find that [plus_swap] comes in
    handy. *)

Lemma mult_n_Sm : forall n m : nat,
  n * (S m) = n + n * m.
Proof.
  intros n m. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'.
    rewrite -> plus_swap. reflexivity.
Qed.

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  intros m n. induction m as [| m'].
  Case "m = 0".
    rewrite -> mult_0_r.
    rewrite -> mult_0_l. reflexivity.
  Case "m = S m'".
    simpl. rewrite -> IHm'.
    rewrite -> mult_n_Sm. reflexivity.
Qed.

(** **** Exercise: 2 stars, optional (evenb_n__oddb_Sn) *)

(** Prove the following simple fact: *)

Fact evenb_n__evenb_SSn : forall n : nat,
  evenb n = evenb (S (S n)).
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem evenb_n__oddb_Sn : forall n : nat,
  evenb n = negb (evenb (S n)).
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    rewrite <- evenb_n__evenb_SSn.
    rewrite -> IHn'.
    rewrite -> negb_involutive. reflexivity.
Qed.

(** * More Exercises *)

(** **** Exercise: 3 stars, optional (more_exercises) *)
(** Take a piece of paper.  For each of the following theorems, first
    _think_ about whether (a) it can be proved using only
    simplification and rewriting, (b) it also requires case
    analysis ([destruct]), or (c) it also requires induction.  Write
    down your prediction.  Then fill in the proof.  (There is no need
    to turn in your piece of paper; this is just to encourage you to
    reflect before hacking!) *)

Theorem ble_nat_refl : forall n : nat,
  true = ble_nat n n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
  simpl. rewrite <- IHn'. reflexivity. Qed.

Theorem zero_nbeq_S : forall n:nat,
  beq_nat 0 (S n) = false.
Proof.
  simpl. reflexivity. Qed.

Theorem andb_false_r : forall b : bool,
  andb b false = false.
Proof.
  intros b. destruct b.
  Case "b = true".
    simpl. reflexivity.
  Case "b = false".
    simpl. reflexivity. Qed.

Theorem plus_ble_compat_l : forall n m p : nat,
  ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
  intros n m p. intros H.
  induction p as [| p'].
  Case "p = 0".
  simpl. rewrite -> H. reflexivity.
  Case "p = S p'".
  simpl. rewrite -> IHp'. reflexivity. Qed.

Theorem S_nbeq_0 : forall n : nat,
  beq_nat (S n) 0 = false.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem mult_1_l : forall n : nat, 1 * n = n.
Proof.
  intros n.
  simpl. rewrite -> plus_0_r. reflexivity. Qed.

Theorem all3_spec : forall b c : bool,
  orb
    (andb b c)
    (orb (negb b)
         (negb c))
  = true.
Proof.
  intros b c. destruct b, c.
  Case "b = true".
    SCase "c = true".
      simpl. reflexivity.
    SCase "c = false".
      simpl. reflexivity.
  Case "b = false".
    SCase "c = true".
      simpl. reflexivity.
    SCase "c = false".
      simpl. reflexivity. Qed.

Theorem mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  intros n m p. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. rewrite -> plus_assoc. reflexivity.
Qed.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  intros n m p. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'.
    rewrite -> mult_plus_distr_r. reflexivity.
Qed.

(** **** Exercise: 2 stars, optional (beq_nat_refl) *)
(** Prove the following theorem.  Putting [true] on the left-hand side
of the equality may seem odd, but this is how the theorem is stated in
the standard library, so we follow suit.  Since rewriting
works equally well in either direction, we will have no
problem using the theorem no matter which way we state it. *)

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
  simpl. reflexivity.
  Case "n = S n'".
  simpl. rewrite <- IHn'. reflexivity. Qed.

(** **** Exercise: 2 stars, optional (plus_swap') *)
(** The [replace] tactic allows you to specify a particular subterm to
   rewrite and what you want it rewritten to.  More precisely,
   [replace (t) with (u)] replaces (all copies of) expression [t] in
   the goal by expression [u], and generates [t = u] as an additional
   subgoal. This is often useful when a plain [rewrite] acts on the wrong
   part of the goal.

   Use the [replace] tactic to do a proof of [plus_swap'], just like
   [plus_swap] but without needing [assert (n + m = m + n)].
*)

Theorem plus_swap' : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  rewrite -> plus_assoc. rewrite -> plus_assoc.
  replace (n + m) with (m + n).
  reflexivity.
  rewrite -> plus_comm. reflexivity. Qed.
(** [] *)

(** **** Exercise: 3 stars (binary_commute) *)
(** Recall the [increment] and [binary-to-unary] functions that you
    wrote for the [binary] exercise in the [Basics] chapter.  Prove
    that these functions commute -- that is, incrementing a binary
    number and then converting it to unary yields the same result as
    first converting it to unary and then incrementing.

    (Before you start working on this exercise, please copy the
    definitions from your solution to the [binary] exercise here so
    that this file can be graded on its own.  If you find yourself
    wanting to change your original definitions to make the property
    easier to prove, feel free to do so.) *)

(* TODO *)
(** [] *)

(** **** Exercise: 5 stars, advanced (binary_inverse) *)
(** This exercise is a continuation of the previous exercise about
    binary numbers.  You will need your definitions and theorems from
    the previous exercise to complete this one.

    (a) First, write a function to convert natural numbers to binary
        numbers.  Then prove that starting with any natural number,
        converting to binary, then converting back yields the same
        natural number you started with.

    (b) You might naturally think that we should also prove the
        opposite direction: that starting with a binary number,
        converting to a natural, and then back to binary yields the
        same number we started with.  However, it is not true!
        Explain what the problem is.

    (c) Define a function [normalize] from binary numbers to binary
        numbers such that for any binary number b, converting to a
        natural and then back to binary yields [(normalize b)].  Prove
        it.

    Again, feel free to change your earlier definitions if this helps
    here.
*)

(* TODO *)
(** [] *)

(** * Advanced Material *)

(** ** Formal vs. Informal Proof *)

(** **** Exercise: 2 stars, advanced (plus_comm_informal) *)
(** Translate your solution for [plus_comm] into an informal proof. *)

(** Theorem: Addition is commutative.
  Proof.
  We show n + m = m + n for any natural numbers n and m, by induction on [n].
  First, suppose n = 0. We must show
    0 + m = m + 0.
  This follows directly from the definition of +.

  Next, suppose n = S n', where
    n' + m = m + n'.
  We must show
    S n' + m = m + S n'.
  By the definition of + and the induction hypothesis,
  the left-hand side of the equation can be transform as
    S n' + m = S (n' + m) = S (m + n').
  By the theorem plus_n_Sm we can say S (n + m) = n + S m.
  Thus S n' + m = m + S n'.
[]
*)

(** **** Exercise: 2 stars, optional (beq_nat_refl_informal) *)
(** Write an informal proof of the following theorem, using the
    informal proof of [plus_assoc] as a model.  Don't just
    paraphrase the Coq tactics into English!

    Theorem: [true = beq_nat n n] for any [n].

    Proof: (* blah blah *)
[]
 *)


Require Import util syntax.

(* Read ω ∈* Ω as ω ∈ Ω* *)
Reserved Notation " ω ∈* Ω " (at level 40).
Inductive cclo (Ω : Ω) : ω → Prop :=
  | trivial : ∀ ω, ω ∈ Ω → ω ∈* Ω
  | sub_refl : ∀ r, subr r r ∈* Ω
  | sub_trans : ∀ ri rj rk, subr ri rj ∈* Ω → subr rj rk ∈* Ω  →
                                  subr ri rk ∈* Ω
  | dis_sub : ∀ ri rj rk, subr ri rj ∈* Ω → disj rj rk ∈*  Ω →
                                  disj ri rk ∈* Ω
  | dis_comm : ∀ ri rj, disj ri rj ∈* Ω → disj rj ri ∈* Ω
where " ω ∈* Ω " := (cclo Ω ω).

Definition resp (M : M) (elem : Ω → ω → Prop) (Ω : Ω) :=
  (∀ r1 r2, elem Ω (subr r1 r2) → lu r1 M ⊆ lu r2 M)
                              ∧
  (∀ r1 r2, elem Ω (disj r1 r2) → lu r1 M ∩ lu r2 M = [])
.

(* Read M ~* Ω as M ~ Ω* *)
Notation " M ~ Ω " := (resp M (λ Ω ω, In ω Ω) Ω) (at level 40).
Notation " M ~* Ω " := (resp M cclo Ω) (at level 40).

Lemma resp_clos_sub : ∀ r1 r2 Ω (M:M),
  (∀ r1 r2, subr r1 r2 ∈ Ω → lu r1 M ⊆ lu r2 M) →
           subr r1 r2 ∈* Ω → lu r1 M ⊆ lu r2 M.
intros. prep_induction H0. induction H0; intros; subst. apply H0. assumption.
inversion H2. subst. clear H2. apply subset_refl. inversion H2. subst. clear H2.
specialize (IHcclo2 _ _ _ H eq_refl).  specialize (IHcclo1 _ _ _ H eq_refl).
apply (subset_trans _ _ _ IHcclo1 IHcclo2). inversion H2. inversion H2. Qed.

(* Lemma 6 from the oopsla13 paper *)
Lemma resp_clos : ∀ M Ω, M ~ Ω ↔ M ~* Ω.
intros. split; intros; split; intros; destruct H. apply resp_clos_sub with
(Ω := Ω). assumption. assumption. prep_induction H0. induction
H0; intros; subst. apply H1. assumption. inversion H3. subst. inversion H3.
inversion H3. subst. clear H3.  specialize (IHcclo2 _ H H1 _ _ eq_refl). apply
resp_clos_sub with (M:=M) in H0_. apply subset_intersection with (zs:=lu r2
M) in H0_.  rewrite IHcclo2 in H0_. apply subset_nil_nil in H0_. assumption.
assumption. inversion H3. subst. clear H3. specialize (IHcclo _ H H1 _ _ eq_refl).
apply subset_nil_nil. apply subset_trans with (ys:=lu r2 M ∩ lu r1 M). apply
intersection_comm. rewrite IHcclo. apply subset_refl. apply H. apply trivial.
assumption. apply H1. apply trivial. assumption. Qed.


Definition eqb (b1 b2 : bool) : Prop := b1 = b2.
Definition ltb (b1 b2 : bool) : Prop :=
    match (b1, b2) with
        | (false, _) => True
        | (true, true) => True
        | (true, talse) => False
        end.

#[export] Instance ref_eqb : Reflexive eqb.
constructor.
Qed.

#[export] Instance sym_eqb : Symmetric eqb.
intros x y  H.
symmetry.
assumption.
Qed.

#[export] Instance trans_eqb : Transitive eqb.
intros x y z H1 H2.
transitivity y.
assumption.
assumption.
Qed.

#[export] Instance eq_eqb : Equivalence eqb.
constructor.
apply ref_eqb.
apply sym_eqb.
apply trans_eqb.
Qed.

#[export] Instance refl_ltb : Reflexive ltb.
intros x.
unfold ltb.
case_eq x; intros; subst.
trivial.
trivial.
Qed.

#[export] Instance trans_ltb : Transitive ltb.
intros x y z H1 H2.
destruct x,y,z;  trivial.
Qed.

#[export] Instance preo_eqb : PreOrder ltb.
constructor.
apply refl_ltb.
apply trans_ltb.
Qed.

#[export] Instance po : PartialOrder eqb ltb.
constructor.
-   unfold eqb, ltb, Basics.flip.
    split; destruct x, x0; solve [trivial | discriminate].
-   unfold eqb, ltb, Basics.flip.
    intros [H1 H2].
    destruct x, x0; intuition.
Qed.

Definition joinb (b1 b2 : bool) : bool :=
    match (b1, b2) with
        | (false, false) => false
        | (_, _) => true
        end.

#[global] Instance jl : JoinLattice eqb ltb joinb.
constructor.
-   intros; unfold ltb, joinb.
    destruct x, y; trivial.
-   intros; unfold ltb, joinb.
    destruct x, y; trivial.
- intros; unfold ltb, joinb.
    destruct x, y, z; trivial.
Defined.

Lemma a : forall b1 b2 : bool, ltb b1 (joinb b1 b2).
Proof.
    intros.
    apply join_bound1.
Qed.


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

(*
  Problem(s):
    Provability in Hilbert-style calculi (HSC_PRV)
    Recognizing axiomatizations of Hilbert-style calculi (HSC_AX)

  HSC_PRV:
    Fix a list s₁,...,sₙ of formulae.
    Given a formula s, is [s₁,...,sₙ] ⊢ s derivable?

  HSC_AX:
    Given a list s₁,...,sₙ of formulae such that
    [a → b → a] ⊢ sᵢ is derivable for i = 1...n,
    is [s₁,...,sₙ] ⊢ a → b → a derivable?

  References:
    [1] Grigoriy V. Bokov: Undecidable problems for propositional calculi with implication.
      Logic Journal of the IGPL, 24(5):792–806, 2016. doi:10.1093/jigpal/jzw013
    [2] Andrej Dudenhefner, Jakob Rehof: Lower End of the Linial-Post Spectrum.
      TYPES 2017: 2:1-2:15. doi: 10.4230/LIPIcs.TYPES.2017.2
*)

Require Import List.
Import ListNotations.

(* propositional formulae s, t ::= a | s → t *)
Inductive formula : Set :=
  | var : nat -> formula
  | arr : formula -> formula -> formula.

(* substitute ζ t replaces each variable n in t by ζ n *)
Fixpoint substitute (ζ: nat -> formula) (t: formula) : formula :=
  match t with
  | var n => ζ n
  | arr s t => arr (substitute ζ s) (substitute ζ t)
  end.

(* Hilbert-style calculus *)
Inductive hsc (Gamma: list formula) : formula -> Prop :=
  | hsc_var : forall (ζ: nat -> formula) (t: formula), In t Gamma -> hsc Gamma (substitute ζ t)
  | hsc_arr : forall (s t : formula), hsc Gamma (arr s t) -> hsc Gamma s -> hsc Gamma t.

(* is the formula s derivable from the fixed list of formulae Gamma? *)
Definition HSC_PRV (Gamma: list formula) (s: formula) := hsc Gamma s.

(* the formula a → b → a *)
Definition a_b_a : formula := arr (var 0) (arr (var 1) (var 0)).

(* list of formulae derivable from a → b → a *)
Definition HSC_AX_PROBLEM := { Gamma: list formula | forall s, In s Gamma -> hsc [a_b_a] s}.

(* is the formula a → b → a derivable? *)
Definition HSC_AX (l: HSC_AX_PROBLEM) := hsc (proj1_sig l) a_b_a.


(* -*- mode: coq; mode: visual-line -*- *)
(** * Theorems about dependent products *)

Require Import HoTT.Basics.
Require Import Types.Paths.

Local Open Scope path_scope.

Generalizable Variables A B f g e n.

Section AssumeFunext.
  Context `{Funext}.

  (** ** Composition *)
  Lemma path_forall_precompose (A B C:Type) (f:A -> B) (g h:B -> C) (eq:forall x, g x = h x)
: ap (fun u => u o f) (path_forall g h eq) = path_forall (g o f) (h o f) (fun x => (eq (f x))).
  apply (@equiv_inj _ _ _ (isequiv_apD10 _ _ _ _)).
  unfold path_forall at 2; rewrite eisretr.
  apply path_forall; intro a.
  pose (r:= @ap10_ap_precompose); unfold ap10 in r; rewrite r; clear r.
  unfold path_forall; rewrite eisretr. reflexivity.
  Qed.

  Lemma ap_path_forall_postcompose (A B C:Type) (f:B -> C) (g h:A -> B) (eq:forall x, g x = h x)
: ap (fun u => f o u) (path_forall g h eq) = path_forall (f o g) (f o h) (fun x => ap f (eq x)).
  apply (@equiv_inj _ _ _ (isequiv_apD10 _ _ _ _)).
  unfold path_forall at 2; rewrite eisretr.
  apply path_forall; intro a.
  pose (r:= @ap10_ap_postcompose); unfold ap10 in r; rewrite r; clear r.
  unfold path_forall; rewrite eisretr. reflexivity.
Qed.
End AssumeFunext.


From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.

(* Minimal separation logic **)

(* Syntax **)

Definition sp_term := option nat.

Inductive msp_form :=
| mpointer : sp_term -> sp_term -> sp_term -> msp_form (* weak binary pointer *)
| mbot : msp_form
| mimp : msp_form -> msp_form -> msp_form
| mand : msp_form -> msp_form -> msp_form
| mor : msp_form -> msp_form -> msp_form
| mall : msp_form -> msp_form
| mex : msp_form -> msp_form.

(* Semantics **)

Definition val := option nat.
Definition stack := nat -> val.
Definition heap := list (nat * (val * val)).

Definition sp_eval (s : stack) (t : sp_term) : val :=
  match t with Some x => s x | None => None end.

Definition update_stack (s : stack) v :=
  fun x => match x with 0 => v | S x => s x end.

Fixpoint msp_sat (s : stack) (h : heap) (P : msp_form) :=
  match P with
  | mpointer E E1 E2 => exists l, sp_eval s E = Some l /\ (l, (sp_eval s E1, sp_eval s E2)) el h
  | mbot => False
  | mimp P1 P2 => msp_sat s h P1 -> msp_sat s h P2
  | mand P1 P2 => msp_sat s h P1 /\ msp_sat s h P2
  | mor P1 P2 => msp_sat s h P1 \/ msp_sat s h P2
  | mall P => forall v, msp_sat (update_stack s v) h P
  | mex P => exists v, msp_sat (update_stack s v) h P
  end.

(* Satisfiability problem **)

Definition functional (h : heap) :=
  forall l p p', (l, p) el h -> (l, p') el h -> p = p'.

Definition MSLSAT (P : msp_form) :=
  exists s h, functional h /\ msp_sat s h P.


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.theory.fields.
Require Export
  HoTT.Classes.orders.rings.

Generalizable Variables F f R Fle Flt.

Section contents.
Context `{OrderedField F}.

Lemma pos_recip_compat (x : F) (Px : 0 < x) : 0 < //(x;positive_apart_zero x Px).
Proof.
apply (strictly_order_reflecting (x *.)).
rewrite mult_0_r.
rewrite (recip_inverse' x).
apply lt_0_1.
Qed.

Lemma neg_recip_compat (x : F) (Px : x < 0) : //(x;negative_apart_zero x Px) < 0.
Proof.
  set (negxpos := fst (flip_neg_negate x) Px).
  apply (strictly_order_reflecting ((-x) *.)).
  rewrite mult_0_r.
  rewrite <- negate_mult_distr_l.
  rewrite (recip_inverse' x).
  apply flip_pos_negate, lt_0_1.
Qed.

Lemma flip_lt_recip x y (Py : 0 < y) (ltyx : y < x) :
  let apy0 := positive_apart_zero y Py in
  let apx0 := positive_apart_zero x (transitivity Py ltyx) in
  //(x;apx0) < //(y;apy0).
Proof.
  assert (0 < x) by (transitivity y;trivial).
  apply (strictly_order_reflecting (x *.)).
  rewrite (recip_inverse' x ).
  rewrite mult_comm.
  apply (strictly_order_reflecting (y *.)).
  rewrite mult_assoc, mult_1_r.
  rewrite (recip_inverse' y), mult_1_l; assumption.
Qed.

Lemma flip_lt_recip_l x y (Py : 0 < y) (ltyx : //(y;positive_apart_zero y Py) < x) :
  let apx0 := positive_apart_zero x (transitivity (pos_recip_compat y Py) ltyx) in
  //(x;apx0) < y.
Proof.
  set (apy0 := positive_apart_zero y Py).
  set (eq := recip_involutive (y;apy0)).
  set (eq' := ap pr1 eq).
  cbn in eq'.
  rewrite <- eq'.
  unfold recip_on_apart.
  (* need : // (y; apy0) < x *)
  (* have : //(y;pseudo_order_lt_apart_flip 0 y Py) < x *)
  set (ltyx2 := ltyx).
  unfold ltyx2.
  rewrite (recip_irrelevant y (positive_apart_zero y Py) apy0) in ltyx2.
  set (ltyx_recips := flip_lt_recip x (// (y; apy0)) (pos_recip_compat y Py) ltyx2).
  cbn in ltyx_recips.
  rewrite (recip_irrelevant x _ (positive_apart_zero x (transitivity (pos_recip_compat y Py) ltyx))) in ltyx_recips.
  cbn.
  rewrite (recip_irrelevant (//(y;apy0)) _ (recip_apart y apy0)) in ltyx_recips.
  assumption.
Qed.
Lemma flip_lt_recip_r (x y : F) (Px : 0 < x) (Py : 0 < y) (ltyx : y < //(x;positive_apart_zero x Px)) :
  x < //(y;positive_apart_zero y Py).
Proof.
  set (apx0 := positive_apart_zero x Px).
  set (apy0 := positive_apart_zero y Py).
  change x with ((x;apx0) : ApartZero F).1.
  rewrite <- (recip_involutive (x;apx0)).
  unfold recip_on_apart; cbn.
  assert (ltry := pos_recip_compat y Py).
  rewrite (recip_irrelevant y (positive_apart_zero y Py) apy0) in ltry.
  change y with ((y;apy0) : ApartZero F).1 in ltyx.
  rewrite <- (recip_involutive (y;apy0)) in ltyx.
  unfold recip_on_apart in ltyx; cbn in ltyx.
  rewrite (recip_irrelevant (//(y;apy0)) (recip_apart y apy0) (positive_apart_zero (// (y; apy0)) ltry)) in ltyx.
  assert (ltxy := flip_lt_recip_l (// (x; apx0)) (// (y; apy0)) ltry ltyx).
  cbn in ltxy.
  rewrite (recip_irrelevant (//(x;apx0)) (positive_apart_zero (// (x; apx0)) (transitivity (pos_recip_compat (// (y; apy0)) ltry) ltyx)) (recip_apart x apx0)) in ltxy.
  assumption.
Qed.

Lemma field_split2 (x : F) : (x * recip'  2 (positive_apart_zero 2 lt_0_2)) + (x * recip' 2 (positive_apart_zero 2 lt_0_2)) = x.
Proof.
  rewrite <- plus_mult_distr_l.
  rewrite <- (mult_1_l (recip' 2 (positive_apart_zero 2 lt_0_2))).
  rewrite <- plus_mult_distr_r.
  rewrite (recip_inverse' 2 (positive_apart_zero 2 lt_0_2)).
  rewrite mult_1_r.
  reflexivity.
Qed.
End contents.


(*  Pierre Casteran
    LaBRI, Universit� Bordeaux 1, and Inria Futurs (Logical)

    Yves Bertot (for AcxcElim3 )
*)

Section restricted_recursion.

 Variables (A:Type)(P:A->Prop)(R:A->A->Prop).

 Definition restrict (a b:A):Prop :=
   P a /\ R a b /\ P b.

 Definition well_founded_P := forall (a:A), P a -> Acc restrict a.

 Definition P_well_founded_induction_type :
       well_founded_P  ->
       forall X : A -> Type,
       (forall x : A, P x -> (forall y : A,P y-> R y x -> X y) -> X x) ->
       forall a : A, P a -> X a.
  intros W X H a.
  pattern a; eapply well_founded_induction_type with (R:=restrict).
  unfold well_founded.
  split.
  unfold well_founded_P in W.
  intros; apply W.
 case H0.
 auto.
 intros; apply H.
 auto.
 intros; apply X0.
 unfold restrict; auto.
 auto.
Defined.

End restricted_recursion.

Theorem AccElim3 :
forall A B C:Type,
 forall (RA:A->A->Prop)
        (RB:B->B->Prop)
        (RC:C->C->Prop),
 forall (P : A -> B -> C ->  Prop),
 (forall x y z,
    (forall (t : A), RA t x ->
                     forall y' z', Acc RB y' -> Acc RC z' ->
                                   P t y' z') ->
    (forall (t : B), RB t y ->
                     forall z', Acc RC z' -> P x t z') ->
    (forall (t : C), RC t z -> P x y t) ->
    P x y z) ->
  forall x y z, Acc RA x -> Acc RB y -> Acc RC z -> P x y z.
Proof.
 intros A B C RA RB RC P H x y z Ax; generalize y z; clear y z.
 elim Ax; clear Ax x; intros x _ Hrecx y z Ay; generalize z; clear z.
 elim Ay; clear Ay y;
 intros y _ Hrecy z Az; elim Az; clear Az z; auto.
Qed.

Theorem accElim3:
 forall (A B C:Set)(RA : A -> A ->Prop) (RB : B-> B-> Prop)
                   (RC : C -> C -> Prop)(P : A -> B -> C ->  Prop),
 (forall x y z ,
  (forall (t : A), RA t x ->  P t y z) ->
  (forall (t : B), RB t y ->  P x t z) ->
  (forall (t : C), RC t z ->  P x y t) ->  P x y z) ->
 forall x y z, Acc RA x -> Acc RB y -> Acc RC z ->  P x y z.

intros A B C RA RB RC P H x y z Ax Ay Az.
 generalize Ax Ay Az.
 pattern x, y, z;
 eapply AccElim3 with (RA:=RA)(RB:=RB)(RC:=RC) ;eauto.
 intros; apply H.

 intros;apply H0; auto.
 eapply Acc_inv;eauto.
 intros;apply H1; auto.
 eapply Acc_inv;eauto.
 intros;apply H2; auto.
  eapply Acc_inv;eauto.
Qed.


(* $Id: CSemiGroups.v,v 1.15 2003/03/13 12:06:15 lcf Exp $ *)

Require Export CSetoids.
Require Export CTactics.

(* Begin_SpecReals *)

(* Tex_Prose
\chapter{Semigroups}
*)

(* Tex_Prose
\section{Definition of the notion of semigroup}
*)

(* Begin_Tex_Verb *)
Definition is_CSemi_grp [A:CSetoid; unit: A; op:(CSetoid_bin_op A)] :=
  (associative op).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Record CSemi_grp : Type :=
  { csg_crr   :> CSetoid;
    csg_unit  :  csg_crr;                      (* non-empty *)
    csg_op    :  (CSetoid_bin_op csg_crr);
    csg_proof :  (is_CSemi_grp csg_crr csg_unit csg_op)
  }.
(* End_Tex_Verb *)

(* Tex_Prose
\begin{notation}
\verb!csg_unit ?! is denoted with {\tt\hypertarget{Syntactic_4}{Zero}}.
\end{notation}
*)

Syntactic Definition Zero := (csg_unit ?).
Syntax constr level 1:
  csg_unit_constant [(csg_unit $e0)] -> ["Zero"].

(* Tex_Prose
\begin{notation}
\hypertarget{Operator_7}{}\verb!(csg_op ? x y)! is denoted with \verb!x [+] y!.
\end{notation}

\begin{nameconvention}
In the {\em names} of lemmas, we will denote \verb!Zero! with \verb!zero!,
and \verb![+]! with \verb!plus!.
We denote \verb![#] Zero! in the names of lemmas by \verb!ap_zero!
(and not, e.g.\ \verb!nonzero!).
\end{nameconvention}
*)

Implicits csg_op [1].
Infix 7 "[+]" csg_op.
(* End_SpecReals *)

(* Tex_Prose
\section{Semi group axioms}
The axiomatic properties of a semi group.
\begin{convention}
Let \verb!G! be a semi-group.
\end{convention}
*)
Section CSemi_grp_axioms.
Variable G : CSemi_grp.

(* Begin_Tex_Verb *)
Lemma CSemi_grp_is_CSemi_grp : (is_CSemi_grp G Zero csg_op).
(* End_Tex_Verb *)
Elim G; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma plus_assoc : (associative (!csg_op G)).
(* End_Tex_Verb *)
Exact CSemi_grp_is_CSemi_grp.
Qed.

End CSemi_grp_axioms.

(* Begin_SpecReals *)

(* Tex_Prose
\section{Semi group basics}
\begin{convention}
Let \verb!G! be a semi-group.
\end{convention}
*)
Section CSemi_grp_basics.
Variable G : CSemi_grp.

(* End_SpecReals *)

(* Begin_Tex_Verb *)
Lemma plus_assoc_unfolded : (G:CSemi_grp)(x,y,z:G)
                            (x [+] (y [+] z)) [=] ((x [+] y) [+] z).
(* End_Tex_Verb *)
Exact plus_assoc.
Qed.

(* Begin_SpecReals *)

(* Tex_Prose
The predicate "non-zero" is defined as follows.
In lemmas we will continue to write \verb!x [#] Zero!, rather than
\verb!nonZeroP x!, but the predicate is useful for some high-level definitions,
e.g. for the setoid of non-zeros.
*)

(* Begin_Tex_Verb *)
Definition nonZeroP [x:G] : CProp := (x [#] Zero).
(* End_Tex_Verb *)

End CSemi_grp_basics.

Implicits nonZeroP [1].
(* End_SpecReals *)

Hints Resolve plus_assoc_unfolded : algebra.

(* Tex_Prose
\section{Functional operations}
We can also define a similar addition operator, which will be denoted by {\tt\hypertarget{Operator_8}{\{+\}}}, on partial functions.

\begin{convention} Whenever possible, we will denote the functional construction corresponding to an algebraic operation by the same symbol enclosed in curly braces.
\end{convention}

At this stage, we will always consider automorphisms; we {\em could} treat this in a more general setting, but we feel that it wouldn't really be a useful effort.

\begin{convention} Let \verb!G:CSemi_grp! and \verb!F,F':(PartFunct G)! and denote by \verb!P! and \verb!Q!, respectively, the predicates characterizing their domains.
\end{convention}
*)

Section Part_Function_Plus.

Variable G:CSemi_grp.

Variables F,F' : (PartFunct G).

Local P := (Pred F).
Local Q := (Pred F').

(* Begin_Tex_Verb *)
Lemma part_function_plus_strext :
  (x,y:G)(Hx:(Conj P Q x))(Hy:(Conj P Q y))
  ((((F x (prj1 G ??? Hx))[+](F' x (prj2 G ??? Hx)))[#]
    ((F y (prj1 G ??? Hy))[+](F' y (prj2 G ??? Hy))))->(x[#]y)).
(* End_Tex_Verb *)
Intros x y Hx Hy H.
Elim (bin_op_strext_unfolded ?????? H); Intro H1; Exact (pfstrx ?????? H1).
Qed.

(* Begin_Tex_Verb *)
Definition Fplus := (Build_PartFunct G ?
  (conj_wd ??? (pfprwd ? F) (pfprwd ? F'))
  [x:G][Hx:(Conj P Q x)]((F x (prj1 G ??? Hx))[+](F' x (prj2 G ??? Hx)))
  part_function_plus_strext).
(* End_Tex_Verb *)

End Part_Function_Plus.

Implicits Fplus [1].
Infix 7 "{+}" Fplus.

(* Tex_Prose
\section{Sub-semi-groups}
\begin{convention}
Let \verb!csg! a semi-group and \verb!P! a predicate on the semi-group with
\verb!P Zero! and which is preserved by \verb![+]!.
\end{convention}
*)
Section SubCSemi_grps.
Variable csg       : CSemi_grp.
Variable P         : csg -> CProp.
Variable Punit     : (P Zero).
Variable op_pres_P : (bin_op_pres_pred ? P csg_op).

(* Begin_Tex_Verb *)
Local subcrr : CSetoid := (Build_SubCSetoid ? P).
Definition Build_SubCSemi_grp : CSemi_grp :=
  (Build_CSemi_grp subcrr
                   (Build_subcsetoid_crr ? ? ? Punit)
                   (Build_SubCSetoid_bin_op ? ? ? op_pres_P)
                   (restr_f_assoc ? ? ? op_pres_P (plus_assoc csg))).
(* End_Tex_Verb *)
End SubCSemi_grps.


(** Product of ordinal  notations *)

(** Pierre Castéran, Univ. Bordeaux and LaBRI *)

From Coq Require Import Arith Compare_dec Lia
     Relation_Operators RelationClasses.
From hydras Require Import Comparable Simple_LexProd ON_Generic.

Import Relations.
Generalizable All Variables.
Coercion is_true: bool >-> Sortclass.

(** * Definitions *)

(**  The product of two notation systems NA and NB is defined as the
    lexicographic product of the order on NB by the order on NA
    (in this order ! ) *)

(* begin snippet Defs *)

Section Defs.

  Context `(ltA: relation A)
          (cmpA : Compare A)
          (NA: ON ltA cmpA)
          `(ltB : relation B)
          (cmpB : Compare B)
          (NB: ON ltB cmpB).

  Definition t := (B * A)%type.
  Definition lt : relation t := lexico ltB ltA.
  Definition le := clos_refl _ lt.

  #[global] Instance compare_t : Compare t :=
    fun (alpha beta: t) =>
    match compare (fst alpha) (fst beta) with
    | Eq => compare (snd alpha) (snd beta)
    | c => c
    end.
   (*||*)
  (* end snippet Defs *)

  #[local] Hint Constructors clos_refl lexico: core.
  #[local] Hint Unfold  lt le : core.

  (** * Properties *)

  Instance lt_strorder : StrictOrder lt.
  Proof.
    apply Strict_lex; [apply NB | apply NA].
  Qed.

  Lemma lt_wf : well_founded lt.
  Proof. apply wf_lexico; apply ON_wf. Qed.

  Lemma compare_reflect alpha beta :
    match (compare alpha beta)
    with
      Lt => lt alpha  beta
    | Eq => alpha = beta
    | Gt => lt beta  alpha
    end.
  Proof.
    destruct alpha, beta; cbn. unfold compare, compare_t; cbn.
    destruct (comparable_comp_spec b b0).
    - subst; destruct (comparable_comp_spec a a0).
      + now subst.
      + now constructor 2.
      + now constructor 2.
    - now constructor 1.
    - now constructor 1.
  Qed.

  Lemma compare_correct alpha beta :
    CompSpec eq lt alpha beta (compare alpha beta).
  Proof.
    generalize (compare_reflect alpha beta);
      destruct (compare alpha beta); now constructor.
  Qed.

  (* begin snippet multComp:: no-out *)

  #[global] Instance mult_comp:  Comparable lt compare_t.
  (* end snippet multComp *)

  Proof.
    split.
    - apply lt_strorder.
    - apply compare_correct.
  Qed.

  (* begin snippet ONMult:: no-out *)
  #[global] Instance ON_mult: ON lt compare_t.
  (* end snippet ONMult *)

  Proof.
    split.
    - apply mult_comp.
    - apply lt_wf.
  Qed.

  Lemma lt_eq_lt_dec alpha beta :
    {lt alpha  beta} + {alpha = beta} + {lt beta alpha}.
  Proof.
    generalize (compare_reflect  alpha beta).
    destruct (compare alpha beta).
    - left;right; auto.
    - left;left; auto.
    - right;  auto.
  Defined.

  (* begin snippet endDefs *)

End Defs.
(* end snippet endDefs *)

Arguments lt_eq_lt_dec {A ltA cmpA} _ {B ltB cmpB} _.
Arguments ON_mult {A ltA cmpA} _ {B ltB cmpB}.
Arguments lt_strorder {A} {ltA} {cmpA} _  {B} {ltB} {cmpB} _.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.job rt.model.arrival.basic.task rt.model.arrival.basic.arrival_sequence.
Require Import rt.model.schedule.global.basic.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Definition and properties about processor affinities. *)
Module Affinity.

  Import ArrivalSequence ScheduleOfSporadicTask.

  Section AffinityDefs.

    Variable sporadic_task: eqType.

    (* Given the number of processors, ... *)
    Variable num_cpus: nat.

    (* ... let a processor affinity be a subset of these processors.
       Note: notation {set T} is just a list of type T with no duplicates. *)
    Definition affinity := {set (processor num_cpus)}.

    (* Next, we define a task affinity as the mapping from tasks to affinities. *)
    Definition task_affinity := sporadic_task -> affinity.

  End AffinityDefs.

  Section Properties.

    Context {sporadic_task: eqType}.
    Context {num_cpus: nat}.

    Section JobProperties.

      (* Assume that each task has a processor affinity alpha. *)
      Variable alpha: task_affinity sporadic_task num_cpus.

      (* Then, we say that task tsk ...*)
      Variable tsk: sporadic_task.

      (* ... can execute on processor cpu ...*)
      Variable cpu: processor num_cpus.

      (* ... iff cpu is part of j's affinity. *)
      Definition can_execute_on := cpu \in alpha tsk.

    End JobProperties.

    Section ScheduleProperties.

      Context {Job: eqType}.
      Variable job_task: Job -> sporadic_task.

      (* Consider any schedule, ... *)
      Variable sched: schedule Job num_cpus.

      (* ... and some affinity alpha. *)
      Variable alpha: affinity num_cpus.

      (* We say that a task is executing on alpha at time t iff it is
         scheduled on some processor in that affinity. *)
      Definition task_scheduled_on_affinity (tsk: sporadic_task) (t: time) :=
        [exists cpu, (cpu \in alpha) && task_scheduled_on job_task sched tsk cpu t].

    End ScheduleProperties.

    Section Subset.

      (* Given two affinities alpha' and alpha, ...*)
      Variable alpha' alpha: affinity num_cpus.

      (* ... we say that alpha' is subaffinity of alpha iff
         alpha' is contained in alpha. *)
      Definition is_subaffinity := {subset alpha' <= alpha}.

      Section Lemmas.

        Hypothesis H_subaffinity: is_subaffinity.

        Lemma leq_subaffinity : #|alpha'| <= #|alpha|.
        Proof.
          assert (UNIQ: uniq (alpha)). by destruct (alpha).
          assert (UNIQ': uniq (alpha')). by destruct (alpha').
          move: (UNIQ) (UNIQ') => /card_uniqP -> /card_uniqP ->.
          by apply uniq_leq_size.
        Qed.

      End Lemmas.

    End Subset.

    Section IntersectingAffinities.

      (* We say that alpha and alpha' intersect iff there exists a processor
         that belongs to both affinities. *)
      Definition affinity_intersects (alpha alpha': affinity num_cpus) :=
        [exists cpu, (cpu \in alpha) && (cpu \in alpha')].

    End IntersectingAffinities.

  End Properties.

End Affinity.


Add LoadPath "../Coq".

Require Import Homotopy.

Close Scope nat_scope.

(** You can't squeeze anything into nothing *)
Definition IsEmpty ( X : Type ) : Type := X -> False.

(** If you can't fit into nothing, you must have something, though perhaps
  we can't say what. *)
Definition is_inhab (X : Type ) := IsEmpty (IsEmpty X).

(** If we can, though, then vice-versa *)
Lemma inhab { X } : X -> is_inhab X.
  intros x f.
  contradict (f x).
Defined.

(** There's at most one way to not fit in nothing. We seem to need funext,
    but perhaps we should simply posit it? Do we not assume something
    equivalent in eta or some such? *)

Lemma is_conn_inhab { X : Type } : forall a b : is_inhab X,
 a == b.
 intros.
 apply funext.
 intro.
 contradict (a x).
Defined.

(** wrapping the previous result in fancier terminology *)

Lemma if_inhab_then_inhab_contr { X : Type } :
 forall a : is_inhab X,
  is_contr (is_inhab X).
  intros.
  exists a.
  intros.
  apply is_conn_inhab.
Defined.

(** And so *)

Lemma is_inhab_is_prop (X : Type) : is_prop ( is_inhab X ).
  intro.
  intro.
  exists ( is_conn_inhab x y ).
  intros.
  refine ( contr_path2 _ _ (if_inhab_then_inhab_contr x)).
Defined.

(** This feels vaguely like cheating, but I'm quite sure
  there isn't any way around it. It's not as though I can
  apply funext or univalence to something that isn't a path or an
  equivalence. *)

Axiom is_inhab_ind :
 forall (X : Type), is_prop X -> is_inhab X -> X.

Lemma prop_inhab_contr (X : Type) :
 is_prop X -> is_inhab X -> is_contr X.
 intros pr inh.
 exists (is_inhab_ind X pr inh).
 intros.
 apply pr.
Defined.

Lemma is_inhab_rect ( A : Type ) ( P : is_inhab A -> Type )
 ( dh : forall a, P (inhab a))
 (dp : forall (a b : is_inhab A)
  ( w : P a ) (z : P b) , transport (is_conn_inhab a b) w == z ) :
  forall (x : is_inhab A), P x.
 assert ( forall y , forall p q : P y, p == q ).
  intros.
  path_via (transport (is_conn_inhab y y) p).
 assert ( forall y : is_inhab A , is_prop (P y)).
  intro.
  intros p q.
  exists ( X y p q ).
  intros. apply contr_path2.
  exists p.
  intro. apply ( X y ).
 assert ( forall y : is_inhab A, is_inhab (P y) ).
  intro.
  intro.
  apply y.
  intro.
  set ( a := inhab X2 ).
  set ( pp := is_conn_inhab a y ).
  set ( v := dh X2 ).
  fold a in v.
  assert ( z := transport pp v ).
  apply X1. exact z.
 intro.
 exact (is_inhab_ind (P x) (X0 x) (X1 x)).
Defined.

(** noodling around; some applications. *)

Fixpoint n_connected ( n : nat) : Type -> Type :=
 match n with
 | O => fun X => is_inhab X
 | S m => fun X => is_inhab X * forall x y : X, n_connected m ( x == y ) end.

Definition component { X : Type } : X -> Type :=
 fun x => { y : X & is_inhab (x == y) }.

Definition components_are_subspaces { X : Type} ( x : X ) : component x -> X :=
 fun y => pr1 y.

Lemma fun_inhab { A B : Type } (f : A -> B ) :
 is_inhab A -> is_inhab B.
 intros.
 intro.
 apply X.
 exact ( X0 o f ).
Defined.

Lemma map_inhab { A B : Type } (f : A -> B )
 { a1 a2 : A } : is_inhab (a1 == a2) -> is_inhab ( f a1 == f a2 ).
 refine (fun_inhab _ ).
 intro.
 apply map.
 auto.
Defined.

Lemma inhab_contr_equiv ( X : Type ) :
 is_contr X -> is_equiv (@inhab X).
 intro.
 apply hequiv_is_equiv with (fun _ => (pr1 X0)).
 intro.
 assert ( H1 := if_inhab_then_inhab_contr y ).
 destruct H1 as [y0 pf].
 path_via y0.
 intro.
 destruct X0 as [ x0 pf ].
 refine (! pf _ ).
Defined.


(********** THE EXAMPLE FROM THE NAVARRO/RYBALCHENKO PAPER ***********)

Require Import ZArith.
Require Import Znumtheory.
Require Import Coq.Lists.List.
Require Import veristar.variables veristar.datatypes veristar.clauses.
Require Import veristar.superpose veristar.veristar.
Import Superposition VeriStar.

Definition a := Var 1%positive.
Definition b := Var 2%positive.
Definition c := Var 3%positive.
Definition d := Var 4%positive.
Definition e := Var 5%positive.

Definition example_ent := Entailment
  (Assertion [Nequ c e] [Lseg a b , Lseg a c , Next c d , Lseg d e])
  (Assertion nil [Lseg b c , Lseg c e]).

Compute cnf example_ent.
Compute check_entailment example_ent.


Require Import List.

Section PropLogic.

Inductive PP:Type:=
|axiom:nat->PP
|bottom:PP
|conj:PP->PP->PP
|cond:PP->PP->PP (* conditional ,A->B*)
|disj:PP->PP->PP (* disjunction, a or B *)
|neg:PP->PP.

Search list.
SearchPattern (list _->Prop).
Check In.
Print In.
Infix  "&":=conj (at level 70).
Infix "or":=disj (at  level 80).
Infix "-->":=cond (at level 90).

(*Inductive provable:list PP->PP->Prop:=
|taut A:forall prec,
In A prec->provable prec A
|conj_intro A B:forall prec:list PP,
In A prec->In B prec->provable prec (A&B)
|conj_elim_l A B:forall prec:list PP,
In (A&B) prec->provable prec A
|conj_elim_r A B:forall prec:list PP,
In (A&B) prec->provable prec B
|cond_intro A B C:
(forall prec,In A prec->In B prec->provable prec C)->forall prec:list PP,In A prec->provable prec (B-->C)
|cond_elim A B:
forall prec:list PP,
In A prec->In (A-->B) prec->provable prec B
|disj_intro_l A B:forall prec:list PP,
In A prec->provable prec (A or B)
|disj_intro_r A B:forall prec:list PP,
In B prec->provable prec (A or B)
|disj_elim A B C:
(forall prec,In A prec->provable prec C)->
(forall prec,In B prec->provable prec C)->
(forall prec,In (A or B) prec->provable prec C)
|bottom_intro A:forall prec:list PP,
provable prec A->provable prec (neg A)->provable prec bottom
|neg_intro A:forall prec:list PP,
provable (A :: prec) bottom->provable prec (neg A).*)

Axiom (provable:PP->PP->Prop).
Axiom (taut :forall A,provable A (A-->A)).
Axiom (conj_intro:forall A B,provable A (A&B)).
|conj_elim_l A B:forall prec:list PP,
In (A&B) prec->provable prec A
|conj_elim_r A B:forall prec:list PP,
In (A&B) prec->provable prec B
|cond_intro A B C:
(forall prec,In A prec->In B prec->provable prec C)->forall prec:list PP,In A prec->provable prec (B-->C)
|cond_elim A B:
forall prec:list PP,
In A prec->In (A-->B) prec->provable prec B
|disj_intro_l A B:forall prec:list PP,
In A prec->provable prec (A or B)
|disj_intro_r A B:forall prec:list PP,
In B prec->provable prec (A or B)
|disj_elim A B C:
(forall prec,In A prec->provable prec C)->
(forall prec,In B prec->provable prec C)->
(forall prec,In (A or B) prec->provable prec C)
|bottom_intro A:forall prec:list PP,
provable prec A->provable prec (neg A)->provable prec bottom
|neg_intro A:forall prec:list PP,
provable (A :: prec) bottom->provable prec (neg A).*)

Definition absurdity:=forall prec B,
In bottom prec->provable prec B.
Definition disj_syll:Prop:=forall A B:PP,
forall prec:list PP,
In (A or B) prec->In (neg A) prec->provable prec B.
Lemma asurd_disj_syll_iff:
absurdity<->disj_syll.
unfold absurdity,disj_syll.
split.
intros.
apply (disj_elim A B).
intros.
apply H.
apply bottom_intro.
intro.
intros.


From DEZ.Has Require Export
  EquivalenceRelation OrderRelation.
From DEZ.Is Require Export
  Preorder Antisymmetric.

Class IsPartialOrder {A : Type} {has_eqv : HasEqv A}
  (has_ord : HasOrd A) : Prop := {
  ord_is_preorder :> IsPreorder ord;
  ord_is_antisymmetric :> IsAntisymmetric ord;
}.

Section Context.

Context {A : Type} `{is_partial_order : IsPartialOrder A}.

Global Instance eqv_ord_partial_order : PartialOrder eqv ord | 0 := {
  partial_order_equivalence := _;
}.
Proof.
  cbv [relation_equivalence relation_conjunction].
  cbv [predicate_equivalence predicate_intersection].
  cbv [pointwise_lifting pointwise_extension].
  cbv [flip].
  intros x y. split.
  - intros Hxy. rewrite Hxy. split; reflexivity.
  - intros [Hxy Hyx]. apply antisymmetric; assumption. Qed.

End Context.


Require Export Iron.Language.SystemF2Data.Base.
Require Export Iron.Language.SystemF2Data.Kind.

(********************************************************************)
(* Type Constructors. *)
Inductive tycon : Type :=
 (* The function type constructor. *)
 | TyConFun  : tycon

 (* Primitive type constructors. *)
 | TyConNat  : tycon
 | TyConBool : tycon

 (* Data type constructors. *)
 | TyConData : nat   -> ki -> tycon.
Hint Constructors tycon.

(* The unit type constructor. *)
Definition  tcUnit := TyConData 0 KStar.
Hint Unfold tcUnit.

(********************************************************************)
(* Check whether two type constructors are equal. *)
Fixpoint tycon_beq t1 t2 :=
 match t1, t2 with
 | TyConFun,       TyConFun       => true
 | TyConNat,       TyConNat       => true
 | TyConBool,      TyConBool      => true
 | TyConData n1 _, TyConData n2 _ => beq_nat n1 n2
 | _,              _              => false
 end.

(* Check whether this is the function type constructor. *)
Definition isTyConFun  (tc: tycon) : Prop :=
 match tc with
 | TyConFun      => True
 | _             => False
 end.
Hint Unfold isTyConFun.

(* Check whether this is is an algebraic type constructor
   not the function type constructor or a primitive type. *)
Definition isTyConData (tc: tycon) : Prop :=
 match tc with
 | TyConData _ _ => True
 | _             => False
 end.
Hint Unfold isTyConData.


(precise)admin@localhost:~$ coqtop
Welcome to Coq 8.3pl4 (April 2012)

Coq < Section Examples.

Coq < Require Import Classical.

Coq < Variables G H I J : Prop.
G is assumed
H is assumed
I is assumed
J is assumed

Coq < Goal ((G -> H) /\ (H -> I) /\ (~J -> G) /\ ~I) -> J.
1 subgoal

  G : Prop
  H : Prop
  I : Prop
  J : Prop
  ============================
   (G -> H) /\ (H -> I) /\ (~ J -> G) /\ ~ I -> J

Unnamed_thm < intros.
1 subgoal

  G : Prop
  H : Prop
  I : Prop
  J : Prop
  H0 : (G -> H) /\ (H -> I) /\ (~ J -> G) /\ ~ I
  ============================
   J

Unnamed_thm < elim H0.
1 subgoal

  G : Prop
  H : Prop
  I : Prop
  J : Prop
  H0 : (G -> H) /\ (H -> I) /\ (~ J -> G) /\ ~ I
  ============================
   (G -> H) -> (H -> I) /\ (~ J -> G) /\ ~ I -> J

Unnamed_thm < intro.
1 subgoal

  G : Prop
  H : Prop
  I : Prop
  J : Prop
  H0 : (G -> H) /\ (H -> I) /\ (~ J -> G) /\ ~ I
  H1 : G -> H
  ============================
   (H -> I) /\ (~ J -> G) /\ ~ I -> J

Unnamed_thm < intro.
1 subgoal

  G : Prop
  H : Prop
  I : Prop
  J : Prop
  H0 : (G -> H) /\ (H -> I) /\ (~ J -> G) /\ ~ I
  H1 : G -> H
  H2 : (H -> I) /\ (~ J -> G) /\ ~ I
  ============================
   J

Unnamed_thm < destruct H2.
1 subgoal

  G : Prop
  H : Prop
  I : Prop
  J : Prop
  H0 : (G -> H) /\ (H -> I) /\ (~ J -> G) /\ ~ I
  H1 : G -> H
  H2 : H -> I
  H3 : (~ J -> G) /\ ~ I
  ============================
   J

Unnamed_thm < destruct H3.
1 subgoal

  G : Prop
  H : Prop
  I : Prop
  J : Prop
  H0 : (G -> H) /\ (H -> I) /\ (~ J -> G) /\ ~ I
  H1 : G -> H
  H2 : H -> I
  H3 : ~ J -> G
  H4 : ~ I
  ============================
   J

Unnamed_thm < tauto.
Proof completed.

Unnamed_thm < Qed.
intros.
elim H0.
intro.
intro.
destruct H2.
destruct H3.
tauto.

Unnamed_thm is defined

Coq <


(* isort_rank: like isort but return the rank of what have been
   sorted; its result, when applied to the initial list as an
   operator, returns the sorted list  *)

Set Nested Proofs Allowed.
Set Implicit Arguments.

Require Import Utf8 Arith.
Import List List.ListNotations.
Import Init.Nat.

Require Import Misc SortingFun.

Fixpoint isort_rank_insert {A B} (rel : A → A → bool) (f : B → A) ia lrank :=
  match lrank with
  | [] => [ia]
  | ib :: l =>
      if rel (f ia) (f ib) then ia :: lrank
      else ib :: isort_rank_insert rel f ia l
  end.

Fixpoint isort_rank {A} (rel : A → A → bool) (l : list A) :=
  match l with
  | [] => []
  | d :: l' =>
      isort_rank_insert rel (λ i, nth i l d) 0 (map S (isort_rank rel l'))
  end.

(*
Fixpoint isort_rank {A} (rel : A → A → bool) (l : list A) :=
  match l with
  | [] => []
  | d :: l' =>
      isort_insert (λ ia ib, rel (nth ia l d) (nth ib l d)) 0
        (map S (isort_rank rel l'))
  end.
*)

Theorem isort_rank_insert_length : ∀ {A B} (rel : A → _) (f : B → A) ia lrank,
  length (isort_rank_insert rel f ia lrank) = S (length lrank).
Proof.
intros.
induction lrank as [| ib]; [ easy | cbn ].
destruct (rel (f ia) (f ib)); [ easy | now cbn; f_equal ].
Qed.

Theorem isort_rank_length : ∀ A rel (l : list A),
  length (isort_rank rel l) = length l.
Proof.
intros.
induction l as [| d]; [ easy | ].
cbn - [ nth ].
now rewrite isort_rank_insert_length, map_length; f_equal.
Qed.

Theorem isort_rank_insert_nth_indep : ∀ A rel (d d' : A) ia lrank l_ini,
  ia < length l_ini
  → (∀ i, i ∈ lrank → i < length l_ini)
  → isort_rank_insert rel (λ i : nat, nth i l_ini d) ia lrank =
    isort_rank_insert rel (λ i : nat, nth i l_ini d') ia lrank.
Proof.
intros * Hia Hini.
induction lrank as [| ib]; [ easy | ].
cbn - [ nth ].
specialize (Hini ib (or_introl eq_refl)) as Hib.
rewrite (nth_indep _ _ d' Hia).
rewrite (nth_indep _ _ d' Hib).
remember (rel (nth ia l_ini d') (nth ib l_ini d')) as x eqn:Hx.
symmetry in Hx.
destruct x; [ easy | ].
f_equal.
apply IHlrank.
intros i Hi.
apply Hini.
now right.
Qed.

Theorem in_isort_rank_insert : ∀ A B (rel : A → _) (f : B → A) ia ib lrank,
  ia ∈ isort_rank_insert rel f ib lrank → ia ∈ ib :: lrank.
Proof.
intros * Hia.
induction lrank as [| ic]; [ easy | ].
cbn in Hia.
destruct (rel (f ib) (f ic)); [ easy | ].
destruct Hia as [Hia| Hia]; [ now right; left | ].
specialize (IHlrank Hia).
destruct IHlrank as [H1| H1]; [ now left | now right; right ].
Qed.

Theorem in_isort_rank : ∀ A (rel : A → _) l i,
  i ∈ isort_rank rel l → i < length l.
Proof.
intros * Hi.
revert i Hi.
induction l as [| a]; intros; [ easy | cbn ].
cbn - [ nth ] in Hi.
apply in_isort_rank_insert in Hi.
destruct Hi as [Hi| Hi]; [ now subst i | ].
apply in_map_iff in Hi.
destruct Hi as (j & Hj & Hi); subst i.
apply -> Nat.succ_lt_mono.
now apply IHl.
Qed.

Theorem isort_rank_insert_ub : ∀ A (rel : A → _) ia lrank f i n,
  ia < n
  → (∀ i, i ∈ lrank → i < n)
  → nth i (isort_rank_insert rel f ia lrank) 0 < n.
Proof.
intros * Hia Hn.
revert i.
induction lrank as [| ib]; intros. {
  destruct i; [ easy | cbn ].
  rewrite Tauto_match_nat_same; flia Hia.
}
cbn - [ nth ].
remember (rel (f ia) (f ib)) as x eqn:Hx.
symmetry in Hx.
destruct x. {
  destruct i; [ easy | ].
  destruct i; cbn; [ now apply Hn; left | ].
  destruct (lt_dec i (length lrank)) as [Hii| Hii]. 2: {
    apply Nat.nlt_ge in Hii.
    rewrite nth_overflow; [ flia Hia | easy ].
  }
  apply Hn; right.
  now apply nth_In.
} {
  destruct i; cbn; [ now apply Hn; left | ].
  apply IHlrank.
  intros j Hj.
  now apply Hn; right.
}
Qed.

Theorem isort_rank_ub : ∀ A rel (l : list A) i,
  l ≠ [] → nth i (isort_rank rel l) 0 < length l.
Proof.
intros * Hlz.
destruct l as [| ia]; [ easy | clear Hlz ].
cbn - [ nth ].
apply isort_rank_insert_ub; [ easy | ].
intros j Hj.
apply in_map_iff in Hj.
destruct Hj as (k & Hk & Hj); subst j.
apply -> Nat.succ_lt_mono.
now apply in_isort_rank in Hj.
Qed.

Theorem NoDup_isort_rank_insert : ∀ A (d : A) rel l_ini ia lrank,
  NoDup (ia :: lrank)
  → NoDup (isort_rank_insert rel (λ k : nat, nth k l_ini d) ia lrank).
Proof.
intros * Hnd.
revert ia Hnd.
induction lrank as [| ib]; intros. {
  cbn; constructor; [ easy | constructor ].
}
cbn.
destruct (rel (nth ia l_ini d) (nth ib l_ini d)); [ easy | ].
apply NoDup_cons_iff in Hnd.
destruct Hnd as (Hia, Hnd).
apply NoDup_cons_iff in Hnd.
destruct Hnd as (Hib, Hnd).
apply NoDup_cons. 2: {
  apply IHlrank.
  apply NoDup_cons_iff.
  split; [ | easy ].
  now intros H; apply Hia; right.
}
intros Hib'.
apply in_isort_rank_insert in Hib'.
destruct Hib' as [Hib'| Hib']; [ | easy ].
subst ib; apply Hia.
now left.
Qed.

Theorem NoDup_isort_rank : ∀ A rel (l : list A), NoDup (isort_rank rel l).
Proof.
intros.
induction l as [| d]; [ constructor | ].
cbn - [ nth ].
apply NoDup_isort_rank_insert.
constructor. {
  intros H; apply in_map_iff in H.
  now destruct H as (i & Hi & H).
}
apply FinFun.Injective_map_NoDup; [ | easy ].
intros i j Hij.
now apply Nat.succ_inj in Hij.
Qed.

Theorem eq_isort_rank_nil : ∀ A (rel : A → _) l,
  isort_rank rel l = [] → l = [].
Proof.
intros * Hl.
apply (f_equal length) in Hl.
rewrite isort_rank_length in Hl.
now apply length_zero_iff_nil in Hl.
Qed.

Theorem isort_insert_isort_rank_insert : ∀ A B rel ia (f : B → A) lrank,
  isort_insert rel (f ia) (map f lrank) =
  map f (isort_rank_insert rel f ia lrank).
Proof.
intros.
induction lrank as [| ib]; [ easy | cbn ].
destruct (rel (f ia) (f ib)); [ easy | ].
now cbn; f_equal.
Qed.

(* *)

Theorem isort_isort_rank : ∀ A (rel : A → A → bool) (d : A) l,
  isort rel l = map (λ i, nth i l d) (isort_rank rel l).
Proof.
intros.
induction l as [| d' l]; [ easy | ].
cbn - [ nth ].
rewrite IHl.
rewrite isort_rank_insert_nth_indep with (d' := d); [ | now cbn | ]. 2: {
  intros i Hi.
  apply in_map_iff in Hi.
  destruct Hi as (j & Hj & Hi); subst i.
  cbn; apply -> Nat.succ_lt_mono.
  now apply in_isort_rank in Hi.
}
rewrite <- isort_insert_isort_rank_insert.
rewrite List_nth_0_cons.
now rewrite map_map.
Qed.

Theorem sorted_isort_rank_insert : ∀ A B (rela : A → _) (relb : B → _),
  transitive relb →
  total_relation relb →
  ∀ f ia lrank,
  (∀ ib ic, ib ∈ ia :: lrank → ic ∈ ia :: lrank →
   rela (f ib) (f ic) = relb ib ic)
  → sorted relb lrank
  → sorted relb (isort_rank_insert rela f ia lrank).
Proof.
intros * Htrab Htotb * Hfab * Hs.
revert ia Hfab.
induction lrank as [| ib]; intros; [ easy | cbn ].
remember (rela (f ia) (f ib)) as ab eqn:Hab; symmetry in Hab.
destruct ab. {
  apply sorted_cons_iff; [ easy | ].
  split; [ easy | ].
  intros ic Hic.
  generalize Hab; intros Hiab.
  rewrite Hfab in Hiab; [ | now left | now right; left ].
  destruct Hic as [Hic| Hic]; [ now subst ic | ].
  apply sorted_cons_iff in Hs; [ | easy ].
  destruct Hs as (Hs, Hib).
  specialize (Hib _ Hic) as Hibc.
  now apply (Htrab _ ib).
}
apply sorted_cons_iff; [ easy | ].
apply sorted_cons_iff in Hs; [ | easy ].
destruct Hs as (Hs, Hib).
split. {
  apply IHlrank; [ easy | ].
  intros ic id Hic Hid.
  apply Hfab. {
    destruct Hic as [Hic| Hic]; [ now subst ic; left | now right; right ].
  } {
    destruct Hid as [Hid| Hid]; [ now subst id; left | now right; right ].
  }
}
intros ic Hic.
apply in_isort_rank_insert in Hic.
destruct Hic as [Hic| Hic]. {
  subst ic.
  rewrite Hfab in Hab; [ | now left | now right; left ].
  specialize (Htotb ia ib).
  now rewrite Hab in Htotb.
}
now apply Hib.
Qed.

(*
Theorem sorted_isort_rank : ∀ A d (rel : A → _),
  total_relation rel
  → ∀ la, sorted (λ i j, nth i la d <=? nth j la d) (isort_rank Nat.leb la).
Proof.
intros * Hto *.
induction la as [| a]; [ easy | ].
cbn - [ nth ].
rewrite isort_rank_insert_nth_indep with (d' := d); [ | now cbn | ]. 2: {
  intros i Hi.
  apply in_map_iff in Hi.
  destruct Hi as (j & Hj & Hi); subst i.
  cbn; apply -> Nat.succ_lt_mono.
  now apply in_isort_rank in Hi.
}
apply sorted_isort_rank_insert. {
  intros i j.
  apply Bool.orb_true_iff.
  remember (_ <=? _) as x eqn:Hx; symmetry in Hx.
  destruct x; [ now left | right ].
  apply Nat.leb_le.
  apply Nat.leb_nle, Nat.nle_gt in Hx.
  now apply Nat.lt_le_incl.
}
apply sorted_map; [ | apply IHla ].
intros x y z Hx Hy.
apply Nat.leb_le in Hx, Hy.
apply Nat.leb_le.
etransitivity; [ apply Hx | apply Hy ].
Qed.
*)

Theorem eq_sorted_isort_rank_insert_seq : ∀ A (rel : A → _) (ia : A) lrank f,
  (∀ ib, ib ∈ lrank → rel (f ia) (f ib) = true)
  → isort_rank_insert rel f ia lrank = ia :: lrank.
Proof.
intros * Ha.
destruct lrank as [| ib]; [ easy | cbn ].
remember (rel (f ia) (f ib)) as ab eqn:Hab; symmetry in Hab.
destruct ab; [ easy | ].
rewrite Ha in Hab; [ easy | now left ].
Qed.

Theorem eq_sorted_isort_rank_seq : ∀ (rel : nat → _),
  transitive rel →
  ∀ la, sorted rel la
  → isort_rank rel la = seq 0 (length la).
Proof.
intros * Htra * Hs.
induction la as [| a]; intros; [ easy | ].
cbn - [ nth seq ].
rewrite IHla; [ | now apply sorted_cons in Hs ].
rewrite seq_shift.
cbn - [ nth ].
apply eq_sorted_isort_rank_insert_seq.
intros * Hb.
apply in_seq in Hb.
rewrite List_nth_0_cons.
apply sorted_cons_iff in Hs; [ | easy ].
destruct Hs as (Hs, Ha).
apply Ha.
destruct ib; [ easy | cbn ].
apply nth_In; flia Hb.
Qed.

Theorem isort_rank_insert_eq_compat : ∀ A (f g : A → _) ia lrank,
  (∀ x y, x ∈ ia :: lrank → y ∈ ia :: lrank → (f x <=? f y) = (g x <=? g y))
  → isort_rank_insert Nat.leb f ia lrank =
    isort_rank_insert Nat.leb g ia lrank.
Proof.
intros * Hfg.
induction lrank as [| ib]; [ easy | cbn ].
rewrite Hfg; [ | now left | now right; left ].
rewrite IHlrank; [ easy | ].
intros i j Hi Hj.
apply Hfg. {
  destruct Hi; [ now left | now right; right ].
} {
  destruct Hj; [ now left | now right; right ].
}
Qed.

Theorem isort_rank_map_add_compat : ∀ i j la,
  isort_rank Nat.leb (map (add i) la) = isort_rank Nat.leb (map (add j) la).
Proof.
intros.
induction la as [| a]; [ easy | ].
cbn - [ nth ].
rewrite IHla.
apply isort_rank_insert_eq_compat.
intros ia ib Hia Hib.
destruct Hia as [Hia| Hia]. {
  subst ia; do 2 rewrite List_nth_0_cons.
  destruct Hib as [Hib| Hib]. {
    subst ib; do 2 rewrite List_nth_0_cons.
    now do 2 rewrite Nat.leb_refl.
  }
  apply in_map_iff in Hib.
  destruct Hib as (ic & H & Hib); subst ib.
  do 2 rewrite List_nth_succ_cons.
  apply in_isort_rank in Hib.
  rewrite map_length in Hib.
  rewrite (List_map_nth' 0); [ | easy ].
  rewrite (List_map_nth' 0); [ | easy ].
  now do 2 rewrite Nat_leb_add_mono_l.
}
apply in_map_iff in Hia.
destruct Hia as (ic & H & Hic); subst ia.
do 2 rewrite List_nth_succ_cons.
apply in_isort_rank in Hic.
rewrite map_length in Hic.
rewrite (List_map_nth' 0); [ | easy ].
rewrite (List_map_nth' 0); [ | easy ].
destruct Hib as [Hib| Hib]. {
  subst ib; do 2 rewrite List_nth_0_cons.
  now do 2 rewrite Nat_leb_add_mono_l.
}
apply in_map_iff in Hib.
destruct Hib as (id & H & Hid); subst ib.
do 2 rewrite List_nth_succ_cons.
apply in_isort_rank in Hid.
rewrite map_length in Hid.
rewrite (List_map_nth' 0); [ | easy ].
rewrite (List_map_nth' 0); [ | easy ].
now do 2 rewrite Nat_leb_add_mono_l.
Qed.

Theorem nth_nth_isort_rank : ∀ A d rel (l : list A) i,
  i < length l
  → nth (nth i (isort_rank rel l) 0) l d = nth i (isort rel l) d.
Proof.
intros * Hil.
rewrite (isort_isort_rank _ d).
rewrite (List_map_nth' 0); [ easy | ].
now rewrite isort_rank_length.
Qed.

Theorem neq_isort_rank_insert_nil : ∀ A B rel (f : B → A) ia lrank,
  isort_rank_insert rel f ia lrank ≠ [].
Proof.
intros * Hla.
destruct lrank as [| ib]; [ easy | cbn in Hla ].
now destruct (rel (f ia) (f ib)).
Qed.

(* collapse: transforms a list of n different naturals into a permutation of
   {0..n-1} such that they are in the same order than the initial list;
   E.g. collapse [3;1;7;2] = [2;0;3;1]; it is the list of the ranks.
   I claim that list has the same ε than the initial list i.e.
      ε (collapse l) = ε l
   I also claim that
      collapse (collapse l) = collapse l
      collapse (la ° lb) = collapse la ° collapse lb
      collapse la = la, if la is a permutation
   And
      collapse is a permutation
      it is the invert permutation of isort_rank
      i.e. isort_rank of isort_rank
      isort_rank ord l = rank of the elements in the sorted list
      e.g.
        isort_rank Nat.leb [19;3;7;6] = [1;3;2;0] means thatn
        - the first element of [1;3;2;0], 1, is the rank of the lowest
          value in [19;3;7;6] which is 3,
        - the second element of [1;3;2;0], 3, is the rank of the next
          lowest value in [19;3;7;6] which is 6,
        - and so on
*)

Definition collapse l := isort_rank Nat.leb (isort_rank Nat.leb l).

Theorem fold_collapse : ∀ l,
  isort_rank Nat.leb (isort_rank Nat.leb l) = collapse l.
Proof. easy. Qed.

Theorem collapse_length : ∀ l, length (collapse l) = length l.
Proof.
intros.
unfold collapse.
now do 2 rewrite isort_rank_length.
Qed.

Theorem eq_sorted_collapse_seq : ∀ la,
  sorted Nat.leb la → collapse la = seq 0 (length la).
Proof.
intros * Hs.
unfold collapse.
rewrite eq_sorted_isort_rank_seq; [ | apply Nat_leb_trans | ]. 2: {
  rewrite eq_sorted_isort_rank_seq; [ | apply Nat_leb_trans | easy ].
  apply sorted_nat_ltb_leb_incl.
  apply sorted_seq.
}
now rewrite isort_rank_length.
Qed.