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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Solange Coupet-Grimal and William Delobel, 2006-01-09

Various properties of preorders
*)

From CoLoR Require Import LogicUtil.
From Coq Require Import Relations.

Section PreOrderFacts.
  Variable A : Type.
  Variable leA : relation A.

  Definition eqA : relation A := fun (f g : A) => leA f g /\ leA g f.
  Definition ltA : (relation A) := fun (f g : A) => leA f g /\ ~ eqA f g.

  Variable leA_preorder : preorder A leA.

  Lemma eqA_equivalence : equivalence A eqA.
  Proof.
    inversion leA_preorder.
    split.
    (* reflexive : *)
    intro a; split; apply preord_refl.
    (* transitive : *)
    intros a b c H1 H2.
    elim H1; clear H1; intros a_le_g b_le_a.
    elim H2; clear H2; intros b_le_c c_le_b.
    split.
    apply preord_trans with b; hyp.
    apply preord_trans with b; hyp.
    (* symmetric : *)
    intros a b H.
    elim H; split; hyp.
  Qed.

  Lemma ltA_antisym : forall (a b : A), ltA a b -> ltA b a -> False.
  Proof.
    intros a b H1 H2.
    elim H1; clear H1; intros a_le_b b_neq_a.
    elim H2; clear H2; intros b_le_a a_neq_b.
    apply a_neq_b; split; hyp.
  Qed.

  Lemma ltA_trans : transitive A ltA.
  Proof.
    inversion leA_preorder.
    intros a b c H1 H2.
    elim H1; clear H1; intros a_le_b a_neq_b.
    elim H2; clear H2; intros b_le_c b_neq_c.
    split.
    apply preord_trans with b; hyp.
    intro H.
    elim H; clear H; intros a_le_c c_le_a.
    apply a_neq_b; split.
    hyp.
    apply preord_trans with c; hyp.
  Qed.

  Lemma leA_dec_to_eqA_dec : (forall (a b : A), leA a b \/ ~ leA a b) ->
    forall (a b : A), eqA a b \/ ~ eqA a b.
  Proof.
    intros leA_dec a b; elim (leA_dec a b); intro case_a_le_b.
    elim (leA_dec b a); intro case_b_le_a; [left | right].
    split; trivial.
    intro H; elim H; clear H; intros H1 H2.
    apply case_b_le_a; trivial.
    right; intro H; apply case_a_le_b.
    elim H; trivial.
  Qed.

  Lemma ltA_eqA_compat_r : forall (a b b' :A), eqA b b' -> ltA a b -> ltA a b'.
  Proof.
    inversion leA_preorder.
    intros a b b' b_eq a_lt_b.
    elim a_lt_b; clear a_lt_b; intros a_le_b a_neq_b.
    split.
    elim b_eq; clear b_eq; intros b_le_b' b'_le_b.
    apply preord_trans with b; hyp.
    elim (eqA_equivalence); intros eqA_refl eqA_trans eqA_sym.
    intro; apply a_neq_b; apply eqA_trans with b'; trivial.
    elim b_eq; split; trivial.
  Qed.

  Lemma ltA_eqA_compat_l : forall (a b b' :A), eqA b b' -> ltA b a -> ltA b' a.
  Proof.
    inversion leA_preorder.
    intros a b b' b_eq b_lt_a.
    elim b_lt_a; clear b_lt_a; intros b_le_a b_neq_a.
    split.
    elim b_eq; clear b_eq; intros b_le_b' b'_le_b.
    apply preord_trans with b; hyp.
    elim (eqA_equivalence); intros eqA_refl eqA_trans eqA_sym.
    intro; apply b_neq_a; apply eqA_trans with b'; trivial.
  Qed.

  Section Decidability.

    Variable leA_dec : forall a b, {leA a b} + {~leA a b}.

    Lemma eqA_dec : forall a b, {eqA a b} + {~eqA a b}.

    Proof.
      intros. unfold eqA.
      destruct (leA_dec a b); intuition.
      destruct (leA_dec b a); intuition.
    Defined.

    Lemma ltA_dec : forall a b, {ltA a b} + {~ltA a b}.

    Proof.
      intros. unfold ltA.
      destruct (leA_dec a b); intuition.
      destruct (eqA_dec a b); intuition.
    Defined.

  End Decidability.

End PreOrderFacts.


Require Export Coq.Init.Nat.

Definition smallerThan3 (n:nat) : bool := ltb n 3.

Compute smallerThan3 0.

Fixpoint firstn {A:Set} (l:list A) (n:nat) : list A :=
    match l with
    | nil => nil
    | cons h l' => match n with
                    | 0 => nil
                    | S n' => cons h (firstn l' n')
                    end
    end.

Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
(* Implicit Arguments firstn {A}. *)
Compute (firstn [1;2;3;4;5;6] 7).

Print snd.

Definition split {A B : Set} : list (A*B) -> list A * list B :=
    fix f (lab : list (A*B)) : list A * list B :=
        match lab with
        | nil => (nil, nil)
        | cons h lab' => match h with (a, b) => let tmp := (f lab') in (cons a (fst tmp), cons b (snd tmp))
        end
        end.

Compute (split ([(1,2); (2,3); (3,4)])).

Inductive List (A:Set) : Set :=
| nil : List A
| cons : A -> List A -> List A.

Check
  (fun l:List nat =>
     match l with
     | nil _ => nil nat
     | cons _ _ l' => l'
     end).


From Undecidability.Shared.Libs.PSL Require Import FinTypes.

Fixpoint position {X : eqType} (x : X) (l : list X) : option (Fin.t (length l)).
Proof.
  induction l.
  - exact None.
  - cbn. decide (a = x).
    + exact (Some Fin.F1).
    + destruct (position _ x l) as [res | ].
      * exact (Some (Fin.FS res)).
      * exact None.
Defined.

Lemma position_in {X : eqType} (x : X) (l : list X) (H : x el l) :
  { i | position x l = Some i}.
Proof.
    induction l; cbn in *.
    - inv H.
    - decide (a = x).
        + eauto.
        + destruct IHl as [i IH]. firstorder. rewrite IH. eauto.
Defined.

Definition posIn {X : eqType} (x : X) (l : list X) (H : x el l) : Fin.t (length l).
Proof.
    eapply position_in in H. destruct (position x l) as [i | ]. exact i.
    abstract (exfalso; firstorder congruence).
Defined.

Fixpoint getat {X : Type} (l : list X) (i : Fin.t (length l)) : X.
Proof.
    destruct l.
    - inv i.
    - cbn in i. eapply (Fin.caseS' i (fun _ => X)).
      + exact x.
      + eapply getat.
Defined.

Arguments getat {_} _ _.

Lemma getatIn {X : Type} (l : list X) (i : Fin.t (length l)) :
    getat l i el l.
Proof.
    induction l.
    - inv i.
    - cbn in *. eapply (Fin.caseS' i); cbn. eauto. eauto.
Qed.

Lemma finite_n (F : finType) :
    { n & {f : F -> Fin.t n & { g : Fin.t n -> F | (forall i, f (g i) = i) /\ forall x, g (f x) = x }}}.
Proof.
    destruct F as (X & [l H]). cbn in *.
    exists (length l).
    assert (Hin : forall x, x el l). { intros x. eapply count_in_equiv. rewrite H. lia. }
    exists (fun x => proj1_sig (position_in (Hin x))). exists (@getat _ l). split.
    - intros i. destruct position_in. cbn.
      specialize (H (getat l i)). clear - H e.
      induction l.
      + inv x.
      + cbn in *. revert H e.
        eapply (Fin.caseS' i). cbn.
        * decide (a = a); congruence.
        * cbn. intros. decide (getat l p = a).
         -- decide (a = getat l p); try congruence. subst. inv e. inv H.
            eapply countZero in H1 as []. eapply getatIn.
         -- decide (a = getat l p); try congruence.
            destruct position eqn:E; inv e. eapply IHl in E; congruence.
    - intros x. generalize (Hin x). clear. intros H.
      destruct (position_in H) as [i H1]. cbn.
      induction l; cbn in *.
      + inv H1.
      + decide (a = x).
        * inv H1. cbn. reflexivity.
        * destruct (position x l) eqn:E; inv H1.
          cbn. eapply IHl. firstorder. reflexivity.
Qed.


From Coq Require Import
  Utf8 Pnat BinNatDef
  BinPos List Lia.

Import ListNotations.

Section Prob.

 (* We formalise the probability as a rational
    number where denominator is positive.
    By construction, we can only construct
    zero or positive values. *)
  Record prob :=
    mk_prob {num : nat; denum : positive}.

  Declare Scope Prob_scope.
  Delimit Scope Prob_scope with P.
  Local Open Scope Prob_scope.

  Definition prob_eq (p q : prob) : bool :=
    match p, q with
    | mk_prob pa pb, mk_prob qa qb =>
      Nat.eqb (pa * Pos.to_nat qb) (qa * Pos.to_nat pb)
    end.

  (* Print Grammar constr. *)
  Local Infix "=p=" := prob_eq
    (at level 70, no associativity) : Prob_scope.

  (* prob_eq is an equivalence relation *)
  Lemma prob_eq_refl : forall p, p =p= p = true.
  Proof.
    intros [pa pb]; simpl; f_equal.
    apply PeanoNat.Nat.eqb_eq;
    reflexivity.
  Qed.

  Lemma prob_eq_sym : forall p q,
    p =p= q = true -> q =p= p = true.
  Proof.
    intros [pa pb] [qa qb]; simpl; intro Heq.
    apply PeanoNat.Nat.eqb_eq in Heq.
    apply PeanoNat.Nat.eqb_eq.
    lia.
  Qed.

  Lemma prob_eq_trans : forall p q r,
    p =p= q = true -> q =p= r = true ->
    p =p= r = true.
  Proof.
    intros [pa pb] [qa qb] [ra rb]; simpl;
    intros Ha Hb.
    apply PeanoNat.Nat.eqb_eq in Ha, Hb.
    apply PeanoNat.Nat.eqb_eq.
    nia. (* facinating! lia can't solve this goal *)
  Qed.
  (* end of equivalence relation *)

  Definition zero : prob := mk_prob 0 1.

  Definition one : prob := mk_prob 1 1.

  Definition add_prob (p q : prob) : prob :=
    match p, q with
    | mk_prob a b, mk_prob c d =>
        mk_prob
        (a * Pos.to_nat d + c * Pos.to_nat b)
        (b * d)
    end.

  Local Infix "+p" := (add_prob)
    (at level 50, left associativity) : Prob_scope.

  Lemma add_prob_assoc : forall p q r : prob,
    p +p q +p r = p +p (q +p r).
  Proof.
    intros [px dpx] [qx dqx] [rx drx]; simpl;
     f_equal; try lia.
  Qed.

  Lemma add_prob_comm : forall p q, p +p q = q +p p.
  Proof.
    intros [px Hpx] [qx Hqx]; simpl;
    f_equal; try lia.
  Qed.

  Definition mul_prob (p q : prob) : prob :=
    match p, q with
    | mk_prob a b , mk_prob c d =>
        mk_prob (a * c) (b * d)
    end.

  Local Infix "*p" := (mul_prob)
    (at level 40, left associativity) : Prob_scope.

  Lemma mul_prob_assoc : forall px pxx pt,
    px *p pxx *p pt =  px *p (pxx *p pt).
  Proof.
    intros [pxn pxd] [ppxn ppxd] [ptn ptd];
    simpl; f_equal; lia.
  Qed.

  Lemma mul_prob_comm: forall p q,
    p *p q = q *p p.
  Proof.
    intros [px Hpx] [qx Hqx]; simpl;
    f_equal; try lia.
  Qed.

  Definition leq (p q : prob) : bool :=
    match p, q with
    | mk_prob pa pb, mk_prob qa qb =>
      Nat.leb (pa * Pos.to_nat qb) (qa * Pos.to_nat pb)
    end.

  Local Infix "<p=" := (leq) (at level 70). (* associativity? *)
  (* Print Grammar constr. *)

  Lemma prob_leq_refl : forall p,
    p <p= p = true.
  Proof.
    intros [pa pb]; simpl.
    apply PeanoNat.Nat.leb_le.
    nia.
  Qed.

  Lemma prob_leq_trans : forall p q r,
    p <p= q = true -> q <p= r = true -> p <p= r = true.
  Proof.
    intros [pxn pxd] [ppxn ppxd] [ptn ptd];
      simpl; intros Hpq Hqr.
    apply PeanoNat.Nat.leb_le.
    apply PeanoNat.Nat.leb_le in Hpq, Hqr.
    nia.
  Qed.

  Lemma prob_leq_add_r : forall p q r,
    p <p= q = true -> p +p r <p= q +p r = true.
  Proof.
    intros [pxn pxd] [ppxn ppxd] [ptn ptd];
      simpl; intros Hpq.
    apply PeanoNat.Nat.leb_le.
    apply PeanoNat.Nat.leb_le in Hpq.
    nia.
  Qed.

  Lemma prob_leq_add_l : forall p q r,
    p <p= q = true -> r +p p <p= r +p q = true.
  Proof.
    intros [pxn pxd] [ppxn ppxd] [ptn ptd];
      simpl; intros Hpq.
    apply PeanoNat.Nat.leb_le.
    apply PeanoNat.Nat.leb_le in Hpq.
    nia.
  Qed.

  Lemma prob_leq_mul_r : forall p q r,
    p <p= q = true -> p *p r <p= q *p r = true.
  Proof.
    intros [pxn pxd] [ppxn ppxd] [ptn ptd];
      simpl; intros Hpq.
    apply PeanoNat.Nat.leb_le.
    apply PeanoNat.Nat.leb_le in Hpq.
    repeat rewrite Pos2Nat.inj_mul,
      PeanoNat.Nat.mul_assoc.
    apply PeanoNat.Nat.mul_le_mono_r.
    nia.
  Qed.

  Lemma prob_leq_mul_l : forall p q r,
    p <p= q = true ->  r *p p <p= r *p q = true.
  Proof.
    intros [pxn pxd] [ppxn ppxd] [ptn ptd];
      simpl; intros Hpq.
    apply PeanoNat.Nat.leb_le.
    apply PeanoNat.Nat.leb_le in Hpq.
    repeat rewrite Pos2Nat.inj_mul,
      PeanoNat.Nat.mul_assoc.
    assert (Ht: ptn * pxn * Pos.to_nat ptd * Pos.to_nat ppxd =
      ptn * (Pos.to_nat ptd * pxn * Pos.to_nat ppxd)).
    nia.
    rewrite Ht; clear Ht.
    assert (Ht: ptn * ppxn * Pos.to_nat ptd * Pos.to_nat pxd =
      ptn * (Pos.to_nat ptd * ppxn * Pos.to_nat pxd)).
    nia.
    rewrite Ht; clear Ht.
    eapply PeanoNat.Nat.mul_le_mono_nonneg_l with (p := ptn);
    try nia.
  Qed.

  Lemma leq_prob : forall p q,
    p <p= q = true <->
    num p * (Pos.to_nat (denum q)) <= num q * (Pos.to_nat (denum p)).
  Proof.
    intros [px qx] [py qy]; simpl.
    split; intros H;
    [apply PeanoNat.Nat.leb_le in H |
      apply PeanoNat.Nat.leb_le];
    nia.
  Qed.

End Prob.


Fixpoint grb (n m : nat) : bool :=
  match n with
  | O => false
  | S n' =>
      match m with
      | O => true
      | S m' => grb n' m'
      end
  end.

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

Example test_blt_nat1: grb 2 0 = true.
Proof. simpl. reflexivity. Qed.

Example test_blt_nat2: (grb 2 2) = false.
Proof. simpl. reflexivity. Qed.

Example test_blt_nat3: (grb 2 1) = true.
Proof. simpl. reflexivity. Qed.

Example test_blt_nat4: (grb 2 3) = false.
Proof. simpl. reflexivity. Qed.

Theorem t': forall (n: nat), grb (S n) n = true.
Proof.
  intros.
  induction n.
  - simpl. reflexivity.
  - simpl. apply IHn.
Qed.

Theorem inf_nat: forall (m: nat), exists (n: nat), grb n m = true.
Proof.
  intros m.
  induction m.
  - exists 1. simpl. reflexivity.
  - exists (S (S m)). simpl. apply t' with (n:=S m).
Qed.

Lemma wrong: forall x: nat, 2 * x = 1 -> False.
Proof.
  intros x. induction x.
  - intros. inversion H.
  - intros. apply IHx. destruct x. inversion H. inversion H.
Qed.

(* This black magic proof should be referred back to a lot.
   important to note that intros moves LHS from the goal to the context.
   somehow I didn't understand that completely, all this time.
*)
(*
Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  (* question: how can we just destruct m, if we haven't introduced it?
   * answer from lolisa on #coq: destruct introduces m, and all variables that come before it. *)
  Case "n=0".
  destruct m.
    SCase "m=0". intro H. reflexivity.
    SCase "m>0".
      (* cleverly not introducing the hypothesis until later. *)
      simpl. intro contra. inversion contra.
  Case "n>0".
  destruct m as [|m'].
    SCase "m=0". intros contra. inversion contra.
    SCase "m>0".
      intro H.
      apply eq_remove_S.
      (* here is some magic trick:
        applying a hypothesis with an assumption moves the assumption to the goal.
        but it can only be done when your goal matches whats on the RHS of that assumption.
        this really makes sense though:
          if you know A -> B, and you need to prove B,
          then if you can prove A, you're good.
            (also if you can disprove A, i guess, but that doesn't apply here).
      *)
      apply IHn'.
      (* in the rest, nothing really interesting happens. *)
     simpl in H. inversion H. rewrite <- plus_n_Sm in H1. rewrite <- plus_n_Sm in H1. inversion H1. reflexivity.
Qed.
*)

Definition prop' (m n k: nat) := forall (m: nat), exists (n: nat), grb n m = true /\ ~ exists (k: nat), 2 * k = n.
Check prop'.

Definition hasFactor (f n: nat) := true.

Theorem inf_nat_filter': forall (m n k: nat), hasFactor 2 m = true -> prop' m n k /\ hasFactor 2 m = false -> prop' m n k.
Proof.
  intros m.
  induction m.
  -
  induction m.
  - exists 1. unfold not. split.
    + simpl. reflexivity.
    + intros. destruct H. apply wrong with (x:=x). apply H.
  - exists (S (S m)). unfold not. split.
    + apply t' with (n:=S m).
    (* Stuck *)
    + intros. destruct H. destruct IHm. unfold not in H0. destruct H0. apply H1.


(** Regex derivatives
 *
 * Regular expression derivatives are a particularly elegant approach
 * to matching and reasoning about regular expressions and
 * languages. The idea is to consider the derivative of a language L
 * (a set of strings) with respect to a character c, defined as {w |
 * cw in L}. In terms of automata, what does the automata match if fed the
 * character c first? It turns out that derivatives of regular languages have
 * two nice properties: the derivative of a regular language is regular, and the
 * derivative of a language expressed as a regular expression can be expressed
 * in a simple syntatic manner.
 *
 * This development defines regexes as syntax and as predicates,
 * defines derivatives syntactically and as a transformation of a
 * predicate, and proves a relationship between these
 * two. Specifically, [[ dr/dc ]] = d [[ r ]]/dc, abusing d/dc for
 * both the syntatic and denotational derivative and using [[ r ]] to
 * denote the denotation of a regex.
 *
 * These derivative tools give a simple and natural regex matcher with a
 * correctness proof in its type.
 *)

Require Import List.

Section RegularExpressions.

  (** The alphabet for strings *)
  Variable Sigma:Type.
  (** We only require decidable equality on the alphabet for matching
  and derivatives to work (in particular, no finiteness
  constraint). *)
  Variable Sigma_dec : forall (c c': Sigma), {c = c'} + {c <> c'}.

  (** * Standard names

  These simple definitions give standard names from the theory of computation to
  the analogues in this setting.
   *)

  (** A string takes elements from the (arbitrary) alphabet above. *)
  Definition string := list Sigma.
  (** A language is traditionally a set of strings. In Coq's constructive logic,
  the best to express (possibly infinite) sets is as a predicate over strings;
  the interpretation will be that forall (l: language) (s: string), l s is true
  for exactly those strings in the language l *)
  Definition language := string -> Prop.

  (** A cool feature of Coq, mirroring standard practice in programming languages papers.

  This command means, for example, that when we use the letter s for a variable
  without a type annotation, it should default to being of type string, before
  types are inferred.

   This might seem like a horrible thing to do, and it is indeed confusing when
   done on a whiteboard or in a paper, but here it serves an important purpose:
   it ensures that when we use the letters c, s, or l (or those characters
   followed by numbers or prime symbols ' actually), they must represent the
   expected type. *)
  Implicit Types (c: Sigma) (s: string) (l: language).

  Definition string_dec : forall (s s': string), {s = s'} + {s <> s'} :=
    List.list_eq_dec Sigma_dec.

  Inductive regex :=
    (** Empty is the empty language, matching no strings. *)
  | Empty
  | Char (c:Sigma)
  | Or (r1:regex) (r2:regex)
  | Seq (r1:regex) (r2:regex)
  | Star (r:regex).

  (** Eps is a derived regex that matches only the empty string. *)
  Definition Eps := Star Empty.

  (** First we give an auxiliary inductive definition to take the Kleene star of
  a language. *)
  Inductive star (l: language) : language :=
  | star_empty : star l nil
  | star_iter : forall s1 s2,
      l s1 ->
      star l s2 ->
      star l (s1 ++ s2).

  (** The denotation of a regex is a language.

      Regular expressions give a nice way to think about denotational vs
      operational definitions. We could define what a regular expression does in
      terms of an automata, which gives regexes a meaning operationally.
      Instead, we give a denotation (think "interpretation" or "meaning") for
      each regex, mapping them to a concept we have in our metatheory.

      Normally the metatheory is mathematics, but here we are using the Coq
      programming language as the metatheory. In mathematics we would use a set
      of strings as the denotation of a regex, whereas here we use [language] as
      defined above. *)
  Fixpoint denotation (r:regex) : language :=
    match r with
    | Empty => fun _ => False
    | Char c => fun s => s = c::nil
    | Or r1 r2 => fun s => denotation r1 s \/ denotation r2 s
    | Seq r1 r2 => fun s =>
                    exists s1 s2, s = s1 ++ s2 /\
                             denotation r1 s1 /\
                             denotation r2 s2
    | Star r => fun s => star (denotation r) s
    end.

  (* We will want to automatically prove the denotation star with its
  constructors *)
  Hint Constructors star : core.

  Lemma star_false : forall s,
      star (fun _ => False) s ->
      s = nil.
  Proof.
    inversion 1; intuition.
  Qed.

  (** Some automation that covers most proofs here. *)

  (* Helper for instantiating existential hypotheses, preserving names. *)
  Ltac deex H :=
    lazymatch type of H with
    | exists (varname: _), _ =>
      let name := fresh varname in
      destruct H as [name ?]
    end.

  Ltac crush :=
    repeat match goal with
           | _ => progress (intros; simpl in *; subst)
           | [ H: exists _, _ |- _ ] => deex H
           | [ H: nil = _ ++ _ |- _ ] =>
             destruct (app_eq_nil _ _ (eq_sym H))
           | [ H: star (fun _ => False) _ |- _ ] =>
             apply star_false in H
           | [ H: _ :: _ = _ :: _ |- _ ] =>
             inversion H; clear H
           | _ => progress (intuition eauto 10)
           | [ |- exists (_ : string), _ ] =>
             solve [ exists nil; crush ]
           | _ => congruence
           end.

  (* Eps indeed represents the language consisting only of the empty string. *)
  Remark eps_denotation : forall s, denotation Eps s <-> s = nil.
  Proof.
    crush.
  Qed.

  (* The [observation_map] of a regex is one (equivalent to) Eps if nil
  is in the language and one (equivalent to) Empty otherwise. *)
  Fixpoint observation_map (r:regex) : regex :=
    match r with
    | Empty => Empty
    | Char _ => Empty
    | Or r1 r2 => Or (observation_map r1) (observation_map r2)
    | Seq r1 r2 => Seq (observation_map r1) (observation_map r2)
    | Star r => Eps
    end.

  (** Characterization of observation_map: when the resulting regex
  holds, it is equivalent to Eps (an artifact of how observation_map
  is defined) and nil is in r *)
  Section ObservationMap.

    Lemma observation_map_1 : forall r s,
      denotation (observation_map r) s ->
      s = nil.
    Proof.
      induction r; crush.
      rewrite (IHr1 s1); eauto.
    Qed.

    Lemma observation_map_2 : forall r,
        denotation (observation_map r) nil ->
        denotation r nil.
    Proof.
      induction r; crush.
    Qed.

    Lemma observation_map_eps : forall r s,
        denotation (observation_map r) s ->
        (s = nil /\ denotation r nil).
    Proof.
      intros.
      pose proof (observation_map_1 _ _ H); subst.
      intuition auto using observation_map_2.
    Qed.

    (* converse to the above *)
    Lemma observation_map_holds : forall r,
        denotation r nil ->
        denotation (observation_map r) nil.
    Proof.
      induction r; crush.
    Qed.

  End ObservationMap.

  (** Finally, we define the syntactic continuation map or derivative
    of a regular expression, with respect to c. *)
  Section Derivative.
    (** This is the character we are taking the derivative with respect to.
    Making it a variable means we don't have to pass it in recursive calls. *)
    Variable c:Sigma.

    Fixpoint continuation_map (r:regex) : regex :=
      match r with
      | Empty => Empty
      | Char c' => if Sigma_dec c c' then Eps else Empty
      | Or r1 r2 => Or (continuation_map r1) (continuation_map r2)
      | Seq r1 r2 => Or
                      (Seq (continuation_map r1) r2)
                      (Seq (observation_map r1) (continuation_map r2))
      | Star r => Seq (continuation_map r) (Star r)
      end.
  End Derivative.

  (** To write the correctness of the continuation_map, [derivative]
  defines derivative for a language in a straightforward,
  interpretable way. *)
  Definition derivative (c:Sigma) (l: language) : language :=
    fun s => l (c :: s).

  Hint Resolve app_comm_cons : core.
  Hint Resolve observation_map_eps observation_map_holds : core.

  (** The correctness theorem has the form that two languages (the denotation
      of the continuation map and the derivative of the regex language) are the
      same.

      In Coq the natural way to express that l1 and l2 are the same is to prove
      forall s, l1 <-> l2. This is easiest done by proving each direction
      separately, amounting to proving l1 is a subset of l2 (forall s, l1 -> l2)
      and that l2 is a subset of l1 (forall s, l2 -> l1). *)

  Theorem continuation_map_denotes_derivative_1 : forall r c,
      forall s, denotation (continuation_map c r) s ->
           derivative c (denotation r) s.
  Proof.
    unfold derivative.
    induction r; crush.
    - destruct (Sigma_dec c0 c); crush.
    - do 2 eexists; crush.
    - pose proof (observation_map_eps _ _ H); crush.
    - rewrite app_comm_cons.
      eauto.
  Qed.

  Theorem continuation_map_denotes_derivative_2 : forall r c,
      forall s, derivative c (denotation r) s ->
           denotation (continuation_map c r) s.
  Proof.
    unfold derivative.
    induction r; crush.
    - destruct (Sigma_dec c c); crush.
    - destruct s1; solve [ left + right; crush ].
    - remember (c::s).
      generalize dependent s.
      match goal with
      | [ H: star _ _ |- _ ] => induction H; crush
      end.
      destruct s1; crush.
  Qed.

  Theorem continuation_map_denotes_derivative : forall r c,
      forall s, denotation (continuation_map c r) s <->
           derivative c (denotation r) s.
  Proof.
    split; auto using continuation_map_denotes_derivative_1,
           continuation_map_denotes_derivative_2.
  Qed.

  (** With these definitions it is easy to write a regex matcher, verified
  against the denotation given above *)

  Section Matching.

    Ltac t := try solve [ left + right; crush ].

    (** auxilliary function to make observation_map computable *)
    Definition includes_nil r :
      {denotation (observation_map r) nil} +
      {forall s, ~denotation (observation_map r) s}.
      induction r; crush; t.
    Defined.

    (** unfold definition of derivative to drive hints *)
    Definition derivative_unfold : forall r c s,
        derivative c (denotation r) s ->
        denotation r (c::s)
      := ltac:(auto).

    Hint Resolve derivative_unfold : core.
    Hint Resolve observation_map_2 : core.
    Hint Resolve continuation_map_denotes_derivative_1 : core.
    Hint Resolve continuation_map_denotes_derivative_2 : core.

    (** Regex matching, with correctness built into the return type *)
    Fixpoint regex_match r s : {denotation r s} + {~denotation r s}.
      destruct s.
      - destruct (includes_nil r); t.
      - destruct (regex_match (continuation_map s r) s0); t.
    Defined.

    Section LazyEvaluation.

      (** Check if a regex represents the empty language. *)
      Fixpoint is_empty r : {forall s, ~denotation r s} + {exists s, denotation r s}.
        destruct r; simpl; t.
        - destruct (is_empty r1); t.
          destruct (is_empty r2); t.
        - destruct (is_empty r1); t.
          destruct (is_empty r2); t.
      Defined.

      (** This (probably more efficient) matcher first checks if the regex
      language has become empty; if so, it stops matching and uses the is_empty
      proof underneath a right constructor *)
      Fixpoint lazy_regex_match r s : {denotation r s} + {~denotation r s}.
        destruct s.
        - destruct (includes_nil r); t.
        - destruct (is_empty (continuation_map s r)); t.
          destruct (regex_match (continuation_map s r) s0); t.
      Defined.

    End LazyEvaluation.

  End Matching.

End RegularExpressions.

(* Local Variables: *)
(* company-coq-local-symbols: (("Sigma" . ?Σ)) *)
(* End: *)


From Equations Require Import Equations.
Require Import Arith.
Require Import Lia.
Require Import Coq.Lists.SetoidList. (* For Sorted *)
Require Import Sumbool.
Require Export JMeq.
Import Sigma_Notations.
Require Import Coq.Program.Tactics.

Notation dec x := (sumbool_of_bool x).

Lemma lte_div2 :
forall (n m : nat),
    n <= m
  ->
    Nat.div2 n <= Nat.div2 m.

intros.
rewrite Nat.div2_div.
rewrite Nat.div2_div.
apply Nat.div_le_mono.
lia.
apply H.
Qed.

Lemma lte_plus_div2 :
forall (n m : nat),
    m <= (n + m) / 2
  ->
    m <= n.

intros.
apply mult_le_compat_l with (p:= 2) in H.
apply Nat.le_trans with (p:= 2*(n+m)/2) in H.
replace (2*(n+m)) with ((n+m)*2) in H.
rewrite Nat.div_mul with (b:= 2) in H.
lia.
lia.
lia.
apply Nat.div_mul_le.
lia.
Qed.

Lemma lt_div2_min :
forall (n m : nat),
    n < m
  ->
    Nat.div2 (n + m) - n < m - n.

intros.
destruct (Nat.div2 (n+m)<? m) as []eqn:?.
apply Nat.ltb_lt in Heqb.
lia.
apply Nat.ltb_ge in Heqb.
rewrite Nat.div2_div in Heqb.
apply lte_plus_div2 in Heqb.
apply le_not_lt in Heqb.
contradiction.
Qed.

Set Program Mode.

Equations? binarysearch (l: list nat) (target L R :nat) : option nat by wf (R-L) lt:=
binarysearch l t L R with dec(R <=? L) =>
  | left H => None;
  | right H with dec(t =? nth (Nat.div2 L+R) l (t+1))=>
      | left H => Some (Nat.div2 L+R);
      | right H => if nth ((Nat.div2 L+R)) l (t+1) <? t
                     then binarysearch l t ((Nat.div2 (L+R))+1) R
                     else binarysearch l t L (Nat.div2 (L+R)).

apply leb_complete_conv in H.
apply Nat.le_lt_trans with (m:= R - (Nat.div2 (2*L) + 1)).
rewrite Nat.sub_add_distr.
rewrite Nat.sub_add_distr.
apply Nat.sub_le_mono_r.
apply Nat.sub_le_mono_l.
apply lte_div2.
lia.
rewrite Nat.div2_double.
rewrite Nat.sub_add_distr.
apply Nat.sub_gt in H.
lia.
apply leb_complete_conv in H.
apply lt_div2_min.
apply H.
Defined.

Check binarysearch_elim.

(* The return type containing the correctness property: *)
(* {p: option nat | Sorted le l -> (forall (e:nat), p=Some e -> nth e l (target+1) = target) /\ (p=None -> ~ In target l)}. *)

(* This is one part of the correctness property: *)
Theorem binarysearch_correct : forall (l : list nat) (a index : nat),
Sorted le l
->
~ In a l
->
binarysearch l a 0 (length l) = None.

intros.
apply binarysearch_elim.
intros.
trivial.
intros.
inversion e.
apply beq_nat_true in H2.
Admitted.
(* 2:{
intros.
destruct (nth (Nat.div2 L + R) l0 0 <? target) as []eqn:?.
apply H1.
apply H2. *)


Require Import Coq.Setoids.Setoid.
Require Import ELRefine.Refinement.

(** The abstract domain **)
Inductive Parity := Even | Odd.

(** The Abstraction Relation **)
Inductive Abstracts : Parity -> nat -> Prop :=
| A_Even : Abstracts Even 0
| A_Odd : Abstracts Odd 1
| A_SS : forall n p, Abstracts p n -> Abstracts p (2 + n).

(** Plus on the abstract domain **)
Definition plusParity (a b : Parity) : Parity :=
  match a , b with
    | Even , Odd
    | Odd , Even => Odd
    | _ , _ => Even
  end.

(** Lemmas **)
Definition opp (p : Parity) : Parity :=
  match p with
    | Even => Odd
    | Odd => Even
  end.

Lemma Abstracts_SS : forall n p, Abstracts p n <-> Abstracts p (S (S n)).
Proof.
  intros.
  destruct n; intuition; repeat constructor; auto.
  inversion H; auto.
  inversion H. auto.
Qed.

Theorem Abstracts_S : forall n p, Abstracts p n <-> Abstracts (opp p) (S n).
Proof.
  induction n.
  { intros. split. inversion 1. subst. constructor.
    destruct p; simpl; try constructor. inversion 1. }
  { intros.
    rewrite <- Abstracts_SS.
    specialize (IHn (opp p)); symmetry.
    destruct p; auto. }
Qed.

Theorem plusParity_plus
: hrespectful Abstracts (hrespectful Abstracts Abstracts) plusParity plus.
Proof.
  repeat red; intros.
  induction H; simpl; intros; try solve [ repeat constructor ].
  { destruct x0; assumption. }
  { rewrite Abstracts_S.
    constructor. destruct x0; assumption. }
  { rewrite <- Abstracts_SS. assumption. }
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section IntLogic.

Variables A B C : Prop.

Lemma notTrue_iff_False : (~ True) <-> False.
Proof.
Admitted.

Lemma dne_False : ~ ~ False -> False.
Proof.
Admitted.

Lemma dne_True : ~ ~ True -> True.
Proof.
Admitted.

Lemma weak_peirce : ((((A -> B) -> A) -> A) -> B) -> B.
Proof.
Admitted.

Lemma imp_trans : (A -> B) -> (B -> C) -> (A -> C).
Proof.
Admitted.

End IntLogic.

(** Let's get familiarize ourselves with some lemmas from [ssrbool] module.
    The proofs are very easy, so the lemma statements are more important here.
 *)
Section BooleanLogic.

Variables (A B : Type) (x : A) (f : A -> B) (a b : bool) (vT vF : A).

Lemma negbNE : ~~ ~~ b -> b.
Proof.
Admitted.

(** Figure out what [involutive] and [injective] mean
    using Coq's interactive queries. Prove the lemmas.
    Hint: to unfold a definition in the goal use [rewrite /definition] command.
*)
Lemma negbK : involutive negb.
Proof.
Admitted.

Lemma negb_inj : injective negb.
Proof.
Admitted.

Lemma ifT : b -> (if b then vT else vF) = vT.
Proof.
Admitted.

Lemma ifF : b = false -> (if b then vT else vF) = vF.
Proof.
Admitted.

Lemma if_same : (if b then vT else vT) = vT.
Proof.
Admitted.

Lemma if_neg : (if ~~ b then vT else vF) = if b then vF else vT.
Proof.
Admitted.

Lemma fun_if : f (if b then vT else vF) = if b then f vT else f vF.
Proof.
Admitted.

Lemma if_arg (fT fF : A -> B) :
  (if b then fT else fF) x = if b then fT x else fF x.
Proof.
Admitted.

Lemma andbK : a && b || a = a.
Proof.
Admitted.

(** Find out what [left_id], [right_id] mean
    using Coq's interactive queries. Prove the lemmas.
 *)
Lemma addFb : left_id false addb.    (* [addb] means XOR (eXclusive OR operation) *)
Proof.
Admitted.

Lemma addbF : right_id false addb.
Proof.
Admitted.

Lemma addbC : commutative addb.
Proof.
Admitted.

Lemma addbA : associative addb.
Proof.
Admitted.

(** Formulate analogous laws (left/right identity, commutativity, associativity)
    for boolean AND and OR and proove those.
    Find the names of corresponding lemmas in the standard library using
    [Search] command. For instance: [Search _ andb left_id.]
    Have you noticed the naming patterns?
 *)

End BooleanLogic.

Section NaturalNumbers.
(** Figure out what [cancel], [succn], [predn] mean
    using Coq's interactive queries. Prove the lemmas.
 *)
Lemma succnK : cancel succn predn.
Proof.
Admitted.

Lemma add0n : left_id 0 addn.
Proof.
Admitted.

Lemma addSn m n : m.+1 + n = (m + n).+1.
Proof.
Admitted.

Lemma add1n n : 1 + n = n.+1.
Proof.
Admitted.

Lemma add2n m : 2 + m = m.+2.
Proof.
Admitted.

Lemma subn0 : right_id 0 subn.
Proof.
Admitted.

End NaturalNumbers.


From Hammer Require Import Hammer.

Require Import NZAxioms NZBase Decidable OrdersTac.

Module Type NZOrderProp
(Import NZ : NZOrdSig')(Import NZBase : NZBaseProp NZ).

Instance le_wd : Proper (eq==>eq==>iff) le.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_wd".
intros n n' Hn m m' Hm. now rewrite <- !lt_succ_r, Hn, Hm.
Qed.

Ltac le_elim H := rewrite lt_eq_cases in H; destruct H as [H | H].

Theorem lt_le_incl : forall n m, n < m -> n <= m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_le_incl".
intros. apply lt_eq_cases. now left.
Qed.

Theorem le_refl : forall n, n <= n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_refl".
intro. apply lt_eq_cases. now right.
Qed.

Theorem lt_succ_diag_r : forall n, n < S n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_succ_diag_r".
intro n. rewrite lt_succ_r. apply le_refl.
Qed.

Theorem le_succ_diag_r : forall n, n <= S n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_succ_diag_r".
intro; apply lt_le_incl; apply lt_succ_diag_r.
Qed.

Theorem neq_succ_diag_l : forall n, S n ~= n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.neq_succ_diag_l".
intros n H. apply (lt_irrefl n). rewrite <- H at 2. apply lt_succ_diag_r.
Qed.

Theorem neq_succ_diag_r : forall n, n ~= S n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.neq_succ_diag_r".
intro n; apply neq_sym, neq_succ_diag_l.
Qed.

Theorem nlt_succ_diag_l : forall n, ~ S n < n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.nlt_succ_diag_l".
intros n H. apply (lt_irrefl (S n)). rewrite lt_succ_r. now apply lt_le_incl.
Qed.

Theorem nle_succ_diag_l : forall n, ~ S n <= n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.nle_succ_diag_l".
intros n H; le_elim H.
false_hyp H nlt_succ_diag_l. false_hyp H neq_succ_diag_l.
Qed.

Theorem le_succ_l : forall n m, S n <= m <-> n < m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_succ_l".
intro n; nzinduct m n.
split; intro H. false_hyp H nle_succ_diag_l. false_hyp H lt_irrefl.
intro m.
rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd.
rewrite or_cancel_r.
reflexivity.
intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l.
intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl.
Qed.

Theorem le_gt_cases : forall n m, n <= m \/ n > m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_gt_cases".
intros n m; nzinduct n m.
left; apply le_refl.
intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition.
Qed.

Theorem lt_trichotomy : forall n m,  n < m \/ n == m \/ m < n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_trichotomy".
intros n m. generalize (le_gt_cases n m); rewrite lt_eq_cases; tauto.
Qed.

Notation lt_eq_gt_cases := lt_trichotomy (only parsing).

Theorem lt_asymm : forall n m, n < m -> ~ m < n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_asymm".
intros n m; nzinduct n m.
intros H; false_hyp H lt_irrefl.
intro n; split; intros H H1 H2.
apply lt_succ_r in H2. le_elim H2.
apply H; auto. apply le_succ_l. now apply lt_le_incl.
rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l.
apply le_succ_l in H1. le_elim H1.
apply H; auto. rewrite lt_succ_r. now apply lt_le_incl.
rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l.
Qed.

Notation lt_ngt := lt_asymm (only parsing).

Theorem lt_trans : forall n m p, n < m -> m < p -> n < p.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_trans".
intros n m p; nzinduct p m.
intros _ H; false_hyp H lt_irrefl.
intro p. rewrite 2 lt_succ_r.
split; intros H H1 H2.
apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1].
assert (n <= p) as H3 by (auto using lt_le_incl).
le_elim H3. assumption. rewrite <- H3 in H2.
elim (lt_asymm n m); auto.
Qed.

Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_trans".
intros n m p. rewrite 3 lt_eq_cases.
intros [LT|EQ] [LT'|EQ']; try rewrite EQ; try rewrite <- EQ';
generalize (lt_trans n m p); auto with relations.
Qed.

Instance lt_strorder : StrictOrder lt.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_strorder".   split. exact lt_irrefl. exact lt_trans. Qed.

Instance le_preorder : PreOrder le.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_preorder".   split. exact le_refl. exact le_trans. Qed.

Instance le_partialorder : PartialOrder _ le.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_partialorder".
intros x y. compute. split.
intro EQ; now rewrite EQ.
rewrite 2 lt_eq_cases. intuition. elim (lt_irrefl x). now transitivity y.
Qed.

Definition lt_compat := lt_wd.
Definition lt_total := lt_trichotomy.
Definition le_lteq := lt_eq_cases.

Module Private_OrderTac.
Module IsTotal.
Definition eq_equiv := eq_equiv.
Definition lt_strorder := lt_strorder.
Definition lt_compat := lt_compat.
Definition lt_total := lt_total.
Definition le_lteq := le_lteq.
End IsTotal.
Module Tac := !MakeOrderTac NZ IsTotal.
End Private_OrderTac.
Ltac order := Private_OrderTac.Tac.order.

Theorem lt_neq : forall n m, n < m -> n ~= m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_neq".   order. Qed.

Theorem le_neq : forall n m, n < m <-> n <= m /\ n ~= m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_neq".   intuition order. Qed.

Theorem eq_le_incl : forall n m, n == m -> n <= m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.eq_le_incl".   order. Qed.

Lemma lt_stepl : forall x y z, x < y -> x == z -> z < y.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_stepl".   order. Qed.

Lemma lt_stepr : forall x y z, x < y -> y == z -> x < z.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_stepr".   order. Qed.

Lemma le_stepl : forall x y z, x <= y -> x == z -> z <= y.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_stepl".   order. Qed.

Lemma le_stepr : forall x y z, x <= y -> y == z -> x <= z.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_stepr".   order. Qed.

Declare Left  Step lt_stepl.
Declare Right Step lt_stepr.
Declare Left  Step le_stepl.
Declare Right Step le_stepr.

Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_lt_trans".   order. Qed.

Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_le_trans".   order. Qed.

Theorem le_antisymm : forall n m, n <= m -> m <= n -> n == m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_antisymm".   order. Qed.

Theorem le_succ_r : forall n m, n <= S m <-> n <= m \/ n == S m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_succ_r".
intros n m; rewrite lt_eq_cases. now rewrite lt_succ_r.
Qed.

Theorem lt_succ_l : forall n m, S n < m -> n < m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_succ_l".
intros n m H; apply le_succ_l; order.
Qed.

Theorem le_le_succ_r : forall n m, n <= m -> n <= S m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_le_succ_r".
intros n m LE. apply lt_succ_r in LE. order.
Qed.

Theorem lt_lt_succ_r : forall n m, n < m -> n < S m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_lt_succ_r".
intros. rewrite lt_succ_r. order.
Qed.

Theorem succ_lt_mono : forall n m, n < m <-> S n < S m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.succ_lt_mono".
intros n m. rewrite <- le_succ_l. symmetry. apply lt_succ_r.
Qed.

Theorem succ_le_mono : forall n m, n <= m <-> S n <= S m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.succ_le_mono".
intros n m. now rewrite 2 lt_eq_cases, <- succ_lt_mono, succ_inj_wd.
Qed.

Theorem lt_0_1 : 0 < 1.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_0_1".
rewrite one_succ. apply lt_succ_diag_r.
Qed.

Theorem le_0_1 : 0 <= 1.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_0_1".
apply lt_le_incl, lt_0_1.
Qed.

Theorem lt_1_2 : 1 < 2.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_1_2".
rewrite two_succ. apply lt_succ_diag_r.
Qed.

Theorem lt_0_2 : 0 < 2.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_0_2".
transitivity 1. apply lt_0_1. apply lt_1_2.
Qed.

Theorem le_0_2 : 0 <= 2.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_0_2".
apply lt_le_incl, lt_0_2.
Qed.

Ltac order' := generalize lt_0_1 lt_1_2; order.

Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_1_l".
intros n m H1 H2. rewrite <- le_succ_l, <- one_succ in H1. order.
Qed.

Theorem lt_ge_cases : forall n m, n < m \/ n >= m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_ge_cases".
intros n m; destruct (le_gt_cases m n); intuition order.
Qed.

Theorem le_ge_cases : forall n m, n <= m \/ n >= m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_ge_cases".
intros n m; destruct (le_gt_cases n m); intuition order.
Qed.

Theorem lt_gt_cases : forall n m, n ~= m <-> n < m \/ n > m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_gt_cases".
intros n m; destruct (lt_trichotomy n m); intuition order.
Qed.

Theorem eq_decidable : forall n m, decidable (n == m).
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.eq_decidable".
intros n m; destruct (lt_trichotomy n m) as [ | [ | ]];
(right; order) || (left; order).
Qed.

Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.eq_dne".
intros n m; split; intro H.
destruct (eq_decidable n m) as [H1 | H1].
assumption. false_hyp H1 H.
intro H1; now apply H1.
Qed.

Theorem le_ngt : forall n m, n <= m <-> ~ n > m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_ngt".   intuition order. Qed.

Theorem nlt_ge : forall n m, ~ n < m <-> n >= m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.nlt_ge".   intuition order. Qed.

Theorem lt_decidable : forall n m, decidable (n < m).
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_decidable".
intros n m; destruct (le_gt_cases m n); [right|left]; order.
Qed.

Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_dne".
intros n m; split; intro H.
destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H].
intro H1; false_hyp H H1.
Qed.

Theorem nle_gt : forall n m, ~ n <= m <-> n > m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.nle_gt".   intuition order. Qed.

Theorem lt_nge : forall n m, n < m <-> ~ n >= m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_nge".   intuition order. Qed.

Theorem le_decidable : forall n m, decidable (n <= m).
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_decidable".
intros n m; destruct (le_gt_cases n m); [left|right]; order.
Qed.

Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_dne".
intros n m; split; intro H.
destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H].
intro H1; false_hyp H H1.
Qed.

Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.nlt_succ_r".
intros n m; rewrite lt_succ_r. intuition order.
Qed.

Lemma lt_exists_pred_strong :
forall z n m, z < m -> m <= n -> exists k, m == S k /\ z <= k.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_exists_pred_strong".
intro z; nzinduct n z.
order.
intro n; split; intros IH m H1 H2.
apply le_succ_r in H2. destruct H2 as [H2 | H2].
now apply IH. exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2].
apply IH. assumption. now apply le_le_succ_r.
Qed.

Theorem lt_exists_pred :
forall z n, z < n -> exists k, n == S k /\ z <= k.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_exists_pred".
intros z n H; apply lt_exists_pred_strong with (z := z) (n := n).
assumption. apply le_refl.
Qed.

Lemma lt_succ_pred : forall z n, z < n -> S (P n) == n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_succ_pred".
intros z n H.
destruct (lt_exists_pred _ _ H) as (n' & EQ & LE).
rewrite EQ. now rewrite pred_succ.
Qed.

Section Induction.

Variable A : t -> Prop.
Hypothesis A_wd : Proper (eq==>iff) A.

Section Center.

Variable z : t.

Section RightInduction.

Let A' (n : t) := forall m, z <= m -> m < n -> A m.
Let right_step :=   forall n, z <= n -> A n -> A (S n).
Let right_step' :=  forall n, z <= n -> A' n -> A n.
Let right_step'' := forall n, A' n <-> A' (S n).

Lemma rs_rs' :  A z -> right_step -> right_step'.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.rs_rs'".
intros Az RS n H1 H2.
le_elim H1. apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]].
rewrite H3. apply RS; trivial. apply H2; trivial.
rewrite H3; apply lt_succ_diag_r.
rewrite <- H1; apply Az.
Qed.

Lemma rs'_rs'' : right_step' -> right_step''.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.rs'_rs''".
intros RS' n; split; intros H1 m H2 H3.
apply lt_succ_r in H3; le_elim H3;
[now apply H1 | rewrite H3 in *; now apply RS'].
apply H1; [assumption | now apply lt_lt_succ_r].
Qed.

Lemma rbase : A' z.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.rbase".
intros m H1 H2. apply le_ngt in H1. false_hyp H2 H1.
Qed.

Lemma A'A_right : (forall n, A' n) -> forall n, z <= n -> A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.A'A_right".
intros H1 n H2. apply H1 with (n := S n); [assumption | apply lt_succ_diag_r].
Qed.

Theorem strong_right_induction: right_step' -> forall n, z <= n -> A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.strong_right_induction".
intro RS'; apply A'A_right; unfold A'; nzinduct n z;
[apply rbase | apply rs'_rs''; apply RS'].
Qed.

Theorem right_induction : A z -> right_step -> forall n, z <= n -> A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.right_induction".
intros Az RS; apply strong_right_induction; now apply rs_rs'.
Qed.

Theorem right_induction' :
(forall n, n <= z -> A n) -> right_step -> forall n, A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.right_induction'".
intros L R n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply L; now apply lt_le_incl.
apply L; now apply eq_le_incl.
apply right_induction. apply L; now apply eq_le_incl. assumption.
now apply lt_le_incl.
Qed.

Theorem strong_right_induction' :
(forall n, n <= z -> A n) -> right_step' -> forall n, A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.strong_right_induction'".
intros L R n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply L; now apply lt_le_incl.
apply L; now apply eq_le_incl.
apply strong_right_induction. assumption. now apply lt_le_incl.
Qed.

End RightInduction.

Section LeftInduction.

Let A' (n : t) := forall m, m <= z -> n <= m -> A m.
Let left_step :=   forall n, n < z -> A (S n) -> A n.
Let left_step' :=  forall n, n <= z -> A' (S n) -> A n.
Let left_step'' := forall n, A' n <-> A' (S n).

Lemma ls_ls' :  A z -> left_step -> left_step'.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.ls_ls'".
intros Az LS n H1 H2. le_elim H1.
apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl].
rewrite H1; apply Az.
Qed.

Lemma ls'_ls'' : left_step' -> left_step''.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.ls'_ls''".
intros LS' n; split; intros H1 m H2 H3.
apply le_succ_l in H3. apply lt_le_incl in H3. now apply H1.
le_elim H3.
apply le_succ_l in H3. now apply H1.
rewrite <- H3 in *; now apply LS'.
Qed.

Lemma lbase : A' (S z).
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lbase".
intros m H1 H2. apply le_succ_l in H2.
apply le_ngt in H1. false_hyp H2 H1.
Qed.

Lemma A'A_left : (forall n, A' n) -> forall n, n <= z -> A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.A'A_left".
intros H1 n H2. apply (H1 n); [assumption | now apply eq_le_incl].
Qed.

Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.strong_left_induction".
intro LS'; apply A'A_left; unfold A'; nzinduct n (S z);
[apply lbase | apply ls'_ls''; apply LS'].
Qed.

Theorem left_induction : A z -> left_step -> forall n, n <= z -> A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.left_induction".
intros Az LS; apply strong_left_induction; now apply ls_ls'.
Qed.

Theorem left_induction' :
(forall n, z <= n -> A n) -> left_step -> forall n, A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.left_induction'".
intros R L n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply left_induction. apply R. now apply eq_le_incl. assumption.
now apply lt_le_incl.
rewrite H; apply R; now apply eq_le_incl.
apply R; now apply lt_le_incl.
Qed.

Theorem strong_left_induction' :
(forall n, z <= n -> A n) -> left_step' -> forall n, A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.strong_left_induction'".
intros R L n.
destruct (lt_trichotomy n z) as [H | [H | H]].
apply strong_left_induction; auto. now apply lt_le_incl.
rewrite H; apply R; now apply eq_le_incl.
apply R; now apply lt_le_incl.
Qed.

End LeftInduction.

Theorem order_induction :
A z ->
(forall n, z <= n -> A n -> A (S n)) ->
(forall n, n < z  -> A (S n) -> A n) ->
forall n, A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.order_induction".
intros Az RS LS n.
destruct (lt_trichotomy n z) as [H | [H | H]].
now apply left_induction; [| | apply lt_le_incl].
now rewrite H.
now apply right_induction; [| | apply lt_le_incl].
Qed.

Theorem order_induction' :
A z ->
(forall n, z <= n -> A n -> A (S n)) ->
(forall n, n <= z -> A n -> A (P n)) ->
forall n, A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.order_induction'".
intros Az AS AP n; apply order_induction; try assumption.
intros m H1 H2. apply AP in H2; [|now apply le_succ_l].
now rewrite pred_succ in H2.
Qed.

End Center.

Theorem order_induction_0 :
A 0 ->
(forall n, 0 <= n -> A n -> A (S n)) ->
(forall n, n < 0  -> A (S n) -> A n) ->
forall n, A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.order_induction_0".  exact ((order_induction 0)). Qed.

Theorem order_induction'_0 :
A 0 ->
(forall n, 0 <= n -> A n -> A (S n)) ->
(forall n, n <= 0 -> A n -> A (P n)) ->
forall n, A n.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.order_induction'_0".  exact ((order_induction' 0)). Qed.

Theorem lt_ind : forall (n : t),
A (S n) ->
(forall m, n < m -> A m -> A (S m)) ->
forall m, n < m -> A m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_ind".
intros n H1 H2 m H3.
apply right_induction with (S n); [assumption | | now apply le_succ_l].
intros; apply H2; try assumption. now apply le_succ_l.
Qed.

Theorem le_ind : forall (n : t),
A n ->
(forall m, n <= m -> A m -> A (S m)) ->
forall m, n <= m -> A m.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.le_ind".
intros n H1 H2 m H3.
now apply right_induction with n.
Qed.

End Induction.

Tactic Notation "nzord_induct" ident(n) :=
induction_maker n ltac:(apply order_induction_0).

Tactic Notation "nzord_induct" ident(n) constr(z) :=
induction_maker n ltac:(apply order_induction with z).

Section WF.

Variable z : t.

Let Rlt (n m : t) := z <= n < m.
Let Rgt (n m : t) := m < n <= z.

Instance Rlt_wd : Proper (eq ==> eq ==> iff) Rlt.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.Rlt_wd".
intros x1 x2 H1 x3 x4 H2; unfold Rlt. rewrite H1; now rewrite H2.
Qed.

Instance Rgt_wd : Proper (eq ==> eq ==> iff) Rgt.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.Rgt_wd".
intros x1 x2 H1 x3 x4 H2; unfold Rgt; rewrite H1; now rewrite H2.
Qed.

Theorem lt_wf : well_founded Rlt.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.lt_wf".
unfold well_founded.
apply strong_right_induction' with (z := z).
auto with typeclass_instances.
intros n H; constructor; intros y [H1 H2].
apply nle_gt in H2. elim H2. now apply le_trans with z.
intros n H1 H2; constructor; intros m [H3 H4]. now apply H2.
Qed.

Theorem gt_wf : well_founded Rgt.
Proof. hammer_hook "NZOrder" "NZOrder.NZOrderProp.gt_wf".
unfold well_founded.
apply strong_left_induction' with (z := z).
auto with typeclass_instances.
intros n H; constructor; intros y [H1 H2].
apply nle_gt in H2. elim H2. now apply le_lt_trans with n.
intros n H1 H2; constructor; intros m [H3 H4].
apply H2. assumption. now apply le_succ_l.
Qed.

End WF.

End NZOrderProp.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (x : natural) (lf2 : natural) : natural :=
  plus x (plus (Succ y) lf2).


(* week_36d_fac.v *)
(* dIFP 2014-2015, Q1, Week 36 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

(* ********** *)

Require Import Arith Bool.

Require Import unfold_tactic.

(* ********** *)

Notation "A === B" := (beq_nat A B) (at level 70, right associativity).

Definition unit_tests_for_factorial (fac : nat -> nat) :=
  (fac 0 === 1)
  &&
  (fac 1 === 1)
  &&
  (fac 5 === 120).

(* ********** *)

Definition specification_of_factorial (fac : nat -> nat) :=
  (fac O = 1)
  /\
  (forall n' : nat,
    fac (S n') = (S n') * (fac n')).

Proposition there_is_only_one_factorial_function :
  forall fac1 fac2 : nat -> nat,
    specification_of_factorial fac1 ->
    specification_of_factorial fac2 ->
    forall n : nat,
      fac1 n = fac2 n.
Proof.
  intros fac1 fac2 S_fac1 S_fac2 n.
  unfold specification_of_factorial in S_fac1.
  destruct S_fac1 as [H_fac1_bc H_fac1_ic].
  unfold specification_of_factorial in S_fac2.
  destruct S_fac2 as [H_fac2_bc H_fac2_ic].

  induction n as [ | n' IHn'].

  rewrite -> H_fac1_bc.
  rewrite -> H_fac2_bc.
  reflexivity.

  rewrite -> (H_fac1_ic n').
  rewrite -> (H_fac2_ic n').
  rewrite -> IHn'.

  reflexivity.

 Qed.
(* ********** *)

Fixpoint fac_ds (n : nat) :=
  match n with
    | 0 => 1
    | S n' => (S n') * (fac_ds n')
  end.

Definition fac_v0 (n : nat) :=
  fac_ds n.

Compute unit_tests_for_factorial fac_v0.

(* The two mandatory unfold lemmas: *)

Lemma unfold_fac_ds_bc :
  fac_ds 0 = 1.
Proof.
  unfold_tactic fac_ds.
Qed.

Lemma unfold_fac_ds_ic :
  forall n' : nat,
    fac_ds (S n') = (S n') * (fac_ds n').
Proof.
  unfold_tactic fac_ds.
Qed.

Theorem fac_v0_satisfies_the_specification_of_factorial :
  specification_of_factorial fac_v0.
Proof.
  unfold specification_of_factorial.
  split.
    unfold fac_v0.
    apply unfold_fac_ds_bc.
  intro n'.
  unfold fac_v0.
  apply (unfold_fac_ds_ic n').
Qed.

(* ********** *)

Fixpoint fac_acc (n a : nat) :=
  match n with
    | 0 => a
    | S n' => fac_acc n' (S n' * a)
  end.

Definition fac_v1 (n : nat) :=
  fac_acc n 1.

Compute unit_tests_for_factorial fac_v1.

(* The two mandatory unfold lemmas: *)

Lemma unfold_fac_acc_bc :
  forall a : nat,
    fac_acc 0 a = a.
Proof.
  unfold_tactic fac_acc.
Qed.

Lemma unfold_fac_acc_ic :
  forall n' a : nat,
    fac_acc (S n') a = fac_acc n' (S n' * a).
Proof.
  unfold_tactic fac_acc.
Qed.

Theorem fac_v1_satisfies_the_specification_of_factorial_first_try :
  specification_of_factorial fac_v1.
Proof.
  unfold specification_of_factorial.
  unfold fac_v1.

  split.
  apply (unfold_fac_acc_bc 1).

  intro n'.
  rewrite -> (unfold_fac_acc_ic n' 1).
  Check mult_1_r.
  rewrite -> (mult_1_r (S n')).
 Abort.

Lemma about_fac_acc_tentative :
  forall n a : nat,
    fac_acc n a = a * (fac_acc n 1).
Proof.
Admitted.

Theorem fac_v1_satisfies_the_specification_of_factorial_second_try :
  specification_of_factorial fac_v1.
Proof.
  unfold specification_of_factorial.
  unfold fac_v1.

  split.
  apply (unfold_fac_acc_bc 1).

  intro n'.
  rewrite -> (unfold_fac_acc_ic n' 1).
  Check mult_1_r.
  rewrite -> (mult_1_r (S n')).
  rewrite -> (about_fac_acc_tentative n' (S n')).
  reflexivity.
Abort.

Lemma about_fac_acc :
  forall n a : nat,
    fac_acc n a = a * (fac_acc n 1).
Proof.
  intros n a.
  induction n as [ | n' IHn'].

  rewrite -> (unfold_fac_acc_bc a).
  rewrite -> (unfold_fac_acc_bc 1).
  rewrite -> (mult_1_r a).
  reflexivity.

  rewrite -> (unfold_fac_acc_ic n' a).
  rewrite -> (unfold_fac_acc_ic n' 1).
  rewrite -> (mult_1_r (S n')).

  Restart.

  intro n.
  induction n as [ | n' IHn'].
  intro a.
  rewrite -> (unfold_fac_acc_bc a).
  rewrite -> (unfold_fac_acc_bc 1).
  rewrite -> (mult_1_r a).
  reflexivity.

  intro a.
  rewrite -> (unfold_fac_acc_ic n' a).
  rewrite -> (unfold_fac_acc_ic n' 1).
Abort. (* DU NÅEDE HERTIL *)
(* OG DU MANGLER AT SKRIVE NOGET IND ET ANDET STED OGSÅ *)

(* ********** *)

Fixpoint fac_cps (ans : Type) (n : nat) (k : nat -> ans) :=
  match n with
    | 0 => k 1
    | S n' => fac_cps ans n' (fun v => k (S n' * v))
  end.

Definition fac_v2 (n : nat) :=
  fac_cps nat n (fun v => v).

Compute unit_tests_for_factorial fac_v2.

(* The two mandatory unfold lemmas: *)

Lemma unfold_fac_cps_bc :
  forall (ans : Type)
         (k : nat -> ans),
    fac_cps ans 0 k = k 1.
Proof.
  unfold_tactic fac_cps.
Qed.

Lemma unfold_fac_cps_ic :
  forall (ans : Type)
         (n' : nat)
         (k : nat -> ans),
    fac_cps ans (S n') k = fac_cps ans n' (fun v => k (S n' * v)).
Proof.
  unfold_tactic fac_cps.
Qed.

Lemma about_fac_cps :
  forall (n : nat)
         (k : nat -> nat),
    fac_cps nat n k = k (fac_cps nat n (fun v => v)).
Proof.
  intro n.
  induction n as [ | n' IHn'].

  intro k.
  rewrite -> (unfold_fac_cps_bc nat k).
  rewrite -> (unfold_fac_cps_bc nat (fun v : nat => v)).
  reflexivity.

  intro k.
  rewrite -> (unfold_fac_cps_ic nat n' k).
  rewrite -> (IHn' (fun v : nat => k (S n' * v))).
  rewrite -> (unfold_fac_cps_ic nat n' (fun v : nat => v)).
  rewrite -> (IHn' (fun v : nat => S n' * v)).
  reflexivity.
Qed.

Theorem fac_v2_satisfies_the_specification_of_factorial :
  specification_of_factorial fac_v2.
Proof.
  unfold specification_of_factorial.
  unfold fac_v2.
  split.

  apply (unfold_fac_cps_bc nat (fun v => v)).

  intro n'.
  rewrite -> (unfold_fac_cps_ic nat n' (fun v => v)).
  rewrite -> (about_fac_cps n' (fun v => S n' * v)).
  reflexivity.
Qed.

(* ********** *)

(* end of week_36d_fac.v *)


(* Hernán Gurmendi *)

Set Asymmetric Patterns.

Section Ejercicio1.

Inductive list (A : Set) : Set :=
  | emptyL : list A
  | cons : A -> list A -> list A.

Inductive bintree (A : Set) : Set :=
  | emptyBT : bintree A
  | merge : bintree A -> A -> bintree A -> bintree A.

Inductive array (A : Set) : nat -> Set :=
  | emptyA : array A 0
  | add : forall (n : nat), A -> array A n -> array A (S n).

Inductive matrix (A : Set) : nat -> nat -> Set :=
  | oneCol : forall n : nat, array A n -> matrix A n 1
  | addCol : forall n m : nat, array A n -> matrix A n m -> matrix A n (S m).

Inductive leq : nat -> nat -> Prop :=
  | leq0 : forall m : nat, leq 0 m
  | leqS : forall n m : nat, leq n m -> leq (S n) (S m).

Inductive eq_list (A : Set) : list A -> list A -> Prop :=
  | eqlistE : eq_list A (emptyL A) (emptyL A)
  | eqlistC : forall (l r : list A) (x : A), eq_list A l r -> eq_list A (cons A x l) (cons A x r).

Inductive eq_list' (A : Set) (R : A -> A -> Prop) : list A -> list A -> Prop :=
  | eqlistE' : eq_list' A R (emptyL A) (emptyL A)
  | eqlistC' : forall (l r : list A) (x y : A), eq_list' A R l r -> R x y -> eq_list' A R (cons A x l) (cons A y r).

Inductive sorted (A : Set) (R : A -> A -> Prop) : list A -> Prop :=
  | sortedE : sorted A R (emptyL A)
  | sortedS : forall x : A, sorted A R (cons A x (emptyL A)) (* Singleton *)
  | sortedC : forall (x y : A) (l : list A), R x y -> sorted A R (cons A x (cons A y l)).

Inductive mirror (A : Set) : bintree A -> bintree A -> Prop :=
  | mirrorE : mirror A (emptyBT A) (emptyBT A)
  | mirrorM : forall (x : A) (ll lr rl rr : bintree A), mirror A ll rr -> mirror A lr rl -> mirror A (merge A ll x lr) (merge A rl x rr).

Inductive isomorfo (A : Set) : bintree A -> bintree A -> Prop :=
  | isomorfoE : isomorfo A (emptyBT A) (emptyBT A)
  | isomorfoM : forall (ll lr rl rr : bintree A) (x y : A), isomorfo A ll rl -> isomorfo A lr rr -> isomorfo A (merge A ll x lr) (merge A rl y rr).

End Ejercicio1.

Section Ejercicio3.

Fixpoint sum (n m : nat) : nat :=
    match n, m with
    | 0, m     => m
    | (S n), m => S (sum n m)
    end.

Fixpoint prod (n m : nat) : nat :=
    match n, m with
    | 0, m     => 0
    | (S n), m => sum m (prod n m)
    end.

Fixpoint pot (n m : nat) : nat :=
    match m with
    | 0     => 1
    | (S m) => prod n (pot n m)
    end.

End Ejercicio3.

Section Ejercicio4.

Fixpoint length (A : Set) (l : list A) : nat :=
    match l with
    | emptyL    => 0
    | cons x xs => 1 + length A xs
    end.

Fixpoint length' (A : Set) (l : list A) :=
    match l with
    | emptyL    => 0
    | cons _ xs => S (length' A xs)
    end.

Fixpoint append (A : Set) (l r : list A) : list A :=
    match l with
    | emptyL    => r
    | cons x xs => cons A x (append A xs r)
    end.

Fixpoint reverse (A : Set) (l : list A) : list A :=
    match l with
    | emptyL    => emptyL A
    | cons x xs => append A (reverse A xs) (cons A x (emptyL A))
    end.

Fixpoint filter (A : Set) (p : A -> bool) (l : list A) : list A :=
    match l with
    | emptyL    => emptyL A
    | cons x xs =>
        match (p x) with
        | true  => cons A x (filter A p xs)
        | false => filter A p xs
        end
    end.

Fixpoint map (A B : Set) (f : A -> B) (l : list A) : list B :=
    match l with
    | emptyL    => emptyL B
    | cons x xs => cons B (f x) (map A B f xs)
    end.

Fixpoint exists_ (A : Set) (p : A -> bool) (l : list A) : bool :=
    match l with
    | emptyL    => false
    | cons x xs =>
        match (p x) with
        | false => exists_ A p xs
        | true  => true
        end
    end.

End Ejercicio4.

Section Ejercicio5.

Fixpoint inverse (A : Set) (t : bintree A) : bintree A :=
  match t with
  | emptyBT     => emptyBT A
  | merge l x r => merge A (inverse A r) x (inverse A l)
  end.

End Ejercicio5.

Section Ejercicio9.

Lemma SumO : forall n : nat, sum n 0 = n /\ sum 0 n = n.
Proof.
  intros.
  induction n; split; simpl.
  - reflexivity.
  - reflexivity.
  - elim IHn. intros. rewrite H. reflexivity.
  - reflexivity.
Qed.

Lemma SumS : forall n m : nat, sum n (S m) = sum (S n) m.
Proof.
  intros.
  induction n; simpl.
  - reflexivity.
  - rewrite IHn. reflexivity.
Qed.

Lemma SumAsoc : forall n m p : nat, sum n (sum m p) = sum (sum n m) p.
Proof.
  intros.
  induction n; simpl.
  - reflexivity.
  - rewrite IHn. reflexivity.
Qed.

Lemma SumConm : forall n m : nat, sum n m = sum m n.
Proof.
  intros.
  induction n; simpl.
  - induction m; simpl.
    + reflexivity.
    + rewrite <- IHm. reflexivity.
  - rewrite IHn. rewrite SumS. simpl. reflexivity.
Qed.

End Ejercicio9.

Section Ejercicio12.

Lemma L7 : forall (A B : Set) (l m : list A) (f : A -> B),
  map A B f (append A l m) = append B (map A B f l) (map A B f m).
Proof.
  intros.
  induction l; simpl.
  - reflexivity.
  - rewrite IHl. reflexivity.
Qed.

Lemma L8 : forall (A : Set) (l m : list A) (P : A -> bool),
  filter A P (append A l m) = append A (filter A P l) (filter A P m).
Proof.
  intros.
  induction l; simpl.
  - reflexivity.
  - case (P a); simpl; rewrite IHl; reflexivity.
Qed.

Lemma L9 : forall (A : Set) (l : list A) (P : A -> bool),
  filter A P (filter A P l) = filter A P l.
Proof.
  intros.
  induction l; simpl.
  - reflexivity.
  - assert (P a = true \/ P a =  false). case (P a); [left | right]; reflexivity.
    elim H; intros Assumption; rewrite Assumption; simpl.
    + rewrite Assumption. rewrite IHl. reflexivity.
    + rewrite IHl. reflexivity.
Qed.

Lemma L10 : forall (A : Set) (l m n : list A),
  append A l (append A m n) = append A (append A l m) n.
Proof.
  intros.
  induction l; simpl.
  - reflexivity.
  - rewrite IHl. reflexivity.
Qed.

End Ejercicio12.

Section Ejercicio14.

Lemma Ej14 : forall (A : Set) (t : bintree A), mirror A (inverse A t) t.
Proof.
  intros.
  induction t; simpl.
  - apply mirrorE.
  - apply mirrorM; assumption.
Qed.

End Ejercicio14.

Section Ejercicio17.

Inductive posfijo (A : Set) : list A -> list A -> Prop :=
  | posfE : forall l : list A, posfijo A l l
  | posfC : forall (l1 l2 : list A) (x : A), posfijo A l1 l2 -> posfijo A l1 (cons A x l2).

Lemma Ej17_2_1 : forall (A : Set) (l1 l2 l3 : list A), l2 = append A l3 l1 -> posfijo A l1 l2.
Proof.
  intros.
  rewrite H.
  clear H.
  induction l3; simpl.
  - apply posfE.
  - apply posfC. apply IHl3.
Qed.

Lemma Ej17_2_2 : forall (A : Set) (l1 l2 : list A), posfijo A l1 l2 -> exists l3 : list A, l2 = append A l3 l1.
Proof.
  intros.
  induction H.
  - exists (emptyL A). simpl. reflexivity.
  - elim IHposfijo. intros. rewrite H0. exists (cons A x x0). simpl. reflexivity.
Qed.

Lemma Ej17_3_1 : forall (A : Set) (l1 l2 l3 : list A),
posfijo A l2 (append A l1 l2).
Proof.
  intros.
  induction l1; simpl.
  - apply posfE.
  - apply posfC. assumption.
Qed.

Lemma EmptyAppends : forall (A : Set) (l1 l2 : list A),
append A l1 l2 = emptyL A -> l1 = emptyL A /\ l2 = emptyL A.
Proof.
  intros.
  split; rewrite <- H; induction l1.
  - symmetry. assumption.
  - simpl in H. discriminate.
  - simpl. reflexivity.
  - simpl in H. discriminate.
Qed.

Axiom AppendEmptyLeft : forall (A : Set) (l1 l2 : list A), append A l1 l2 = l2 -> l1 = emptyL A.

Lemma Ej17_3_2 : forall (A : Set) (l1 l2 : list A),
posfijo A l1 l2 -> posfijo A l2 l1 -> l1 = l2.
Proof.
  intros.
  assert (exists l3 : list A, l2 = append A l3 l1). apply Ej17_2_2. assumption.
  assert (exists l3 : list A, l1 = append A l3 l2). apply Ej17_2_2. assumption.
  elim H1. intros.
  elim H2. intros.
  rewrite H4 in H3.
  rewrite L10 in H3.
  assert (append A x x0 = emptyL A).
  - apply (AppendEmptyLeft A (append A x x0) l2). symmetry. assumption.
  - assert (x0 = emptyL A).
    + elim (EmptyAppends A x x0).
      * intros. assumption.
      * assumption.
    + rewrite H6 in H4. simpl in H4. assumption.
Qed.

Lemma Ej17_3_3 : forall (A : Set) (l1 l2 l3 : list A),
posfijo A l1 l2 -> posfijo A l2 l3 -> posfijo A l1 l3.
Proof.
  intros.
  induction H0.
  - induction l; assumption.
  - induction H0; apply posfC.
    + assumption.
    + apply IHposfijo. assumption.
Qed.

Fixpoint ultimo (A : Set) (l : list A) : list A :=
  match l with
  | emptyL    => emptyL A
  | cons x xs =>
  match xs with
    | emptyL => cons A x (emptyL A)
    | _      => ultimo A xs
    end
  end.

Lemma Ej17_5 : forall (A : Set) (l : list A), posfijo A (ultimo A l) l.
Proof.
  intros.
  induction l; simpl.
  - apply posfE.
  - destruct l.
    + apply posfE.
    + apply posfC. assumption.
Qed.

End Ejercicio17.

Section Ejercicio20.

Inductive ACom (A : Set) : nat -> Set :=
  | single : A -> ACom A O
  | combine : forall n : nat, ACom A n -> A -> ACom A n -> ACom A (S n).

Fixpoint h (A : Set) (n : nat) (t : ACom A n) : nat :=
  match t with
  | single x => 1
  | combine _ t1 x t2 => sum (h A _ t1) (h A _ t2)
  end.

(* Parameter pot: nat -> nat -> nat. *)
Axiom potO : forall n : nat, pot (S n) 0 = 1.
Axiom potS : forall m: nat, pot 2 (S m) = sum (pot 2 m) (pot 2 m).

Lemma Ej20_3 : forall (A : Set) (n : nat) (t : ACom A n),
(h A n t) = (pot 2 n).
Proof.
  intros.
  induction t; simpl.
  - reflexivity.
  - rewrite IHt1. rewrite IHt2. elim (SumO (pot 2 n)). intros. rewrite H. reflexivity.
Qed.

End Ejercicio20.


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Program.Basics.
Require Import Coq.omega.Omega.

Require Import BWT.Sorting.Ord.
Require Import BWT.Sorting.Sorted.
Require Import BWT.Sorting.StablePerm.
Require Import BWT.Sorting.InsertionSort.
Require Import BWT.Rotation.Rotation.
Require Import BWT.Lib.Repeat.
Require Import BWT.Lib.Permutation.
Require Import BWT.Sorting.Key.
Require Import BWT.Lib.List.
Require Import BWT.Columns.
Require Import BWT.Sorting.Lexicographic.
Require Import BWT.Sorting.PermFun.

Section RadixSort.
  Context {A : Type} {O : Preord A}.

  Open Scope program_scope.

  Implicit Type m : list (list A).
  Implicit Type n : nat.

  Definition radixsort m (n : nat) : list (list A)
    := rep (hdsort ∘ map rrot) n m.

  Remark radixsort_S : forall l j,
      radixsort l (S j) = hdsort (map rrot (radixsort l j)).
  Proof. reflexivity. Qed.

  Lemma radixsort_perm_inv : forall j m,
      Permutation (rep (map rrot) j m) (rep (hdsort ∘ map rrot) j m).
  Proof.
    induction j as [|j IH]; intro m; [reflexivity|].
    cbn; symmetry.
    transitivity (map rrot (rep (hdsort ∘ map rrot) j m)).
    symmetry. apply sort_perm.
    apply Permutation_map.
    symmetry. apply IH.
  Qed.

  Theorem radixsort_perm : forall n m,
      Forall (fun r => length r = n) m ->
      Permutation m (radixsort m n).
  Proof.
    intros n m HL.
    unfold radixsort.
    rewrite <- map_id at 1.
    rewrite map_forall_eq with (g := rep rrot n).
    rewrite <- rep_map.
    apply radixsort_perm_inv.
    eapply Forall_impl; [|apply HL].
    cbn; intros a HN.
    rewrite <- HN. symmetry. apply rrot_rep_id.
  Qed.

  Lemma radixsort_nil : forall n, radixsort nil n = nil.
  Proof.
    intros. unfold radixsort.
    apply rep_preserves; [|auto].
    intros x HIn. unfold compose.
    subst.
    reflexivity.
  Qed.

  Theorem radixsort_length : forall n j l,
      Forall (fun x => length x = n) l ->
      Forall (fun x => length x = n) (radixsort l j).
  Proof.
    intros n j l HL.
    unfold radixsort.
    apply rep_preserves; [|auto].
    clear HL l.
    intros l HL.
    apply Forall_forall.
    intros x HIn. unfold compose in HIn.
    apply Permutation_in with (l' := map rrot l) in HIn; [|symmetry; apply sort_perm].
    apply in_map_iff in HIn.
    destruct HIn as [prex [Hprex HIn]].
    rewrite <- Hprex, <- rrot_length.
    apply Forall_forall with (x := prex) in HL.
    apply HL. apply HIn.
  Qed.

  Lemma StablePerm_map_rrot : forall m m' : list (list A),
      StablePerm m m' -> StablePerm (map rrot m) (map rrot m').
  Proof.
    intros m m' HS.
    apply StablePermInd_iff in HS.
    induction HS.
    - reflexivity.
    - cbn. apply StablePerm_skip. apply IHHS.
    - cbn. apply StablePerm_swap.
      intro c; apply H.
      symmetry.
      apply lex_eqv_iff in c.
      apply lex_eqv_iff.
      rewrite <- @r_l_rot_inverse with (l := x).
      rewrite <- @r_l_rot_inverse with (l := y).
      apply Forall2_lrot. easy.
    - transitivity (map rrot l'); easy.
  Qed.

  Lemma radixsort_stable_inv : forall j m,
      StablePerm (rep (map rrot) j m) (rep (hdsort ∘ map rrot) j m).
  Proof.
    induction j; intros l; [reflexivity|].
    cbn; symmetry.
    transitivity (map rrot (rep (hdsort ∘ map rrot) j l)).
    apply PrefixStable_firstn_1.
    symmetry. apply sort_stable.
    apply StablePerm_map_rrot. symmetry. apply IHj.
  Qed.

  Theorem radixsort_stable : forall n l,
      Forall (fun x => length x = n) l ->
      StablePerm l (radixsort l n).
  Proof.
    intros n l HL.
    etransitivity; [|apply radixsort_stable_inv].
    rewrite rep_map.
    replace (map (rep rrot n) l) with (map (fun x => x) l); [rewrite map_id; easy|].
    apply map_forall_eq.
    eapply Forall_impl; [|apply HL].
    intros. rewrite <- H. symmetry; apply rrot_rep_id.
  Qed.

  Lemma radixsort_sorted_inv : forall n j m,
      j <= n ->
      Forall (fun r => length r = n) m ->
      PrefixSorted j (radixsort m j).
  Proof.
    induction j; intros m HJ HL; [apply PrefixSorted_zero|].
    destruct m as [|r m]; [rewrite radixsort_nil; apply Sorted_nil|].
    destruct r as [|d t] eqn:Ht;
      [apply Forall_inv in HL; cbn in HL; omega|rewrite <- Ht in *; clear t Ht].
    rewrite radixsort_S.
    apply hdsort_sorted_S.
    rewrite map_rrot_prepend with (d0 := d)
      by (eapply Forall_impl; [|apply radixsort_length with (j := j) (n := n); easy];
          cbn; intros; intro c; subst; cbn in HJ; omega).
    rewrite map_tl_prepend by (rewrite !map_length; omega).
    apply key_sorted. rewrite map_map.
    rewrite map_forall_eq with (g := firstn j)
      by (apply radixsort_length with (j := j) in HL;
          eapply Forall_impl; [|apply HL]; cbn; intros; apply firstn_init; omega).
    apply key_sorted; fold (PrefixSorted j (radixsort (r :: m) j)).
    apply IHj; [omega|auto].
  Qed.

  Theorem radixsort_sorted : forall n m,
      Forall (fun x => length x = n) m ->
      Sorted (radixsort m n).
  Proof.
    intros n m HL.
    rewrite <- map_id.
    rewrite map_forall_eq with (g := firstn n)
      by (apply radixsort_length with (j := n) in HL;
          eapply Forall_impl; [|apply HL];
          cbn; intros; subst; symmetry; apply firstn_all).
    apply key_sorted; fold (PrefixSorted n (radixsort m n)).
    apply radixsort_sorted_inv with (n := n); [omega|easy].
  Qed.

  Theorem radixsort_correct : forall n m,
      Forall (fun x => length x = n) m ->
      Sorted (radixsort m n) /\ Permutation (radixsort m n) m.
  Proof.
    split; [apply radixsort_sorted|symmetry; apply radixsort_perm]; easy.
  Qed.
End RadixSort.


Require Import group.

Set Implicit Arguments.
Unset Strict Implicit.

Structure hom M (G : group M) M' (G' : group M') := {
  hom_f : M -> M';
  hom_is_map : map hom_f G G';
  hom_law : forall x y, hom_f (bin G x y) = bin G' (hom_f x) (hom_f y)
}.

Theorem hom_id_map_id : forall (M M' : Type) (G : group M) (G' : group M') (h : hom G G'),
  hom_f h (id G) = id G'.
Proof.
  intros.
  assert (hom_f h (id G) = hom_f h (bin G (id G) (id G)))
    as f_id_G_eq_f__id_G_id_G
    by (rewrite (idR G (id G)); reflexivity).

  rewrite (hom_law h (id G) (id G)) in f_id_G_eq_f__id_G_id_G.
  rename f_id_G_eq_f__id_G_id_G into f_id_G_eq_f_id_G_f_id_G.

  apply (both_sides_L (bin G') (inverse G' (hom_f h (id G)))) in f_id_G_eq_f_id_G_f_id_G.
  rename f_id_G_eq_f_id_G_f_id_G into inv_f_id_G_f_id_G_eq_inv_f_id_G_f_id_G_f_id_G.

  rewrite (assoc G' (inverse G' (hom_f h (id G))) (hom_f h (id G)) (hom_f h (id G)))
    in inv_f_id_G_f_id_G_eq_inv_f_id_G_f_id_G_f_id_G.

  rewrite (invL G' (hom_f h (id G)))
    in inv_f_id_G_f_id_G_eq_inv_f_id_G_f_id_G_f_id_G.
  rename inv_f_id_G_f_id_G_eq_inv_f_id_G_f_id_G_f_id_G
    into f_id_G_eq_inv_f_id_G_f_id_G_f_id_G.

  rewrite (idL G' (hom_f h (id G))) in f_id_G_eq_inv_f_id_G_f_id_G_f_id_G.
  symmetry.
  assumption.
Qed.

Theorem hom_inverse_map_inverse : forall (M M' : Type) (G : group M) (G' : group M') (h : hom G G'),
  forall x, hom_f h (inverse G x) = inverse G' (hom_f h x).
Proof.
  intros.
  assert (f_id_G_eq_id_G' := hom_id_map_id h).

  rewrite <- (invR G x) in f_id_G_eq_id_G'.
  rename f_id_G_eq_id_G' into f_x_x'_eq_id_G'.
  rewrite (hom_law h x (inverse G x)) in f_x_x'_eq_id_G'.
  rename f_x_x'_eq_id_G' into f_x_f_x'_eq_id_G'.

  apply (both_sides_L (bin G'))
    with (z:=(inverse G' (hom_f h x)))
    in f_x_f_x'_eq_id_G'
    as f_x'_f_x_f_x'_eq_f_x'_id_G'.
  rewrite (assoc G' (inverse G' (hom_f h x)) (hom_f h x) (hom_f h (inverse G x))) in f_x'_f_x_f_x'_eq_f_x'_id_G'.

  rewrite (idR G' (inverse G' (hom_f h x)))
    in f_x'_f_x_f_x'_eq_f_x'_id_G'.
  rename f_x'_f_x_f_x'_eq_f_x'_id_G' into f_x'_f_x_f_x'_eq_f_x'.

  rewrite (invL G' (hom_f h x)) in f_x'_f_x_f_x'_eq_f_x'.
  rename f_x'_f_x_f_x'_eq_f_x' into id_G'_f_x'_eq_f_x'.

  rewrite (idL G' (hom_f h (inverse G x))) in id_G'_f_x'_eq_f_x'.
  rename id_G'_f_x'_eq_f_x' into f_x'_eq_f_x'.
  assumption.
Qed.

Definition kernel (M M' : Type) (G : group M) (G' : group M') (h : hom G G') : set M :=
  fun x => hom_f h x = id G'.
Arguments kernel M M' G G' h /.

Theorem kernel_has_id : forall (M M' : Type) (G : group M) (G' : group M') (h : hom G G'),
  (id G) \in (kernel h).
Proof.
  simpl. intros.
  apply hom_id_map_id.
Qed.

Theorem kernel_is_entire : forall (M M' : Type) (G : group M) (G' : group M') (h : hom G G'),
  forall x y, x \in (kernel h) -> y \in (kernel h) -> (bin G x y) \in (kernel h).
Proof.
  simpl. intros.
  assert (f_xy_eq_fx_fy := hom_law h x y).
  rewrite H in f_xy_eq_fx_fy.
  rewrite H0 in f_xy_eq_fx_fy.
  rename f_xy_eq_fx_fy into f_xy_eq_id_G'_id_G'.

  rewrite (idR G' (id G')) in f_xy_eq_id_G'_id_G'.
  assumption.
Qed.

Theorem kernel_has_inverse : forall (M M' : Type) (G : group M) (G' : group M') (h : hom G G'),
  forall x, x \in (kernel  h) -> (inverse G x) \in (kernel h).
Proof.
  simpl. intros.
  rewrite (hom_inverse_map_inverse h x).
  rewrite H.
  rewrite id_inverse_eq_id.
  reflexivity.
Qed.

Definition image (M M' : Type) (G : group M) (G' : group M') (h : hom G G') : set M' :=
  fun x => exists y, hom_f h y = x.
Arguments image M M' G G' h /.

Theorem image_has_id : forall (M M' : Type) (G : group M) (G' : group M') (h : hom G G'),
  (id G') \in (image h).
Proof.
  simpl. intros.
  exists (id G).
  apply hom_id_map_id.
Qed.

Theorem image_is_entire : forall (M M' : Type) (G : group M) (G' : group M') (h : hom G G'),
  forall x y, x \in (image h) -> y \in (image h) -> (bin G' x y) \in (image h).
Proof.
  simpl.
  intros.
  inversion H as [x1].
  inversion H0 as [y1].
  exists (bin G x1 y1).
  rewrite <- H1.
  rewrite <- H2.
  rewrite (hom_law h).
  reflexivity.
Qed.

Theorem image_has_inverse : forall (M M' : Type) (G : group M) (G' : group M') (h : hom G G'),
  forall x, x \in (image h) -> (inverse G' x) \in (image h).
Proof.
  simpl. intros.
  inversion H.
  exists (inverse G x0).
  rewrite <- H0.
  apply hom_inverse_map_inverse.
Qed.

(* 準同型f: G -> G' に対し、 fが単射である <-> Ker(f) = {id_G} *)

Theorem hom_is_injection_iff_kernel_is_id : forall (M M' : Type) (G : group M) (G' : group M') (h : hom G G'),
  injection (hom_f h) G G' <->
  forall x y, x \in (kernel h) -> y \in (kernel h) -> x = y /\ x = id G.
Proof.
  simpl. intros.
  split.
  - (* -> *)
    intros.
    split.
    +
      rewrite <- H1 in H0.
      apply (H (hom_is_map h) x y H0).
    +
      assert (H2 := hom_id_map_id h).
      rewrite <- H2 in H0.
      apply (H (hom_is_map h) x (id G) H0).
  - (* <- *)
    intros.
    assert (H2 := hom_law h x (inverse G y)).
    rewrite (hom_inverse_map_inverse h y) in H2.
    rewrite H1 in H2.
    rewrite (invR G') in H2.
    assert (H3 := H (bin G x (inverse G y)) (id G) H2 (hom_id_map_id h)).
    inversion H3.
    apply (both_sides_R (bin G)) with (z := y) in H4.
    rewrite <- (assoc G) with (z := y) in H4.
    rewrite (invL G y) in H4.
    rewrite (idR G x) in H4.
    rewrite (idL G y) in H4.
    assumption.
Qed.

Section g_Aut_G_hom.
  Variables M : Type.
  Variables G : group M.
  Definition M' := M -> M.
  Variables G' : group M'.

  Definition i g := fun h:M => bin G (bin G g h) (inverse G g).
  (* i_g h = g h g^(-1) *)
  Arguments i g /.
  Definition f g := i g.  (* f: G -> Aut G
                             f: g |-> i g *)
  Arguments f g /.

  Definition comp (f f' : M') :=
    fun x => f (f' x).
  Arguments comp f f' /.

  Theorem f_is_map : map f G G'.
  Proof.
  Admitted.

  Axiom extensionality : forall (X Y:Type) (x:X) (f g:X->Y),
    f x = g x -> f = g.
  Theorem f_sat_hom_law : forall g1 g2, f (bin G g1 g2) = (comp (f g1) (f g2)).
  Proof.
    simpl.
    intros.
    apply (@extensionality M M g1).
    rewrite (inverse_distributive G g1 g2).
    rewrite <- (assoc G g1 g2 g1).
    rewrite (assoc G (bin G g1 (bin G g2 g1)) (inverse G g2) (inverse G g1)).
    rewrite <- (assoc G g1 (bin G g2 g1) (inverse G g2)).
    reflexivity.
  Qed.
End g_Aut_G_hom.

Section id_is_hom.
  Variables M : Type.
  Variables G : group M.

  Definition id_f := fun x:M => x.

  Theorem id_is_map : map id_f G G.
  Proof.
    simpl. intros.
    unfold id_f.
    assumption.
  Qed.

  Theorem id_sat_hom_law : forall x y,
    id_f (bin G x y) = bin G (id_f x) (id_f y).
  Proof.
    simpl. intros.
    unfold id_f.
    reflexivity.
  Qed.

  Theorem id_is_hom : hom G G.
  Proof.
    apply (Build_hom id_is_map id_sat_hom_law).
  Qed.
End id_is_hom.

Definition kernel_group (M M' : Type) (G : group M) (G' : group M') (h : hom G G') : group M :=
  Build_group
   (kernel_has_id h)
   (@kernel_has_inverse M M' G G' h)
   (@kernel_is_entire M M' G G' h)
   (assoc G)
   (idR G) (idL G)
   (invR G) (invL G).

Theorem kernel_group_is_normal_group : forall (M M' : Type) (G : group M) (G' : group M') (h : hom G G'),
  normalgroup (kernel_group h) G.
Proof.
  simpl. intros.
  rewrite hom_law. rewrite hom_law.
  rewrite H1.
  rewrite idR.
  rewrite hom_inverse_map_inverse.
  rewrite invR.
  reflexivity.
Qed.


Require Import Coq.Program.Tactics.
Require Import CT.Algebra.Magma.
Require Import CT.Algebra.Semigroup.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.

Set Primitive Projections.

Record Monoid {T : Type} :=
  { semigroup :> @Semigroup T;
    one : T;
    monoid_left_one : forall x, semigroup.(magma).(mu) one x = x;
    monoid_right_one : forall x, semigroup.(magma).(mu) x one = x
  }.

Hint Resolve monoid_right_one.
Hint Resolve monoid_left_one.

Fixpoint mu_power {T : Type} (M : @Monoid T) (t : T) (n : nat) :=
  match n with
  | 0 => one M
  | S n => mu M t (mu_power M t n)
  end.

(** ** Monoid identity is unique. *)
Theorem monoid_identity_unique {T} {M : @Monoid T} e :
  (forall x, mu M x e = x) -> e = one M.
Proof.
  intros.
  destruct M.
  simpl in *.
  destruct (H e).
  rewrite <- (H one0).
  rewrite monoid_left_one0.
  trivial.
Qed.

Corollary monoid_identity_commutes {T} {M : @Monoid T} :
  forall a,
    mu M a (one M) = mu M (one M) a.
Proof.
  intros.
  rewrite monoid_left_one.
  rewrite monoid_right_one.
  trivial.
Qed.

(* Possibly separate this out at some point. *)

(** * Monoid homomorphisms.

Magma homomorphisms that also preserve identity.
*)
Record MonoidHomomorphism {A B} (M : @Monoid A) (N : @Monoid B) :=
  { monoid_hom :> @MagmaHomomorphism A B M N;
    monoid_hom_id_law : magma_hom M N monoid_hom (one M) = one N
  }.

(** * Composition of maps. *)
Program Definition monoid_hom_composition
        {T U V : Type}
        {A : @Monoid T}
        {B : @Monoid U}
        {C : @Monoid V}
        (map1 : MonoidHomomorphism A B)
        (map2 : MonoidHomomorphism B C) :
  MonoidHomomorphism A C :=
  {| monoid_hom :=
       {| magma_hom := fun a => (magma_hom B C map2) ((magma_hom A B map1) a)
       |}
  |}.
Next Obligation.
Proof.
  destruct A, B, C, map1, map2.
  simpl in *.
  rewrite magma_hom_law.
  rewrite magma_hom_law.
  trivial.
Qed.
Next Obligation.
  destruct A, B, C, map1, map2.
  simpl in *.
  rewrite monoid_hom_id_law0.
  rewrite monoid_hom_id_law1.
  trivial.
Qed.

(** * Equality of maps, assuming proof irrelevance. *)
Theorem monoid_hom_eq : forall A B F G (M N : MonoidHomomorphism F G),
    @monoid_hom A B F G M = @monoid_hom A B F G N ->
    M = N.
Proof.
  intros.
  destruct M, N.
  simpl in *.
  subst.
  f_equal.
  apply proof_irrelevance.
Qed.

(** * Associativity of composition of maps. *)
Program Definition monoid_hom_composition_assoc
        {T : Type}
        {A B C D : @Monoid T}
        (f : MonoidHomomorphism A B)
        (g : MonoidHomomorphism B C)
        (h : MonoidHomomorphism C D) :
  monoid_hom_composition f (monoid_hom_composition g h) =
  monoid_hom_composition (monoid_hom_composition f g) h.
Proof.
  destruct f, g, h.
  apply monoid_hom_eq.
  simpl.
  f_equal.
  intros.
  apply proof_irrelevance.
  (* There's got to be a better way. *)
Qed.

(** * Identity map. *)
Program Definition monoid_hom_id
        {A : Type}
        {M : @Monoid A} :
  MonoidHomomorphism M M :=
  {| monoid_hom := {| magma_hom := fun a => a |} |}.


Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Arguments nil {X}.
Arguments cons {X}.

Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.
Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.
Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).
Arguments pair {X} {Y}.
Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

(* Our last polymorphic type for now is polymorphic options, which generalize natoption from the previous chapter. *)

Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.
Arguments Some {X}.
Arguments None {X}.

(* We can now rewrite the nth_error function so that it works with any type of lists. *)

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | nil => None
  | a :: l' => match n with
               | O => Some a
               | S n' => nth_error l' n'
               end
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.

(* Exercise hd_error_poly *)
Definition hd_error {X : Type} (l : list X) : option X :=
    match l with
    | nil => None
    | h :: t => Some h
    end.

Check @hd_error : forall X : Type, list X -> option X.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof. reflexivity. Qed.


Require Import List.

Fixpoint nth {A} (l:list A) (i:nat) : option A :=
  match l with
    | nil => None
    | x :: xs => match i with
                   | 0 => Some x
                   | S j => nth xs j
                 end
  end.

Lemma nth_map A B l i (f : A -> B) : nth (map f l) i = option_map f (nth l i).
Proof.
  intros.
  generalize dependent i.
  induction l; intros; simpl. reflexivity.

  destruct i; simpl;auto.
Qed.


(********** EXERCICE 1 **********)
Require Import ZArith.
Open Scope Z_scope.

(* Question 1 *)
Inductive gauss : Set :=
(* | Gauss (a : Z) (b : Z). *)
| Gauss: Z -> Z -> gauss.

Definition g0 := Gauss 0 0.
Definition g1 := Gauss 1 0.
Definition gi := Gauss 0 1.

(* Question 2 *)
Fixpoint conjug_gauss (g : gauss) :=
match g with
| Gauss a b => Gauss a (-b)
end.

Fixpoint add_gauss (x y : gauss) :=
match (x,y) with
| (Gauss a b, Gauss c d) => Gauss (a+c) (b+d)
end.

Fixpoint mult_gauss (x y : gauss) :=
match (x,y) with
| (Gauss a b, Gauss c d) => Gauss (a*c) (b*d)
end.

Definition sub_gauss (x y : gauss) :=
add_gauss x (conjug_gauss y).

(* Question 3 *)
Lemma q3 : forall a : gauss,
add_gauss g0 a = a.
Proof.
intros.
destruct a.
simpl.
reflexivity.
Qed.

(* Question 4 *)
Lemma gauss_plus_comm : forall a b : gauss,
add_gauss a b = add_gauss b a.
Proof.
intros.
destruct a,b.
simpl.
rewrite Zplus_comm.
rewrite (Zplus_comm z0 z2).
reflexivity.
Qed.

Lemma gauss_plus_assoc : forall a b c : gauss,
add_gauss (add_gauss a b) c = add_gauss a (add_gauss b c).
Proof.
intros.
destruct a,b,c.
simpl.
rewrite Zplus_assoc.
rewrite (Zplus_assoc z0 z2 z4).
reflexivity.
Qed.

Lemma gauss_mult_comm : forall a b : gauss,
mult_gauss a b = mult_gauss b a.
Proof.
intros.
destruct a,b.
simpl.
rewrite Zmult_comm.
rewrite (Zmult_comm z0 z2).
reflexivity.
Qed.
Close Scope Z_scope.
(********** EXERCICE 2 **********)
(* Question 1 *)
Inductive jour : Set :=
| Lundi : jour
| Mardi : jour
| Mercredi : jour
| Jeudi : jour
| Vendredi : jour
| Samedi : jour
| Dimanche : jour.

(* Question 2 *)
Definition jour_suivant (j:jour) : jour :=
match j with
| Lundi => Mardi
| Mardi => Mercredi
| Mercredi => Jeudi
| Jeudi => Vendredi
| Vendredi => Samedi
| Samedi => Dimanche
| Dimanche => Lundi
end.

Definition jour_precedent (j:jour) : jour :=
match j with
| Lundi => Dimanche
| Mardi => Lundi
| Mercredi => Mardi
| Jeudi => Mercredi
| Vendredi => Jeudi
| Samedi => Vendredi
| Dimanche => Samedi
end.

(* Question 3 *)
Lemma j_suivant : forall j : jour,
jour_suivant (jour_precedent j) = j.
Proof.
intros.
elim j; simpl; reflexivity.
Qed.

Lemma j_precedent : forall j : jour,
jour_precedent (jour_suivant j) = j.
Proof.
intros.
elim j; simpl; reflexivity.
Qed.

(* Question 4 *)
Fixpoint iter_jour (n:nat) (f:jour -> jour) (j:jour) :=
match n with
| 0 => j
| S m => f (iter_jour m f j)
end.

Lemma iter_jour_j_suivant : forall j : jour,
iter_jour 7 jour_suivant j = j.
Proof.
intros.
elim j; simpl; reflexivity.
Qed.

(* Question 5 *)
Lemma iter_jour_j_precedent : forall j : jour,
iter_jour 7 jour_precedent j = j.
Proof.
intros.
elim j; simpl; reflexivity.
Qed.

(* Question 6 *)
Lemma q6 : forall (n m: nat) (f: jour->jour),
forall j : jour, iter_jour(n+m) f j = iter_jour n f (iter_jour m f j).
Proof.
intros.
induction n.
simpl.
reflexivity.
simpl.
rewrite IHn.
reflexivity.
Qed.

(* Question 7 *)
Require Import Arith.

Lemma iter_jour_j_modulo : forall (n:nat) (j:jour),
iter_jour (7*n) jour_suivant j = j.
Proof.
intros.
induction n.
simpl.
reflexivity.
rewrite mult_comm.
rewrite mult_succ_l.
rewrite q6.
rewrite mult_comm.
rewrite iter_jour_j_suivant.
assumption.
Qed.


From Coq Require Import List Arith.
Import ListNotations.

(* Arithmetic expressions language *)
Inductive expr : Type :=
| Const : nat -> expr
| Plus : expr -> expr -> expr
| Minus : expr -> expr -> expr.

(* Semantics of arithmetic expressions *)
Fixpoint eval (e : expr) : nat :=
  match e with
  | Const n => n
  | Plus e1 e2 => eval e1 + eval e2
  | Minus e1 e2 => eval e1 - eval e2
  end.

(* Stack machine instructions *)
Inductive instr :=
| Push : nat -> instr
| Add
| Sub.

(* Stack programs *)
Definition prog := list instr.

(* Stack *)
Definition stack := list nat.

(* Stack machine semantics *)
Fixpoint run (p : prog) (s : stack) {struct p}: stack :=
  match p with
  | [] => s
  | i :: p' =>
    match i with
    | Push n => run p' (n :: s)
    | Add =>
      match s with
      | a :: b :: s' => run p' (b + a :: s')
      | _ => [] (* if stack underflow -- interrupt
                   execution and return empty stack *)
      end
    | Sub =>
      match s with
      | a :: b :: s' => run p' (b - a :: s')
      | _ => [] (* if stack underflow -- interrupt
                   execution and return empty stack *)
      end
    end
  end.

(* Compilation from arithmetic expressions
   into stack programs *)
Fixpoint compile (e : expr) : prog :=
  match e with
  | Const n => [Push n]
  | Plus e1 e2 =>
    compile e1 ++ compile e2 ++ [Add]
  | Minus e1 e2 =>
    compile e1 ++ compile e2 ++ [Sub]
  end.

Lemma compile_correct' :
  forall (e : expr) (p : prog) (s : stack),
    run p (eval e :: s) = run (compile e ++ p) s.
Proof.
    induction e.

    simpl.
    reflexivity.

    intros.
    simpl.
    rewrite app_assoc_reverse.
    rewrite <- IHe1.
    rewrite app_assoc_reverse.
    rewrite <- IHe2.
    intuition.

    intros.
    simpl.
    rewrite app_assoc_reverse.
    rewrite <- IHe1.
    rewrite app_assoc_reverse.
    rewrite <- IHe2.
    intuition.
Qed.

Theorem compile_correct :
  forall e,
    [eval e] = run (compile e) [].
Proof.
  intros.
  rewrite (app_nil_end (compile e)).
  rewrite <- compile_correct'.
  intuition.
Qed.


Require Import Coq.Program.Basics.

Open Scope program_scope.

(** A binary "multiplication" operation. *)
Class Mappend (A : Type) : Type :=
  mappend : A -> A -> A.

Notation "f ⊗ x" := (mappend f x) (at level 65, left associativity)
                    : monoid_scope.
Open Scope monoid_scope.

(** A semigroup just has an associative binary operation. *)
Class Semigroup (A : Type) `{Mappend A} : Prop :=
  { mappend_assoc : forall x y z, (x ⊗ y) ⊗ z = x ⊗ (y ⊗ z) }.

(** A distinguished element of A. *)
Class Mempty (A : Type) : Type :=
  mempty : A.

(** A monoid is a semigroup in addition to a distinguished element
    which is the left and right unit of the multiplicaton operator. *)
Class Monoid (A : Type) `{Semigroup A} `{Mempty A} : Prop :=
  { mempty_left : forall x, mempty ⊗ x = x
  ; mempty_right : forall x, x ⊗ mempty = x }.

(** Example instances for nat. *)
Require Import NArith.
Instance Mappend_nat : Mappend nat := Nat.add.
Instance Semigroup_nat : Semigroup nat.
Proof. firstorder. Qed.
Instance Mempty_nat : Mempty nat := O.
Instance Monoid_nat : Monoid nat.
Proof. firstorder. Qed.