Require Import init.

Require Import nat_plus.

Require Export mult.

Global Instance nat_mult : Mult nat := {
    mult := fix mult a b :=
        match a with
            | nat_suc a' => b + mult a' b
            | nat_zero => 0
        end
}.

Lemma nat_mult_lanni_tmp : ∀ a, 0 * a = 0.
Proof.
    intros a.
    unfold mult, zero at 1; cbn.
    reflexivity.
Qed.

Global Instance nat_one : One nat := {
    one := nat_suc nat_zero;
}.
Ltac nat_induction n ::=
    induction n;
    change nat_zero with (zero (U := nat)) in *;
    change (nat_suc zero) with (one (U := nat)) in *.
Ltac nat_destruct n ::=
    destruct n;
    change nat_zero with (zero (U := nat)) in *;
    change (nat_suc zero) with (one (U := nat)) in *.

Theorem nat_one_eq : nat_suc 0 = 1.
Proof.
    reflexivity.
Qed.

Global Instance nat_mult_lid : MultLid nat.
Proof.
    split.
    intros a.
    unfold one, mult; cbn.
    apply plus_rid.
Qed.

Theorem nat_mult_lsuc : ∀ a b, nat_suc a * b = b + a * b.
Proof.
    reflexivity.
Qed.
Theorem nat_mult_rsuc : ∀ a b, a * nat_suc b = a + a * b.
Proof.
    intros a b.
    nat_induction a.
    -   do 2 rewrite nat_mult_lanni_tmp.
        rewrite plus_rid.
        reflexivity.
    -   do 2 rewrite nat_mult_lsuc.
        rewrite IHa.
        do 2 rewrite plus_assoc.
        rewrite nat_plus_lsuc.
        rewrite (nat_plus_lsuc a b).
        rewrite (plus_comm a b).
        reflexivity.
Qed.

Global Instance nat_ldist : Ldist nat.
Proof.
    split.
    intros a b c.
    nat_induction a.
    -   do 3 rewrite nat_mult_lanni_tmp.
        rewrite plus_lid.
        reflexivity.
    -   do 3 rewrite nat_mult_lsuc.
        rewrite IHa.
        do 2 rewrite <- plus_assoc.
        apply lplus.
        do 2 rewrite plus_assoc.
        apply rplus.
        apply plus_comm.
Qed.

Global Instance nat_mult_comm : MultComm nat.
Proof.
    split.
    intros a b.
    nat_induction a.
    -   rewrite nat_mult_lanni_tmp.
        rewrite mult_ranni.
        reflexivity.
    -   rewrite nat_mult_lsuc.
        rewrite nat_mult_rsuc.
        rewrite IHa.
        reflexivity.
Qed.

Global Instance nat_mult_assoc : MultAssoc nat.
Proof.
    split.
    intros a b c.
    nat_induction a.
    -   do 3 rewrite mult_lanni.
        reflexivity.
    -   do 2 rewrite nat_mult_lsuc.
        rewrite IHa.
        rewrite rdist.
        reflexivity.
Qed.

Theorem nat_neq_suc_mult : ∀ a b, 0 ≠ nat_suc a * nat_suc b.
Proof.
    intros a b contr.
    rewrite nat_mult_lsuc in contr.
    rewrite nat_plus_lsuc in contr.
    exact (nat_zero_suc contr).
Qed.

Global Instance nat_mult_lcancel : MultLcancel nat.
Proof.
    split.
    intros a b c c_neq eq.
    nat_destruct c; [>contradiction|].
    clear c_neq.
    revert b eq.
    nat_induction a; intros b eq.
    -   nat_destruct b; [>reflexivity|].
        exfalso.
        rewrite mult_ranni in eq.
        exact (nat_neq_suc_mult _ _ eq).
    -   nat_destruct b.
        +   exfalso; clear IHa.
            rewrite mult_ranni in eq.
            symmetry in eq.
            exact (nat_neq_suc_mult _ _ eq).
        +   apply f_equal.
            apply IHa.
            do 2 rewrite nat_mult_rsuc in eq.
            apply plus_lcancel in eq.
            exact eq.
Qed.

#[refine]
Global Instance nat_not_trivial_class : NotTrivial nat := {
    not_trivial_a := 0;
    not_trivial_b := 1;
}.
Proof.
    apply nat_zero_suc.
Qed.


CoInductive CoNat : Set :=
| Zero : CoNat
| Succ : CoNat -> CoNat.

CoFixpoint plus (x: CoNat) (y: CoNat) : CoNat :=
  match x with
    | Zero => y
    | Succ x' => Succ (plus x' y)
  end.

CoInductive CoList : Set :=
| CoNil : CoList
| CoCons : CoNat -> CoList -> CoList.

CoFixpoint sumlen (xs : CoList) : CoNat :=
  match xs with
    | CoNil => Zero
    | CoCons x' xs' => Succ (f x' xs')
  end
with f (n : CoNat) (xs : CoList) : CoNat :=
  match n with
    | Zero => sumlen xs
    | Succ x' => Succ (f x' xs)
  end.

  sumlen [] = Zero
  sumlen (n:xs) = Succ(f xs)
  f Zero xs = sumlen xs
  f (Succ x) xs = Succ(f x xs)


Add LoadPath "." as OPAT.
Require Import OPAT.doit3 OPAT.doit5 OPAT.aula3 OPAT.aula5 OPAT.aula6 OPAT.aula7 OPAT.aula8.

(** **** Exercise: 3 stars (list_exercises)  *)
(** More practice with lists: *)

Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
  intros l. induction l as [ | l l' IHl'].
  - reflexivity.
  - simpl. rewrite IHl'. reflexivity.
Qed.

Theorem rev_app_distr: forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros l1 l2. induction l1 as [ | l l1' IHl1'].
  - simpl. rewrite app_nil_r. reflexivity.
  - simpl. rewrite IHl1'. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l. simpl. induction l as [ | n l1' IHl1'].
  - simpl. reflexivity.
  - simpl. rewrite rev_app_distr. simpl. rewrite IHl1'. reflexivity.
Qed.

(** There is a short solution to the next one.  If you find yourself
    getting tangled up, step back and try to look for a simpler
    way. *)

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros l1 l2 l3 l4. rewrite app_assoc. rewrite app_assoc. reflexivity.
Qed.

(** An exercise about your implementation of [nonzeros]: *)

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2. induction l1 as [ | n l1' IHl1'].
  - reflexivity.
  - destruct n.
      + simpl. rewrite IHl1'. reflexivity.
      + simpl. rewrite IHl1'. reflexivity.
Qed.

(** [] *)

(** **** Exercise: 2 stars (beq_natlist)  *)
(** Fill in the definition of [beq_natlist], which compares
    lists of numbers for equality.  Prove that [beq_natlist l l]
    yields [true] for every list [l]. *)

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Check beq_nat.

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1 with
  | nil => match l2 with
           | nil => true
           | n :: t => false
           end
  | n1 :: t1 => match l2 with
                | nil => false
                | n2 :: t2 => beq_nat n1 n2 && beq_natlist t1 t2
                end
  end.

Example test_beq_natlist1 :
  (beq_natlist nil nil = true).
reflexivity. Qed.

Example test_beq_natlist2 :
  beq_natlist [1;2;3] [1;2;3] = true.
reflexivity. Qed.

Example test_beq_natlist3 :
  beq_natlist [1;2;3] [1;2;4] = false.
reflexivity. Qed.

Lemma beq_nat_refl : forall n:nat,
  true = beq_nat n n.
Proof.
   intros n. induction n.
   - reflexivity.
   - simpl. rewrite IHn. reflexivity.
Qed.

Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
Proof.
  intros l. induction l as [ | n l1' IHl1'].
  - reflexivity.
  - simpl. rewrite <- beq_nat_refl. rewrite <- IHl1'. reflexivity.
Qed.

(** [] *)

(** **** Exercise: 4 stars, advanced (rev_injective)  *)
(** Prove that the [rev] function is injective -- that is,

    forall (l1 l2 : natlist), rev
 l1 = rev l2 -> l1 = l2.

(There is a hard way and an easy way to do this.) *)

Theorem rev_injective : forall (l1 l2 : natlist),
    rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2 p.
  rewrite <- rev_involutive.
  rewrite <- p.
  rewrite rev_involutive.
  reflexivity.
Qed.

(** [] *)


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype bigop path choice finset fingraph.
Require Import automata regexp misc.

Set Implicit Arguments.

Section RE_FA.
  Import Automata.

  Variable char: finType.
  Definition word:= word char.

  Fixpoint re_to_dfa (r: regular_expression char): dfa char :=
    match r with
    | Void => dfa_void char
    | Eps => dfa_eps char
    | Dot => dfa_dot char
    | Atom a => dfa_char char a
    | Star s => nfa_star (dfa_to_nfa (re_to_dfa s))
    | Plus s t => dfa_disj (re_to_dfa s) (re_to_dfa t)
    | And s t => dfa_conj (re_to_dfa s) (re_to_dfa t)
    | Conc s t => nfa_to_dfa (nfa_conc (dfa_to_nfa (re_to_dfa s)) (dfa_to_nfa (re_to_dfa t)))
    | Not s => dfa_compl (re_to_dfa s)
    end.

  Lemma re_to_dfa_correct r: dfa_lang (re_to_dfa r) =i r.
  Proof.
    elim: r => [].

    move => w. apply/idP/idP. exact: dfa_void_correct.

    exact: dfa_eps_correct.

    move => w.
    rewrite -topredE /= /dot.
    exact: dfa_dot_correct.

    move => a.
    move => w. exact: dfa_char_correct.

    (* Star *)
    move => s IHs.
    move => w.
    rewrite nfa_star_correct.
    apply/starP/starP.
      move => [] vv.
      move => H0 H1.
      exists vv.
      erewrite (eq_all).
          eexact H0.
        move => x /=.
        apply/andP/andP; move => [] H2 H3; split => //.
          rewrite -dfa_to_nfa_correct.
          move: H3. by rewrite -IHs.
        move: H3.
        rewrite -dfa_to_nfa_correct.
        by rewrite -IHs.
      exact H1.
    move => [] vv H1 H2. exists vv => //.
    erewrite eq_all. eexact H1.
    move => x /=.
    apply/andb_id2l => H3.
    by rewrite -IHs -dfa_to_nfa_correct.

    move => s Hs t Ht.
    move => w. rewrite -dfa_disj_correct in_simpl /=.
    by rewrite Ht Hs /=.

    move => s Hs t Ht.
    move => w. rewrite -dfa_conj_correct in_simpl /=.
    by rewrite Hs Ht /=.

    move => s Hs t Ht.
    move => w. rewrite -nfa_to_dfa_correct.
    apply/idP/idP.
    move/nfa_conc_aux1 => [] w1 [] w2 /andP [] /andP [] /eqP H0 H1 H2.
    rewrite -topredE /=.
    apply/concP.
    exists w1. by rewrite -Hs -topredE /= dfa_to_nfa_correct' /nfa_lang /= H1.
    exists w2. rewrite /= in H2. by rewrite -Ht dfa_to_nfa_correct in_simpl H2.
    exact H0.
    move/concP => [] w1. rewrite -Hs => H1 [] w2. rewrite -Ht => H2 ->.
    apply/nfa_conc_aux2.
      move: H1. by rewrite  dfa_to_nfa_correct /nfa_lang /=.
    move: H2. by rewrite dfa_to_nfa_correct /nfa_lang /=.

    move => s H.
    move => w. by rewrite -dfa_compl_correct -topredE /= H.
  Qed.

  Definition re_equiv r s := dfa_equiv (re_to_dfa r) (re_to_dfa s).

  Lemma re_equiv_correct r s: re_equiv r s <-> r =i s.
  Proof.
    rewrite dfa_equiv_correct.
    split => H w.
      move/H: (w). by rewrite !re_to_dfa_correct.
    by rewrite !re_to_dfa_correct.
  Qed.

End RE_FA.


Require Import Coq.Lists.List Program Arith NArith Lia.
Import ListNotations.
Require Import SyDPaCC.Support.NList SyDPaCC.Support.List.
Set Implicit Arguments.
Generalizable All Variables.

(** * Tupling, pairing, compose *)

Definition id {A} (x:A) := x.

Definition tupling A B C (f:A->B)(g:A->C) := fun x => (f x, g x).

Definition pairing A B C D (f:A->B)(g:C->D) :=
  fun (pair:A*C) => (f (fst pair), g (snd pair)).

Definition compose A B C (g : B -> C) (f : A -> B) : A->C :=
  fun x => g (f x).

Declare Scope sydpacc_scope.

Infix "△" := tupling (at level 41, left associativity) : sydpacc_scope.

Infix "×" := pairing (at level 41, left associativity) : sydpacc_scope.

Global Infix "∘" := compose (at level 40, left associativity) : sydpacc_scope.

#[export] Hint Unfold compose pairing tupling id : sydpacc.

Open Scope sydpacc_scope.

(*-----------------------------------------------------------------*)

(** * Induction on Lists Seen as Join-Lists *)

(** A Join-List is either:
    - an empty list,
    - a singleton list,
    - the concatenation of two lists.
    the empty list and concatenation form a monoid. *)

Lemma joinlist_induction :
  forall A, forall P : list A -> Prop,
      (P nil) ->
      (forall a, P [a]) ->
      (forall x y , P x -> P y -> P (x++y)) ->
      forall l,  P l.
Proof.
  intros A P Hnil Hsingleton Hconcat l.
  induction l as [ | a x IH ].
  - trivial.
  - replace (a::x) with ([a]++x) by reflexivity.
    now apply Hconcat.
Qed.

(*-----------------------------------------------------------------*)

(** * Algebraic Properties Defined as Coq Typeclasses *)

(** ** Unit *)
Class LeftNeutral A B (op: B -> A -> A) (e : B) :=
  {
    left_neutral  : forall a, op e a = a
  }.

Class RightNeutral A B (op: A -> B -> A) (e : B) :=
  {
    right_neutral : forall a, op a e =  a
  }.

Class Neutral A (op: A -> A -> A) (e : A) :=
  {
    neutral_left_neutral  :>  LeftNeutral  op e;
    neutral_right_neutral :>  RightNeutral op e
  }.

(** ** Associativity  *)
Class  Associative A (op:A->A->A) :=
  {
    associative : forall (x y z: A), op (op x y) z = op x (op y z)
  }.

(** ** Commutativity  *)
Class Commutative A (op:A->A->A) :=
  {
    commutative : forall (x y: A), op  x y = op y x
  }.

(** ** Monoid *)
Class Monoid A (op : A->A->A) (e : A) :=
  {
    monoid_assoc   :> Associative op;
    monoid_neutral :> Neutral op e
  }.

(** ** Distributivity *)
Class Distributivity  A (otimes:A->A->A) (oplus:A->A->A) :=
  {
    left_distributivity :
      forall x y z,
        otimes x (oplus y z) =  oplus (otimes x y) (otimes x z);

    right_distributivity :
      forall x y z,
        otimes (oplus y z) x = oplus (otimes y x) (otimes z x)
  }.

(** ** Instances *)

#[export] Instance app_associative (A:Type) : Associative (@List.app A).
Proof.
  constructor. intros.
  now rewrite app_assoc.
Qed.

#[export] Instance app_neutral (A:Type) : Neutral (@List.app A) [].
  repeat constructor; apply app_nil_r.
Qed.

#[export] Instance plus_neutral (A:Type) : Neutral plus 0.
  repeat constructor; auto with arith.
Qed.

#[export] Instance plus_associative : Associative plus.
  constructor; auto with arith.
Qed.

#[export] Instance andb_monoid: Monoid andb true.
Proof.
  repeat constructor.
  - intros; now rewrite Bool.andb_assoc.
  - intros; now rewrite Bool.andb_true_r.
Qed.

(*-----------------------------------------------------------------*)

(** * Optimization of Arbitrary Functions *)

Class Opt A B (f g:A->B) :=
  {
    opt_eq: forall a, f a = g a
  }.

Class Opt2 A B C (f g:A->B->C) :=
  {
    opt2_eq: forall a b, f a b = g a b
  }.

(*-----------------------------------------------------------------*)

(** * Properties of Folds *)

Lemma fold_left_prop A (f:A->A->A) {H:Associative f} :
  forall l (a b:A), fold_left f l (f a b) = f a (fold_left f l b).
Proof.
  induction l as [ | x xs IH ].
  - intros. trivial.
  - intros a b. simpl.
    repeat rewrite IH.
    now rewrite <- (associative a).
Qed.

Lemma fold_right_prop A (f:A->A->A) {H:Associative f} :
  forall l a b, fold_right f (f a b) l = f (fold_right f a l) b.
Proof.
  induction l as [ | x xs IH ].
  - trivial.
  - intros a b. simpl.
    rewrite IH.
    now rewrite associative.
Qed.

Lemma fold_left_map_r:
  forall A B C (f:A->B->A) (g :C->B) (l:list C) (a:A),
    fold_left (fun a b => f a (g b)) l a = fold_left f (map g l) a.
Proof.
  induction l as [ | a l IHl]; intro.
  - reflexivity.
  - simpl; rewrite IHl; reflexivity.
Qed.

Lemma fold_right_map_l:
  forall A B C (f:B->A->A) (g:C->B) (l:list C) (a:A),
    fold_right (fun a b => f (g a) b) a l = fold_right f a (map g l).
Proof.
  induction l as [ | a l IHl]; intros.
  - reflexivity.
  - simpl.  f_equal; rewrite IHl; reflexivity.
Qed.

(** * [fold_left2] and Properties *)

Fixpoint fold_left2 A B C (op:C->A*B->C) (e:C) (l1:list A) (l2:list B): C :=
  match (l1, l2) with
  | ([], _ ) | (_ , []) => e
  | (h1::t1, h2::t2) =>
    fold_left2 op (op e (h1,h2)) t1 t2
  end.

Lemma fold_left2_prop1:
  forall A B C (op:C->A*B->C) e l1 l2,
    fold_left op (combine l1 l2) e = fold_left2 op e l1 l2.
Proof.
  intros A B C op e l1 l2; revert e l2;
    induction l1 as [ | h1 t1 IH1]; intros e l2; destruct l2 as [ | h2 t2 ].
  - trivial.
  - trivial.
  - trivial.
    - simpl; now rewrite IH1.
Qed.

Lemma fold_left2_prop2:
  forall A A' B C op (f:A*B->A') (e:C) l1 l2,
    fold_left op (map f (combine l1 l2)) e = fold_left2 (fun u p =>op u (f p))  e l1 l2.
Proof.
  intros A A' B C op f e l1 l2; revert e l2;
    induction l1 as [ | h1 t1 IH1]; intros e l2; destruct l2 as [ | h2 t2 ]; trivial.
  simpl; now rewrite IH1.
Qed.

(*-------------------------------------------------------------*)

(** * Prefixes of a Lists and its Properties *)

Fixpoint prefix `(xs:list A) :=
  match xs with
    | [] => [[]]
    | x::xs => []::(map (cons x) (prefix xs))
  end.

Example prefix_informal :
  prefix ([1;2;3])%nat =  ([[]; [1]; [1; 2]; [1; 2; 3]])%nat.
Proof. trivial. Qed.

Lemma prefix_snoc (A:Type) :
  forall (xs:list A)(x:A),
    prefix (xs++[x]) = prefix xs ++ (map (app xs) [[x]]).
Proof.
  induction xs as [ | x' xs' IH].
  - trivial.
  - intro x. simpl.
    now rewrite IH, map_app.
Qed.

Lemma prefix_app (A:Type) :
  forall (l l':list A),
    prefix (l ++ l') = prefix l ++ tl(map (app l) (prefix l')).
Proof.
  intros l l'; revert l.
  induction l'.
  - intros l'. simpl; repeat rewrite app_nil_r. trivial.
  - intros l.
    change ( a :: l') with ([a]++l').
    rewrite app_assoc.
    rewrite IHl', prefix_snoc, IHl', map_app.
    simpl.
    rewrite <- app_assoc.
    destruct(prefix l') eqn:Heq.
    + trivial.
    + simpl; rewrite map_map.
    do 2 f_equal. apply map_ext.
    intros. now rewrite <- app_assoc.
Qed.

Lemma prefix_map:
  forall A B (f:A->B) xs,
    prefix(map f xs) = map (map f)(prefix xs).
Proof.
  intros A B f; induction xs as [ | x xs IH].
  - trivial.
  - simpl; now rewrite IH, map_map, map_map.
Qed.

Lemma prefix_length (A:Type) :
  forall (l:list A), List.length (prefix l) = S (List.length l).
Proof.
  induction l; simpl; try rewrite List.map_length; now f_equal.
Qed.

Lemma prefix_contains_nil :
  forall `(l:list A), exists l', prefix l = [] :: l'.
Proof.
  induction l as [ | h t IH ].
  - now eexists.
  - inversion IH. simpl. eexists. f_equal.
Qed.

#[export] Hint Rewrite prefix_length : length.

(*-----------------------------------------------------------------*)

(** * Definition and Properties of Prefix Sum Computations *)

Fixpoint scanl A B (op:A->B->A)(e:A)(l:list B) : list A :=
  e::match l with
     | []   => []
     | h::t => scanl op (op e h) t
     end.

Example scanl_example  : scanl plus 0 [1;2;3] = [0; 0+1 ; 0+1+2 ; 0+1+2+3].
Proof. reflexivity. Qed.

Lemma scanl_spec:
  forall A B (op:A->B->A) (e:A) (l : list B),
  scanl op e l =
  map (fun l => fold_left op l e) (prefix l).
Proof.
  intros A B op e l; revert op e ; induction l as [ | h t IH].
  - trivial.
  - intros op e; simpl.
    now rewrite IH, map_map.
Qed.

Lemma scanl_snoc:
  forall A B (op:A->B->A) (e:A) (l : list B) (b:B),
    scanl op e (l ++ [ b ]) = scanl op e l ++ [ fold_left op (l++[b]) e ].
Proof.
  intros A B op e l; revert e; induction l as [ | h t IH]; intros e b.
  - trivial.
  - simpl. now rewrite IH.
Qed.

Fact scanl_cons:
  forall A B (op:A->B->A) (e:A) (l : list B),
    scanl op e l = e::tl(scanl op e l).
Proof.
  intros A B op e l; destruct l; auto.
Qed.

Lemma scanl_map_gen:
  forall A B `{Monoid A op}(xs:list B) (q:B->A) c,
    scanl (fun s t=>op s (q t)) c xs = map (op c)(scanl (fun s t=>op s (q t)) e xs).
Proof.
  intros A B op e H xs q c; revert e c H.
  induction xs as [ | x' xs' IH ]; intros e c H.
  - simpl; now rewrite right_neutral.
  - simpl.
    rewrite IH with (e:=e) by typeclasses eauto.
    rewrite @right_neutral with (e:=e) by typeclasses eauto.
    rewrite @left_neutral with (a:=q x') (e:=e) by typeclasses eauto.
    rewrite IH with (c:=q x')(e:=e) by typeclasses eauto.
    rewrite map_map.
    f_equal; apply map_ext; intro; now rewrite associative.
Qed.

Lemma scanl_map:
  forall `{Associative A op} e (x:A)(xs:list A),
    scanl op (op x e) xs = map (op x)(scanl op e xs).
  intros A op H e x xs. revert e x. induction xs as [ | x' xs' IH ].
  - intros; simpl; do 2 f_equal.
  - intros e x; simpl. f_equal.
    rewrite <- IH. f_equal.
    now rewrite associative.
Qed.

Lemma map_scanl:
  forall A B `{Monoid A op}(q:B->A) a c,
    scanl op c (map q a) =
    scanl (fun (s : A) (t : B) => op s (q t)) c a.
Proof.
  intros A B op e H q a c.
  repeat rewrite scanl_spec.
  rewrite prefix_map, map_map.
  apply map_ext; intro x.
  symmetry. apply fold_left_map_r.
Qed.

Lemma scanl_length:
  forall (A B:Type)(op:A->B->A)(identity:A)(l:list B),
    List.length (scanl op identity l) = S (List.length l).
Proof.
  intros A B op identity l; generalize dependent identity; induction l as [ | h t IHl]; intros.
  - trivial.
  - simpl; now rewrite IHl.
Qed.

#[export] Hint Rewrite scanl_length : length.

Fixpoint scanl_aux A B (op:A->B->A)(e:A)(l:list B)(res:list A) : list A :=
  match l with
  | [] => rev' (e::res)
  | h::t => scanl_aux op (op e h) t (e::res)
  end.

Definition scanl' A B (op:A->B->A)(e:A)(l:list B) : list A :=
  scanl_aux op e l [].

#[export] Hint Unfold scanl' : sydpacc.

Fact scanl_aux_scanl:
  forall A B (op:A->B->A) e l l',
    scanl_aux op e l l' =
    rev' l' ++ scanl op e l.
Proof.
  intros A B op e l l'; revert e l';
    induction l as [ | h t IH ]; intros e l'.
  - simpl. unfold rev'. simpl.
    rewrite rev_append_rev.
    now rewrite rev_alt.
  - simpl; rewrite IH.
    unfold rev'; simpl.
    rewrite rev_append_rev.
    now rewrite rev_alt, <- List.app_assoc.
Qed.

Lemma scanl_scanl':
  forall A B (op:A->B->A) e l,
    scanl op e l = scanl' op e l.
Proof.
  intros A B op e l; revert e; induction l as [ | h t IH ]; intro e.
  - trivial.
  - autounfold with sydpacc. simpl.
    now rewrite scanl_aux_scanl.
Qed.

Unset Implicit Arguments.

Definition scan A (op:A->A->A) `{Monoid A op e} (l : list A):= scanl op e l.

Arguments scan [A] op {e} {_}.

Set Implicit Arguments.

#[export] Hint Unfold scan : sydpacc.

Fact scan_spec:
  forall A `(Monoid A op e) (l : list A),
  scan op l =
  map (fun l => fold_left op l e) (prefix l).
Proof.
  autounfold; intros; apply scanl_spec.
Qed.

Lemma scan_length:
  forall (A B : Type)`(Monoid A op e)(l:list A),
    List.length (scan op l) = S(List.length l).
Proof.
  autounfold; intros; apply scanl_length.
Qed.

#[export] Hint Rewrite scan_length : length.

Lemma scan_map:
  forall  `{Monoid A op e} (x:A)(xs:list A),
    scan op (x::xs) = e::(map (op x) (scan op xs)).
Proof.
  intros A op e H x xs.
  autounfold with sydpacc; simpl.
  rewrite <- scanl_map.
  do 2 f_equal.
  now rewrite left_neutral, right_neutral.
Qed.

Fixpoint scanl_last A B (op:A->B->A)(e:A)(l:list B) : list A * A :=
  match l with
    | []   => ([], e)
    | h::t =>
      let result := scanl_last op (op e h) t in
      (e::fst result, snd result)
  end.

Fixpoint scanl_last_aux A B (op:A->B->A)(e:A)(l:list B) acc_l : list A * A :=
  match l with
  | [] => (List.rev' acc_l, e)
  | h::t => scanl_last_aux op (op e h) t (e::acc_l)
  end.

Definition scanl_last' A B (op:A->B->A)(e:A)(l:list B) : list A * A :=
  scanl_last_aux op e l [].

Lemma scanl_last_scanl_last_aux:
  forall A B (l:list B)(op:A->B->A)(e:A) acc,
    ((List.rev' acc)++(fst(scanl_last op e l)), snd(scanl_last op e l)) =
    scanl_last_aux op e l acc.
Proof.
  induction l as [ | h t IH]; intros op e acc.
  - simpl; f_equal; now rewrite right_neutral.
  - simpl; rewrite <- IH; unfold rev'; rewrite List.rev_append_rev; simpl;
      rewrite List.rev_append_rev; f_equal.
    now repeat rewrite associative.
Qed.

Lemma scanl_last_scanl_last':
  forall A B (l:list B)(op:A->B->A)(e:A),
    scanl_last op e l = scanl_last' op e l.
Proof.
  intros A B l op e; unfold scanl_last'.
  rewrite <- scanl_last_scanl_last_aux; simpl.
  apply surjective_pairing.
Qed.

Lemma scanl_last_fst_scanl:
  forall (A B:Type)(op:A->B->A)(e:A)(l:list B),
    fst (scanl_last op e l) = removelast (scanl op e l).
Proof.
  intros A B op e l; revert e; induction l as [|x xs IH].
  - trivial.
  - intro e; simpl; rewrite IH.
    destruct(scanl op (op e x) xs) eqn:H.
    + assert (List.length(scanl op (op e x) xs) = S (List.length xs)) as Hlen
          by apply scanl_length.
      rewrite H in Hlen; simpl in Hlen; discriminate.
    + trivial.
Qed.

Lemma scanl_scanl_last:
  forall (A B:Type)(op:A->B->A)(e:A)(l:list B),
    scanl op e l = (fst (scanl_last op e l))++[snd(scanl_last op e l)].
Proof.
  intros A B op e l; revert e; induction l as [|x xs IH]; intro e.
  - trivial.
  - simpl; f_equal; now rewrite IH.
Qed.

Lemma scanl_last_snd:
  forall (A B:Type)(op:A->B->A)(e:A)(l:list B),
    snd (scanl_last op e l) = List.fold_left op l e.
Proof.
  intros A B op e l; revert e; induction l as [|x xs IH].
  - trivial.
  - intro e; simpl; rewrite IH; trivial.
Qed.

Lemma list_last_scanl:
  forall A B (op:A->B->A) e xs d,
    last(scanl op e xs) d = snd(scanl_last op e xs).
Proof.
  intros A B op e xs d.
  transitivity (last(fst (scanl_last op e xs)++[snd(scanl_last op e xs)]) d).
  - now rewrite scanl_scanl_last.
  - apply list_last_app.
Qed.

Lemma scanl_not_nil: forall A B (op:A->B->A) e l, scanl op e l <> [].
Proof.
  destruct l; autounfold with sydpacc; simpl; intros; discriminate.
Qed.

Lemma scanl_app_gen:
  forall A B `{Monoid A op e} (q:B->A) c (l1 l2 : list B),
    let op' := fun x y=>op x (q y) in
    scanl op' c (l1++l2) =
    removelast(scanl op' c l1) ++ map (op (List.last (scanl op' c l1) e)) (scanl op' e l2).
Proof.
  intros A B op e H q; revert H; revert e.
    induction l1 as [ | x xs IH ] using rev_ind; intros l2 op'.
  - simpl; unfold op'; now rewrite scanl_map_gen with (e:=e) by typeclasses eauto.
  - rewrite associative, IH by auto; simpl.
    rewrite scanl_snoc, removelast_app by (intro Heq; discriminate).
    simpl; rewrite app_nil_r, list_last_app; simpl.
    rewrite @right_neutral with (op:=op) by typeclasses eauto.
    rewrite app_removelast_last with (l:=scanl op' c xs)(d:=e) by (apply scanl_not_nil).
    rewrite associative; simpl.
    do 2 f_equal.
    assert(List.last (scanl op' c xs) e =
           List.fold_left op' xs c) as HH
      by now erewrite <- scanl_last_snd, <- list_last_scanl.
    fold op'. rewrite HH; clear HH.
    rewrite fold_left_app; simpl.
    generalize (fold_left op' xs e); intro a.
    replace (op e (q x)) with (op' e x) by (now unfold op').
    replace (op' e x) with (q x) by now (unfold op'; rewrite left_neutral).
    assert(forall x, scanl op' x l2 = map (op x) (scanl op' e l2)) as HH.
    {
      induction l2; intros x0.
      - simpl; f_equal; now rewrite  right_neutral.
      - simpl; f_equal.
        + now rewrite  right_neutral.
        + rewrite IHl2 with (x:=op' e a0).
          rewrite IHl2.
          rewrite map_map.
          apply map_ext; intros; unfold op'; simpl.
          rewrite associative, @left_neutral with(e:=e) by typeclasses eauto.
          trivial.
    }
    rewrite HH; rewrite map_map; apply map_ext; intro.
    unfold op'. now rewrite associative.
Qed.

Lemma scanl_app:
  forall `{Monoid A op e} (l1 l2 : list A),
    scanl op e (l1++l2) =
    removelast(scanl op e l1) ++ map (op (List.last (scanl op e l1) e)) (scanl op e l2).
Proof.
  intros A op e H l1 l2.
  now apply scanl_app_gen.
Qed.

Open Scope N_scope.

Lemma scanl_nlength:
  forall (A B:Type)(op:A->B->A)(identity:A)(l:list B),
    length (scanl op identity l) = N.succ (length l).
Proof.
  intros A B op identity l; generalize dependent identity; induction l; intros.
  - trivial.
  - simpl; rewrite IHl; simpl; trivial.
Qed.

Arguments scanl_nlength [A B].

#[export] Hint Rewrite scanl_nlength : length.

Lemma scanl_fold:
  forall (A B:Type)(op:A->B->A)(identity:A)(l:list B)(index:N)(default:A),
    ( index < 1 + length l) ->
    nth index (scanl op identity l) default =
        List.fold_left op (firstn index l) identity.
Proof.
  intros A B op identity l index default valid_index;
    generalize dependent identity; generalize dependent index; induction l as [ | a l IHl ].
  - intros index valid_index identity;
      rewrite firstn_nil; simpl in *; destruct index; trivial.
    lia.
  - intros index valid_index identity; simpl; destruct index; simpl.
    + trivial.
    + rewrite IHl; trivial.
      rewrite length_cons in valid_index.
      rewrite N.pos_pred_spec.
      assert(N.pred (1+ (1+length l)) = 1 + length l) as H
        by (now rewrite N.add_1_l, N.pred_succ).
      rewrite <- H.
      apply N.pred_lt_mono in valid_index; auto.
      clear; intro H; discriminate.
Qed.

Fixpoint scan' {A B:Type}(op:A->B->A)(identity:A)(l:list B) : list A :=
  match l with
    | []   => []
    | h::t =>let id := (op identity h) in id::scan' op id t
  end.

Lemma scan'_length:
  forall (A B : Type)(op:A->B->A)(identity:A)(l:list B),
    length (scan' op identity l) = length l.
Proof.
  intros A B op identity l; generalize dependent identity; induction l as [ | a l IHl ].
  - intros; trivial.
  - intros; simpl; rewrite IHl; simpl; trivial.
Qed.

#[export] Hint Rewrite scan_length : length.

Lemma scan_fold:
  forall (A B:Type)(op:A->B->A)(identity:A)(l:list B)(default:A) (index:N),
    index < length l ->
    nth index (scan' op identity l) default =
    List.fold_left op (firstn (1+index) l) identity.
Proof.
  intros A B op identity l default index validIndex;
    generalize dependent identity; generalize dependent index; induction l.
  - intros; rewrite firstn_nil; simpl in *; destruct index; trivial;
    lia.
  - intros index validIndex identity; destruct index.
    + simpl; rewrite firstn_equation; trivial.
    + rewrite firstn_equation.
      destruct(1 + N.pos p) eqn:Heq.
      * lia.
      * simpl; rewrite IHl.
        -- repeat f_equal. repeat rewrite N.pos_pred_spec; rewrite <- Heq.
           rewrite N.add_pred_r; auto; lia.
        -- rewrite N.pos_pred_spec. rewrite length_cons in validIndex.
           apply N.pred_lt_mono in validIndex; trivial.
           rewrite N.add_1_l in validIndex.
           now rewrite N.pred_succ in  validIndex.
           clear; intro H; lia.
Qed.

(*-----------------------------------------------------------------*)

(** * Reduce on Arbitrary Lists and Properties *)

Definition reduce A (op:A -> A -> A) `{Monoid A op e} :=
  fun l => fold_left op l e.

Arguments reduce [A] op {e }{_}.

Set Implicit Arguments.

Lemma reduce_eq:
  forall A (op:A->A->A) (e:A) `{Monoid A op e} (x:A) (xs:list A),
    reduce op (x::xs) = op x (reduce op xs).
Proof.
  intros A op e H x xs.
  unfold reduce; simpl.
  replace (op e x) with (x) by now rewrite left_neutral.
  rewrite <- fold_left_prop.
  + f_equal; now rewrite right_neutral.
  + typeclasses eauto.
Qed.

Lemma reduce_app:
  forall A (op:A->A->A)`{m: Monoid A op e} (l1 l2:list A),
    reduce op (l1 ++ l2) = op (reduce op l1) (reduce op l2).
Proof.
  intros A op e m l1 l2. unfold reduce.
  now rewrite fold_left_app, <- fold_left_prop, right_neutral
    by typeclasses eauto.
Qed.

(*-----------------------------------------------------------------*)

(** * Homomorphic Functions and List Homomorphisms *)

Class Homomorphic `(h:list A->B) `(op:B->B->B) :=
  { homomorphic : forall x y, h (x++y) = op (h x) (h y) }.

(** ** Image of a List Function  *)

Definition img `(h:list A->B) := { b:B | exists l, h l = b }.

(*-----------------------------------------------------------------*)

(** ** [h] homomorphic -> homomophism on the image of [h] *)

Definition to_img A B (h:list A->B)(xs:list A) : img h.
  exists(h xs).
  now eexists.
Defined.

Definition of_img `{h:list A->B}(x:img h) : B :=
  proj1_sig x.

Lemma to_img_prop :
  forall A B {h:list A->B}(xs ys:list A),
    xs = ys -> to_img h xs = to_img h ys.
Proof.
  intros A B h xs ys Heq.
  rewrite Heq.
  reflexivity.
Qed.

Lemma norm :
  forall A B {h:list A->B}(b:img h), exists xs, b = to_img h xs.
Proof.
  intros A B h b.
  destruct b as [b [xs Hb]].
  exists xs.
  rewrite <- Hb.
  now apply to_img_prop.
Qed.

Lemma img_op:
  forall A B (h:list A->B)(op:B->B->B)
         (hom:Homomorphic h op)(b1 b2:B),
    (exists xs1, h xs1 = b1) ->
    (exists xs2, h xs2 = b2) ->
    (exists xs, h xs = op b1 b2).
Proof.
  intros A B h op hom b1 b2
         [xs1 Hb1] [xs2 Hb2].
  rewrite <- Hb1, <- Hb2, <- homomorphic.
  exists (xs1++xs2).
  reflexivity.
Defined.

Unset Implicit Arguments.
Program Definition restrict_op `(op:B->B->B) `{Homomorphic A B h op} :
  img h -> img h -> img h := op.
Next Obligation.
  destruct x as [x [lx Hx]]; destruct x0 as [y [ly Hy]].
  apply img_op.
  - trivial.
  - eexists; eassumption.
  - eexists; eassumption.
Defined.
Set Implicit Arguments.

Program Definition restrict `{Homomorphic A B h op}
        `(Eq: forall a b : img h,  op' a b = proj1_sig (restrict_op op a b) ) :
  img h -> img h -> img h := op'.
Next Obligation.
  destruct x as [x [lx Hx]]; destruct x0 as [y [ly Hy]].
  rewrite Eq; simpl; apply img_op.
  - trivial.
  - eexists; eassumption.
  - eexists; eassumption.
Defined.

Lemma restrict_to_img:
  forall `{hom:Homomorphic A B h op}
         `(Eq: forall a b : img h, op' a b = proj1_sig(restrict_op op a b))
         (xs ys:list A),
    restrict Eq (to_img h xs)(to_img h ys) =
    to_img h (xs++ys).
Proof.
  intros A B h op hom op' Eq xs ys.
  unfold restrict, restrict_obligation_1, to_img; simpl.
  destruct hom as [hom].
  rewrite Eq; simpl; rewrite <- hom.
  reflexivity.
Qed.

#[export] Program Instance homomorphic_restrict_assoc `{Homomorphic A B h op}
        `(Eq: forall a b : img h, op' a b = proj1_sig(restrict_op op a b)) :
  Associative (restrict Eq).
Next Obligation.
  destruct (norm x) as [xs1 Hb1].
  destruct (norm y) as [xs2 Hb2].
  destruct (norm z) as [xs3 Hb3].
  subst.
  repeat rewrite restrict_to_img.
  apply to_img_prop.
  now rewrite associative.
Qed.

#[export] Program Instance homomorphic_restrict_neutral `{Homomorphic A B h op}
        `(Eq: forall a b : img h, op' a b = proj1_sig(restrict_op op a b)) :
  Neutral (restrict Eq) (to_img h []).
Next Obligation.
  constructor; intro x.
  destruct (norm x) as [xs Hx]; subst.
  rewrite restrict_to_img; now apply to_img_prop.
Qed.
Next Obligation.
  constructor; intro x.
  destruct (norm x) as [xs Hx]; subst.
  rewrite restrict_to_img.
  apply to_img_prop.
  apply app_nil_r.
Qed.

#[export] Program Instance homomorphic_restrict_monoid `{Homomorphic A B h op}
        `(Eq: forall a b : img h, op' a b = ` (restrict_op op a b)) :
  Monoid (A:=(img h)) (restrict Eq) (h []).

(** ** Optimization of Homomophisms *)

Unset Implicit Arguments.
Class Optimised_f `(h:list A->B)`{H:Homomorphic A B h op} :=
  {
    optimised_f_sig: { f: A->B | forall a, f a = h[a] }
  }.

Class Optimised_op `(h:list A->B)`{H:Homomorphic A B h op} :=
  {
    optimised_op_sig: {op':(img h)->(img h)->B|forall a b, op' a b = op (` a) (` b) }
  }.

Program Definition optimised_f `(h:list A->B) `{Ho:Optimised_f A B h} : A -> img h :=
  optimised_f_sig (h:=h).
Next Obligation.
  rewrite (proj2_sig optimised_f_sig).
  now eexists.
Defined.

Definition optimised_op `(h:list A->B)`{H:Optimised_op A B h}: img h -> img h -> img h.
  intros a b.
  apply (exist _ ((` optimised_op_sig) a b)).
  destruct a as [a [la Ha]], b as [b [lb Hb]].
  rewrite (proj2_sig optimised_op_sig); simpl.
  rewrite <- Ha, <- Hb, <- homomorphic.
  now eexists.
Defined.
Set Implicit Arguments.

#[export] Instance non_optimised_f `{Homomorphic A B h op} : Optimised_f h.
Proof. constructor. eexists. reflexivity. Qed.

#[export] Instance non_optimised_op `{Homomorphic A B h op} : Optimised_op h.
Proof. constructor. eexists. reflexivity. Qed.

(*-----------------------------------------------------------------*)

(** ** Homomophism Theorems *)

Unset Implicit Arguments.
Definition hom_to_map_reduce {A B:Type}(h:list A->B)
           `{H:Homomorphic A B h op}
           `{@Optimised_op A B h op H}`{@Optimised_f A B h op H} :
  list A -> img h :=
  (reduce (optimised_op h)) ∘ (List.map (optimised_f h)).
Set Implicit Arguments.

(** *** First Homomophism Theorem *)

Theorem first_homomorphism_theorem:
  forall `{H:Homomorphic A B h op}`{@Optimised_op A B h op H}`{@Optimised_f A B h op H},
  forall l, h l = of_img (hom_to_map_reduce h l).
Proof.
  unfold hom_to_map_reduce.
  intros A B h op hom opt_op opt_f l; induction l as [ | x xs IH ].
  - reflexivity.
  - autounfold with sydpacc in *; unfold of_img in *; simpl in *.
    replace (optimised_f h x :: map (optimised_f h) xs)
    with ([optimised_f h x] ++ map (optimised_f h) xs) by trivial.
    rewrite reduce_app ; simpl.
    rewrite (proj2_sig optimised_op_sig), <- IH; simpl.
    rewrite (proj2_sig optimised_op_sig); simpl.
    rewrite (proj2_sig optimised_f_sig); simpl.
    now repeat rewrite <- homomorphic.
Qed.

Class Rightwards `(h:list A->B)`(op:B->A->B)`(e:B) :=
  { rightwards: forall l, h l = List.fold_left op l e }.

Class Leftwards `(h:list A->B)`(op:A->B->B)`(e:B) :=
  { leftwards: forall l, h l = List.fold_right op e l }.

(** *** Third Homomophism Theorem *)

Class Right_inverse `(h:list A ->B)(h':B->list A) :=
  { right_inverse: forall l, h l = h(h'(h l)) }.

Lemma hom_characterisation:
  forall `(h:list A->B)`{Right_inverse A B h h'},
    (exists op, forall x y, h (x++y) = op (h x) (h y)) <->
    (forall x y v w, h x = h v -> h y = h w -> h(x ++ y) = h(v ++ w)).
Proof.
  intros A B h h' Hinv. split; intro H.
  - intros x y v w Hxv Hyw.
    destruct H as [op Hh].
    repeat rewrite Hh.
    rewrite Hxv, Hyw.
    trivial.
  - exists(fun l r=>h((h' l)++(h' r))).
    intros x y.
    erewrite H; try reflexivity; apply right_inverse.
Qed.

#[export] Instance third_homomorphism_theorem_right_inverse
         `{h:list A->B}`{inv:Right_inverse A B h h'}
         `{Hl:Leftwards A B h opl e} `{Hr:Rightwards A B h opr e} :
  Homomorphic h (fun l r =>h( (h' l)++(h' r))).
Proof.
  constructor; intros x y.
  assert(exists op, forall x y, h (x++y) = op (h x) (h y)) as Hom.
  {
    eapply hom_characterisation; try eassumption.
    intros x0 y0 v w H0 H1.
    rewrite leftwards.
    rewrite fold_right_app.
    rewrite <- (leftwards y0), H1. rewrite (@leftwards _ _ _ _ _ Hl).
    rewrite <- fold_right_app.
    rewrite <- leftwards.
    rewrite rightwards.
    rewrite fold_left_app.
    rewrite <-(rightwards x0), H0, (@rightwards _ _ _ _ _ Hr).
    rewrite <- fold_left_app.
    rewrite <- rightwards.
    trivial.
  }
  destruct Hom as [op Hh].
  repeat rewrite Hh.
  repeat rewrite <- right_inverse.
  trivial.
Qed.

(*-----------------------------------------------------------------*)

(** * A Typeclass to Characterize Empty Lists *)

Class NonEmpty `(l:list A) := { non_emptiness : l<> [] }.

Ltac empty :=
  let H := fresh "Hempty" in
  assert(H:=non_emptiness); contradict H; trivial.

(** ** Instances *)

#[export] Program Instance cons_non_empty
        `(x:A)(xs:list A) : NonEmpty (x::xs).

#[export] Program Instance map_non_empty
        `(f:A->B)(xs:list A){HNE:NonEmpty xs} :
  NonEmpty (map f xs).
Next Obligation.
  destruct xs.
  - empty.
  - intro H. discriminate.
Qed.

Lemma eq_non_empty :
  forall {A:Type}{l1 l2:list A}{HNE:NonEmpty l1}(Eq:l1=l2), NonEmpty l2.
Proof.
  constructor; intro H; subst; destruct HNE as [HNE]; now contradict HNE.
Qed.

#[export] Instance app_non_empty_l
         {A:Type}(l1 l2:list A){HNE:NonEmpty l1} : NonEmpty (l1++l2).
Proof.
  constructor; destruct HNE as [HNE]; contradict HNE.
  now apply app_eq_nil in HNE.
Qed.

#[export] Instance app_non_empty_r
         {A:Type}(l1 l2:list A){HNE:NonEmpty l2} : NonEmpty (l1++l2).
Proof.
  constructor; destruct HNE as [HNE]; contradict HNE.
  now apply app_eq_nil in HNE.
Qed.

Lemma non_empty_cons `{NonEmpty A xs} :
  exists x' xs', xs = x' :: xs'.
Proof.
  destruct xs as [ | x' xs'].
  - empty.
  - exists x'. now exists xs'.
Qed.

#[export] Instance length_lt_0_NonEmpty `(Hlt: (0 < n)%N) `{l:{l:list A | length l = n}} :
  NonEmpty (proj1_sig l).
Proof.
  destruct l as [ [ | h t] Hl ]; simpl in *.
  - lia.
  - typeclasses eauto.
Qed.

(*---------------------------------------------------------------*)

(** ** Reduce on Non-empty Lists and Properties *)

Module NE.

  Unset Implicit Arguments.
  Definition reduce `(op:A->A->A)`{HA:Associative A op}
             (l:list A){HNE:NonEmpty l} : A.
    destruct l as [|x xs].
    - apply False_rect. now apply HNE.
    - exact(fold_left op xs x).
  Defined.

  Lemma reduce_app:
    forall `(op:A->A->A)`{HA:Associative A op}
           (l1 l2:list A){HNE1:NonEmpty l1}{HNE1:NonEmpty l2},
      reduce op (l1++l2) = op (reduce op l1) (reduce op l2).
  Proof.
    intros A op Hassoc; induction l1; intros l2 HNE1 HNE2.
    - inversion HNE1; intuition.
    - destruct l2; simpl.
      + inversion HNE2; intuition.
      + rewrite fold_left_app. simpl.
        now rewrite fold_left_prop.
  Qed.

  Lemma reduce_pi:
    forall `(op:A->A->A)`{HA:Associative A op}
           (l1 l2:list A){HNE:NonEmpty l1}{HNE:NonEmpty l2}(H:l1=l2),
      reduce op l1 = reduce op l2.
  Proof.
    intros A op Hassoc; induction l1; intros l2 HNE1 HNE2 H.
    - inversion HNE1; intuition.
    - destruct l2; inversion HNE2; intuition.
      now inversion H; subst.
  Qed.

  Lemma reduce_fold_left:
    forall `(op:A->A->A)`{HA:Associative A op} x xs,
      reduce op (x::xs) = fold_left op xs x.
    induction xs; trivial.
  Qed.
  Set Implicit Arguments.

End NE.

(*-------------------------------------------------------------*)

(** ** Compositions Taking into Account Non-emptyness *)

Program Definition comp'
        `(f:forall l:list B, NonEmpty l->C)`(g:list A->list B)
        {HNE:forall a, NonEmpty a -> NonEmpty(g a)} :
  forall l:list A, NonEmpty l -> C :=
  fun a H => f (g a) (HNE a H).

Program Definition comp''
        `(f:forall l:list B, NonEmpty l->C)`(g:A->list B)
        {HNE:forall a, NonEmpty(g a)} : A -> C :=
  fun a => f (g a) (HNE a).

Infix "∘'" := comp' (at level 30).
Infix "∘''" := comp'' (at level 30).

(** ** [last] on NonEmpty lists *)

Unset Implicit Arguments.

Program Definition hd A (l:list A) `{NonEmpty A l} : A :=
  match l with
  | [ ] => _
  | h::t => h
  end.
Next Obligation.
  inversion H; contradiction.
Defined.

Arguments hd [A] l { _ }.

Definition last A (l:list A) `{NonEmpty A l} : A :=
  List.last l (hd l).

Arguments last [A] l { _ }.

#[export] Hint Unfold last : sydpacc.

Set Implicit Arguments.

(** ** Properties of [List.last] and [last] *)

Lemma list_last_non_empty:
  forall A l (d:A) d',
    NonEmpty l ->
    List.last l d = List.last l d'.
Proof.
  intros A; induction l as [ | x xs IH]; intros d d' H.
  - inversion H; contradiction.
  - simpl; destruct xs; trivial.
    apply IH.
    typeclasses eauto.
Qed.

Lemma list_last_app:
  forall A (xs:list A) x d,
    List.last (xs++[x]) d = x.
Proof.
  intros A; induction xs; intros x d.
  - now compute.
  - simpl; destruct(xs ++ [x]) eqn:H; symmetry in H.
    + apply app_cons_not_nil in H; now exfalso.
    + destruct xs; inversion H; subst; auto.
      rewrite app_comm_cons; apply IHxs.
Qed.

Lemma last_pi:
  forall A l l' Hl Hl',
    l = l' ->
    @last A l Hl = @last A l' Hl'.
Proof.
  intros A l l' Hl Hl' H.
  autounfold with sydpacc; f_equal; auto.
  destruct l.
  - inversion Hl; contradiction.
  - destruct l'.
    + inversion Hl'; contradiction.
    + inversion H; subst.
      auto.
Qed.

Lemma last_cons_non_empty:
  forall `{NonEmpty A xs} x,
    last (x::xs) = last xs.
Proof.
  intros A xs H x. revert  x.
  induction xs; autounfold with sydpacc in *; simpl; intro x.
  - inversion H; contradiction.
  - simpl in IHxs. destruct xs.
    + trivial.
    + simpl in *. specialize (IHxs (cons_non_empty a0 xs)).
      rewrite IHxs. symmetry. now rewrite IHxs.
Qed.

Lemma last_app:
  forall A (xs:list A) x,
    last (xs++[x]) = x.
Proof.
  intros A xs x; unfold last.
  apply list_last_app.
Qed.

Lemma last_map:
  forall A B (f:A->B) `{NonEmpty A l},
    last (map f l) = f (last l).
Proof.
  intros A B f; induction l as [ | h t IH ]; intros H.
  - inversion H; contradiction.
  - destruct t; simpl.
    + trivial.
    + erewrite last_pi by reflexivity; rewrite last_cons_non_empty.
      simpl in IH; specialize (IH _);
        erewrite last_pi in IH by reflexivity.
      rewrite IH.
      f_equal; symmetry;
        erewrite last_pi at 1 by reflexivity.
      apply last_cons_non_empty.
Qed.

Lemma removelast_length:
  forall A (l:list A), List.length(removelast l) = pred(List.length l).
Proof.
  intros A l;induction l as [ | h t IH ].
  - trivial.
  - destruct t as [ | a t ].
    + trivial.
    + replace (h::a::t) with ([h]++(a::t)) by auto.
      rewrite removelast_app by (intro HH; discriminate).
      repeat rewrite List.app_length.
      now rewrite IH by typeclasses eauto.
Qed.
Lemma removelast_length_N:
  forall `(l:list A),
    length(removelast l) = N.pred(length l).
Proof.
  intros A; induction l as [ | h t IH ].
  - trivial.
  - destruct t.
    + trivial.
    + replace (h::a::t) with ([h]++(a::t)) by auto.
      rewrite removelast_app by (intro HH; discriminate).
      autorewrite with length. rewrite IH by typeclasses eauto.
      repeat rewrite N.add_1_l; simpl.
      now repeat rewrite N.pred_succ.
Qed.

#[export] Hint Rewrite @removelast_length @removelast_length_N : length.

Lemma fst_scanl_last_length:
  forall (A B:Type)(op:A->B->A)(e:A)(l:list B),
    List.length(fst (scanl_last op e l)) = List.length l.
Proof.
  intros A B op e l.
  rewrite scanl_last_fst_scanl.
  now autorewrite with length.
Qed.

#[export] Hint Rewrite fst_scanl_last_length : length.

#[export] Instance prefix_non_empty `(xs:list A) : NonEmpty (prefix xs).
Proof.
  constructor; intro H; destruct xs; simpl; discriminate.
Qed.

Lemma prefix_last:
  forall `(l:list A) {H: NonEmpty l}, prefix l = prefix (removelast l) ++ [l].
Proof.
  induction l as [ | x xs IH] using rev_ind; intro HnonEmpty.
  - empty.
  - rewrite prefix_snoc.
    destruct xs as [ | x' xs] using rev_ind.
    + trivial.
    + rewrite removelast_app by (intro H; discriminate).
      now rewrite app_nil_r.
Qed.

Lemma scanl_removelast:
  forall A B (op:A->B->A) e `{ NonEmpty B l},
    removelast (scanl op e l) = scanl op e (removelast l).
Proof.
  intros A B op e l H; revert e; induction l as [ | h t IH ]; intro e.
  - empty.
  - destruct t.
    + trivial.
    + set(t':=b::t) in *.
      replace (scanl op e (h::t')) with ([ e ] ++ scanl op (op e h) t') by auto.
      replace (h::t') with ([h]++t') by auto.
      rewrite removelast_app by apply non_emptiness.
      rewrite removelast_app by (unfold t'; apply non_emptiness).
      now rewrite IH by (unfold t'; typeclasses eauto).
Qed.

#[export] Instance scanl_non_empty A B (op:A->B->A) e l : NonEmpty (scanl op e l).
Proof.
  constructor; now apply scanl_not_nil.
Qed.

Fact scanl_hd:
  forall A B (op:A->B->A) e l,
    hd (scanl op e l) = e.
Proof.
  intros A B op e l; now destruct l.
Qed.

#[export] Instance scanl'_non_empty A B (op:A->B->A) e l : NonEmpty (scanl' op e l).
Proof.
  rewrite <- scanl_scanl'.
  typeclasses eauto.
Qed.

#[export] Instance scan_non_empty A `{Monoid A op e} l : NonEmpty (scan op l).
Proof.
  destruct l; autounfold; simpl; constructor; intros; discriminate.
Qed.

Lemma last_scanl:
  forall A B (op:A->B->A) e xs,
    last(scanl op e xs) = snd(scanl_last op e xs).
Proof.
  intros A B op e xs.
  transitivity (last(fst (scanl_last op e xs)++[snd(scanl_last op e xs)])).
  - apply last_pi, scanl_scanl_last.
  - apply last_app.
Qed.

Close Scope N_scope.

Close Scope sydpacc_scope.


Require Import bool.
Require Import list.
Require Import In.

Fixpoint filter (a:Type) (test: a -> bool) (l:list a) : list a :=
    match l with
    | []        => []
    | x::xs     => if test x then x::filter a test xs else filter a test xs
    end.

Arguments filter {a} _ _.

Lemma filter_of_false : forall (a:Type) (test:a -> bool) (l:list a),
    (forall x, In x l -> test x = false) -> filter test l = [].
Proof.
    intros a test l H. revert H. induction l as [|x xs IH].
    - intros _. reflexivity.
    - intros H. assert (test x = false) as Hx. { apply H. left. reflexivity. }
        simpl. rewrite Hx. apply IH. intros y H'. apply H. right. exact H'.
Qed.

Lemma filter_of_true : forall (a:Type) (test:a -> bool) (l:list a),
    (forall x, In x l -> test x = true) -> filter test l = l.
Proof.
    intros a test l H. revert H. induction l as [|x xs IH].
    - intros _. reflexivity.
    - intros H. assert (test x = true) as Hx. { apply H. left. reflexivity. }
        simpl. rewrite Hx. assert (filter test xs = xs) as H0.
            { apply IH. intros y H'. apply H. right. exact H'. }
        rewrite H0. reflexivity.
Qed.

Lemma filter_all_true : forall (a:Type) (test:a -> bool) (l:list a),
    forall x, In x (filter test l) -> test x = true.
Proof.
    intros a test l. induction l as [|x xs IH].
    - intros x H. inversion H.
    - intros y H. simpl in H. destruct (test x) eqn:Hx.
        + destruct H as [H|H].
            { rewrite <- H. exact Hx. }
            { apply IH. exact H. }
        + apply IH. exact H.
Qed.


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

Set Implicit Arguments.

Require Export Notations.

Notation "A -> B" := (forall (_ : A), B) : type_scope.

(** * Propositional connectives *)

(** [True] is the always true proposition *)

Inductive True : Prop :=
  I : True.

(** [False] is the always false proposition *)
Inductive False : Prop :=.

(** [not A], written [~A], is the negation of [A] *)
Definition not (A:Prop) := A -> False.

Notation "~ x" := (not x) : type_scope.

(** Create the "core" hint database, and set its transparent state for
  variables and constants explicitely. *)

Create HintDb core.
Hint Variables Opaque : core.
Hint Constants Opaque : core.

Hint Unfold not: core.

  (** [and A B], written [A /\ B], is the conjunction of [A] and [B]

      [conj p q] is a proof of [A /\ B] as soon as
      [p] is a proof of [A] and [q] a proof of [B]

      [proj1] and [proj2] are first and second projections of a conjunction *)

Inductive and (A B:Prop) : Prop :=
  conj : A -> B -> A /\ B

where "A /\ B" := (and A B) : type_scope.

Section Conjunction.

  Variables A B : Prop.

  Theorem proj1 : A /\ B -> A.
  Proof.
    destruct 1; trivial.
  Qed.

  Theorem proj2 : A /\ B -> B.
  Proof.
    destruct 1; trivial.
  Qed.

End Conjunction.

(** [or A B], written [A \/ B], is the disjunction of [A] and [B] *)

Inductive or (A B:Prop) : Prop :=
  | or_introl : A -> A \/ B
  | or_intror : B -> A \/ B

where "A \/ B" := (or A B) : type_scope.

Arguments or_introl [A B] _, [A] B _.
Arguments or_intror [A B] _, A [B] _.

(** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *)

Definition iff (A B:Prop) := (A -> B) /\ (B -> A).

Notation "A <-> B" := (iff A B) : type_scope.

Section Equivalence.

Theorem iff_refl : forall A:Prop, A <-> A.
  Proof.
    split; auto.
  Qed.

Theorem iff_trans : forall A B C:Prop, (A <-> B) -> (B <-> C) -> (A <-> C).
  Proof.
    intros A B C [H1 H2] [H3 H4]; split; auto.
  Qed.

Theorem iff_sym : forall A B:Prop, (A <-> B) -> (B <-> A).
  Proof.
    intros A B [H1 H2]; split; auto.
  Qed.

End Equivalence.

Hint Unfold iff: extcore.

(** Backward direction of the equivalences above does not need assumptions *)

Theorem and_iff_compat_l : forall A B C : Prop,
  (B <-> C) -> (A /\ B <-> A /\ C).
Proof.
  intros ? ? ? [Hl Hr]; split; intros [? ?]; (split; [ assumption | ]);
  [apply Hl | apply Hr]; assumption.
Qed.

Theorem and_iff_compat_r : forall A B C : Prop,
  (B <-> C) -> (B /\ A <-> C /\ A).
Proof.
  intros ? ? ? [Hl Hr]; split; intros [? ?]; (split; [ | assumption ]);
  [apply Hl | apply Hr]; assumption.
Qed.

Theorem or_iff_compat_l : forall A B C : Prop,
  (B <-> C) -> (A \/ B <-> A \/ C).
Proof.
  intros ? ? ? [Hl Hr]; split; (intros [?|?]; [left; assumption| right]);
  [apply Hl | apply Hr]; assumption.
Qed.

Theorem or_iff_compat_r : forall A B C : Prop,
  (B <-> C) -> (B \/ A <-> C \/ A).
Proof.
  intros ? ? ? [Hl Hr]; split; (intros [?|?]; [left| right; assumption]);
  [apply Hl | apply Hr]; assumption.
Qed.

Theorem imp_iff_compat_l : forall A B C : Prop,
  (B <-> C) -> ((A -> B) <-> (A -> C)).
Proof.
  intros ? ? ? [Hl Hr]; split; intros H ?; [apply Hl | apply Hr]; apply H; assumption.
Qed.

Theorem imp_iff_compat_r : forall A B C : Prop,
  (B <-> C) -> ((B -> A) <-> (C -> A)).
Proof.
  intros ? ? ? [Hl Hr]; split; intros H ?; [apply H, Hr | apply H, Hl]; assumption.
Qed.

Theorem not_iff_compat : forall A B : Prop,
  (A <-> B) -> (~ A <-> ~B).
Proof.
  intros; apply imp_iff_compat_r; assumption.
Qed.

(** Some equivalences *)

Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False).
Proof.
  intro A; unfold not; split.
  - intro H; split; [exact H | intro H1; elim H1].
  - intros [H _]; exact H.
Qed.

Theorem and_cancel_l : forall A B C : Prop,
  (B -> A) -> (C -> A) -> ((A /\ B <-> A /\ C) <-> (B <-> C)).
Proof.
  intros A B C Hl Hr.
  split; [ | apply and_iff_compat_l]; intros [HypL HypR]; split; intros.
  + apply HypL; split; [apply Hl | ]; assumption.
  + apply HypR; split; [apply Hr | ]; assumption.
Qed.

Theorem and_cancel_r : forall A B C : Prop,
  (B -> A) -> (C -> A) -> ((B /\ A <-> C /\ A) <-> (B <-> C)).
Proof.
  intros A B C Hl Hr.
  split; [ | apply and_iff_compat_r]; intros [HypL HypR]; split; intros.
  + apply HypL; split; [ | apply Hl ]; assumption.
  + apply HypR; split; [ | apply Hr ]; assumption.
Qed.

Theorem and_comm : forall A B : Prop, A /\ B <-> B /\ A.
Proof.
  intros; split; intros [? ?]; split; assumption.
Qed.

Theorem and_assoc : forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C.
Proof.
  intros; split; [ intros [[? ?] ?]| intros [? [? ?]]]; repeat split; assumption.
Qed.

Theorem or_cancel_l : forall A B C : Prop,
  (B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)).
Proof.
  intros ? ? ? Fl Fr; split; [ | apply or_iff_compat_l]; intros [Hl Hr]; split; intros.
  { destruct Hl; [ right | destruct Fl | ]; assumption. }
  { destruct Hr; [ right | destruct Fr | ]; assumption. }
Qed.

Theorem or_cancel_r : forall A B C : Prop,
  (B -> ~ A) -> (C -> ~ A) -> ((B \/ A <-> C \/ A) <-> (B <-> C)).
Proof.
  intros ? ? ? Fl Fr; split; [ | apply or_iff_compat_r]; intros [Hl Hr]; split; intros.
  { destruct Hl; [ left | | destruct Fl ]; assumption. }
  { destruct Hr; [ left | | destruct Fr ]; assumption. }
Qed.

Theorem or_comm : forall A B : Prop, (A \/ B) <-> (B \/ A).
Proof.
  intros; split; (intros [? | ?]; [ right | left ]; assumption).
Qed.

Theorem or_assoc : forall A B C : Prop, (A \/ B) \/ C <-> A \/ B \/ C.
Proof.
  intros; split; [ intros [[?|?]|?]| intros [?|[?|?]]].
  + left; assumption.
  + right; left; assumption.
  + right; right; assumption.
  + left; left; assumption.
  + left; right; assumption.
  + right; assumption.
Qed.
Lemma iff_and : forall A B : Prop, (A <-> B) -> (A -> B) /\ (B -> A).
Proof.
  intros A B []; split; trivial.
Qed.

Lemma iff_to_and : forall A B : Prop, (A <-> B) <-> (A -> B) /\ (B -> A).
Proof.
  intros; split; intros [Hl Hr]; (split; intros; [ apply Hl | apply Hr]); assumption.
Qed.

(** [(IF_then_else P Q R)], written [IF P then Q else R] denotes
    either [P] and [Q], or [~P] and [R] *)

Definition IF_then_else (P Q R:Prop) := P /\ Q \/ ~ P /\ R.

Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3)
  (at level 200, right associativity) : type_scope.

(** * First-order quantifiers *)

(** [ex P], or simply [exists x, P x], or also [exists x:A, P x],
    expresses the existence of an [x] of some type [A] in [Set] which
    satisfies the predicate [P].  This is existential quantification.

    [ex2 P Q], or simply [exists2 x, P x & Q x], or also
    [exists2 x:A, P x & Q x], expresses the existence of an [x] of
    type [A] which satisfies both predicates [P] and [Q].

    Universal quantification is primitively written [forall x:A, Q]. By
    symmetry with existential quantification, the construction [all P]
    is provided too.
*)

Inductive ex (A:Type) (P:A -> Prop) : Prop :=
  ex_intro : forall x:A, P x -> ex (A:=A) P.

Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop :=
  ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q.

Definition all (A:Type) (P:A -> Prop) := forall x:A, P x.

(* Rule order is important to give printing priority to fully typed exists *)

Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q))
  (at level 200, x ident, p at level 200, right associativity) : type_scope.
Notation "'exists2' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q))
  (at level 200, x ident, A at level 200, p at level 200, right associativity,
    format "'[' 'exists2'  '/  ' x  :  A ,  '/  ' '[' p  &  '/' q ']' ']'")
  : type_scope.

Notation "'exists2' ' x , p & q" := (ex2 (fun x => p) (fun x => q))
  (at level 200, x strict pattern, p at level 200, right associativity) : type_scope.
Notation "'exists2' ' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q))
  (at level 200, x strict pattern, A at level 200, p at level 200, right associativity,
    format "'[' 'exists2'  '/  ' ' x  :  A ,  '/  ' '[' p  &  '/' q ']' ']'")
  : type_scope.

(** Derived rules for universal quantification *)

Section universal_quantification.

  Variable A : Type.
  Variable P : A -> Prop.

  Theorem inst : forall x:A, all (fun x => P x) -> P x.
  Proof.
    unfold all; auto.
  Qed.

  Theorem gen : forall (B:Prop) (f:forall y:A, B -> P y), B -> all P.
  Proof.
    red; auto.
  Qed.

End universal_quantification.

(** * Equality *)

(** [eq x y], or simply [x=y] expresses the equality of [x] and
    [y]. Both [x] and [y] must belong to the same type [A].
    The definition is inductive and states the reflexivity of the equality.
    The others properties (symmetry, transitivity, replacement of
    equals by equals) are proved below. The type of [x] and [y] can be
    made explicit using the notation [x = y :> A]. This is Leibniz equality
    as it expresses that [x] and [y] are equal iff every property on
    [A] which is true of [x] is also true of [y] *)

Inductive eq (A:Type) (x:A) : A -> Prop :=
    eq_refl : x = x :>A

where "x = y :> A" := (@eq A x y) : type_scope.

Notation "x = y" := (x = y :>_) : type_scope.
Notation "x <> y  :> T" := (~ x = y :>T) : type_scope.
Notation "x <> y" := (x <> y :>_) : type_scope.

Arguments eq {A} x _.
Arguments eq_refl {A x} , [A] x.

Arguments eq_ind [A] x P _ y _.
Arguments eq_rec [A] x P _ y _.
Arguments eq_rect [A] x P _ y _.

Hint Resolve I conj or_introl or_intror : core.
Hint Resolve eq_refl: core.
Hint Resolve ex_intro ex_intro2: core.

Section Logic_lemmas.

  Theorem absurd : forall A C:Prop, A -> ~ A -> C.
  Proof.
    unfold not; intros A C h1 h2.
    destruct (h2 h1).
  Qed.

  Section equality.
    Variables A B : Type.
    Variable f : A -> B.
    Variables x y z : A.

    Theorem eq_sym : x = y -> y = x.
    Proof.
      destruct 1; trivial.
    Defined.

    Theorem eq_trans : x = y -> y = z -> x = z.
    Proof.
      destruct 2; trivial.
    Defined.

    Theorem f_equal : x = y -> f x = f y.
    Proof.
      destruct 1; trivial.
    Defined.

    Theorem not_eq_sym : x <> y -> y <> x.
    Proof.
      red; intros h1 h2; apply h1; destruct h2; trivial.
    Qed.

  End equality.

  Definition eq_ind_r :
    forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y.
    intros A x P H y H0. elim eq_sym with (1 := H0); assumption.
  Defined.

  Definition eq_rec_r :
    forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y.
    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
  Defined.

  Definition eq_rect_r :
    forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y = x -> P y.
    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
  Defined.
End Logic_lemmas.

Module EqNotations.
  Notation "'rew' H 'in' H'" := (eq_rect _ _ H' _ H)
    (at level 10, H' at level 10,
     format "'[' 'rew'  H  in  '/' H' ']'").
  Notation "'rew' [ P ] H 'in' H'" := (eq_rect _ P H' _ H)
    (at level 10, H' at level 10,
     format "'[' 'rew'  [ P ]  '/    ' H  in  '/' H' ']'").
  Notation "'rew' <- H 'in' H'" := (eq_rect_r _ H' H)
    (at level 10, H' at level 10,
     format "'[' 'rew'  <-  H  in  '/' H' ']'").
  Notation "'rew' <- [ P ] H 'in' H'" := (eq_rect_r P H' H)
    (at level 10, H' at level 10,
     format "'[' 'rew'  <-  [ P ]  '/    ' H  in  '/' H' ']'").
  Notation "'rew' -> H 'in' H'" := (eq_rect _ _ H' _ H)
    (at level 10, H' at level 10, only parsing).
  Notation "'rew' -> [ P ] H 'in' H'" := (eq_rect _ P H' _ H)
    (at level 10, H' at level 10, only parsing).

End EqNotations.

Import EqNotations.

Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a.
Proof.
intros.
destruct H.
reflexivity.
Defined.

Lemma rew_opp_l : forall A (P:A->Type) (x y:A) (H:x=y) (a:P x), rew <- H in rew H in a = a.
Proof.
intros.
destruct H.
reflexivity.
Defined.

Theorem f_equal2 :
  forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1)
    (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
Proof.
  destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal3 :
  forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1)
    (x2 y2:A2) (x3 y3:A3),
    x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3.
Proof.
  destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal4 :
  forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B)
    (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
    x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4.
Proof.
  destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal5 :
  forall (A1 A2 A3 A4 A5 B:Type) (f:A1 -> A2 -> A3 -> A4 -> A5 -> B)
    (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4) (x5 y5:A5),
    x1 = y1 ->
    x2 = y2 ->
    x3 = y3 -> x4 = y4 -> x5 = y5 -> f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5.
Proof.
  destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal_compose : forall A B C (a b:A) (f:A->B) (g:B->C) (e:a=b),
  f_equal g (f_equal f e) = f_equal (fun a => g (f a)) e.
Proof.
  destruct e. reflexivity.
Defined.

(** The groupoid structure of equality *)

Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e.
Proof.
  destruct e. reflexivity.
Defined.

Theorem eq_trans_refl_r : forall A (x y:A) (e:x=y), eq_trans e eq_refl = e.
Proof.
  destruct e. reflexivity.
Defined.

Theorem eq_sym_involutive : forall A (x y:A) (e:x=y), eq_sym (eq_sym e) = e.
Proof.
  destruct e; reflexivity.
Defined.

Theorem eq_trans_sym_inv_l : forall A (x y:A) (e:x=y), eq_trans (eq_sym e) e = eq_refl.
Proof.
  destruct e; reflexivity.
Defined.

Theorem eq_trans_sym_inv_r : forall A (x y:A) (e:x=y), eq_trans e (eq_sym e) = eq_refl.
Proof.
  destruct e; reflexivity.
Defined.

Theorem eq_trans_assoc : forall A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t),
  eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e''.
Proof.
  destruct e''; reflexivity.
Defined.

(** Extra properties of equality *)

Theorem eq_id_comm_l : forall A (f:A->A) (Hf:forall a, a = f a), forall a, f_equal f (Hf a) = Hf (f a).
Proof.
  intros.
  unfold f_equal.
  rewrite <- (eq_trans_sym_inv_l (Hf a)).
  destruct (Hf a) at 1 2.
  destruct (Hf a).
  reflexivity.
Defined.

Theorem eq_id_comm_r : forall A (f:A->A) (Hf:forall a, f a = a), forall a, f_equal f (Hf a) = Hf (f a).
Proof.
  intros.
  unfold f_equal.
  rewrite <- (eq_trans_sym_inv_l (Hf (f (f a)))).
  set (Hfsymf := fun a => eq_sym (Hf a)).
  change (eq_sym (Hf (f (f a)))) with (Hfsymf (f (f a))).
  pattern (Hfsymf (f (f a))).
  destruct (eq_id_comm_l f Hfsymf (f a)).
  destruct (eq_id_comm_l f Hfsymf a).
  unfold Hfsymf.
  destruct (Hf a). simpl.
  rewrite eq_trans_refl_l.
  reflexivity.
Defined.

Lemma eq_refl_map_distr : forall A B x (f:A->B), f_equal f (eq_refl x) = eq_refl (f x).
Proof.
  reflexivity.
Qed.

Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e').
Proof.
destruct e'.
reflexivity.
Defined.

Lemma eq_sym_map_distr : forall A B (x y:A) (f:A->B) (e:x=y), eq_sym (f_equal f e) = f_equal f (eq_sym e).
Proof.
destruct e.
reflexivity.
Defined.

Lemma eq_trans_sym_distr : forall A (x y z:A) (e:x=y) (e':y=z), eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e).
Proof.
destruct e, e'.
reflexivity.
Defined.

Lemma eq_trans_rew_distr : forall A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x),
    rew (eq_trans e e') in k = rew e' in rew e in k.
Proof.
  destruct e, e'; reflexivity.
Qed.

Lemma rew_const : forall A P (x y:A) (e:x=y) (k:P),
    rew [fun _ => P] e in k = k.
Proof.
  destruct e; reflexivity.
Qed.

(* Aliases *)

Notation sym_eq := eq_sym (only parsing).
Notation trans_eq := eq_trans (only parsing).
Notation sym_not_eq := not_eq_sym (only parsing).

Notation refl_equal := eq_refl (only parsing).
Notation sym_equal := eq_sym (only parsing).
Notation trans_equal := eq_trans (only parsing).
Notation sym_not_equal := not_eq_sym (only parsing).

Hint Immediate eq_sym not_eq_sym: core.

(** Basic definitions about relations and properties *)

Definition subrelation (A B : Type) (R R' : A->B->Prop) :=
  forall x y, R x y -> R' x y.

Definition unique (A : Type) (P : A->Prop) (x:A) :=
  P x /\ forall (x':A), P x' -> x=x'.

Definition uniqueness (A:Type) (P:A->Prop) := forall x y, P x -> P y -> x = y.

(** Unique existence *)

Notation "'exists' ! x .. y , p" :=
  (ex (unique (fun x => .. (ex (unique (fun y => p))) ..)))
  (at level 200, x binder, right associativity,
   format "'[' 'exists'  !  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Lemma unique_existence : forall (A:Type) (P:A->Prop),
  ((exists x, P x) /\ uniqueness P) <-> (exists! x, P x).
Proof.
  intros A P; split.
  - intros ((x,Hx),Huni); exists x; red; auto.
  - intros (x,(Hx,Huni)); split.
    + exists x; assumption.
    + intros x' x'' Hx' Hx''; transitivity x.
      symmetry; auto.
      auto.
Qed.

Lemma forall_exists_unique_domain_coincide :
  forall A (P:A->Prop), (exists! x, P x) ->
  forall Q:A->Prop, (forall x, P x -> Q x) <-> (exists x, P x /\ Q x).
Proof.
  intros A P (x & Hp & Huniq); split.
  - intro; exists x; auto.
  - intros (x0 & HPx0 & HQx0) x1 HPx1.
    assert (H : x0 = x1) by (transitivity x; [symmetry|]; auto).
    destruct H.
    assumption.
Qed.

Lemma forall_exists_coincide_unique_domain :
  forall A (P:A->Prop),
  (forall Q:A->Prop, (forall x, P x -> Q x) <-> (exists x, P x /\ Q x))
  -> (exists! x, P x).
Proof.
  intros A P H.
  destruct H with (Q:=P) as ((x & Hx & _),_); [trivial|].
  exists x. split; [trivial|].
  destruct H with (Q:=fun x'=>x=x') as (_,Huniq).
  apply Huniq. exists x; auto.
Qed.

(** * Being inhabited *)

(** The predicate [inhabited] can be used in different contexts. If [A] is
    thought as a type, [inhabited A] states that [A] is inhabited. If [A] is
    thought as a computationally relevant proposition, then
    [inhabited A] weakens [A] so as to hide its computational meaning.
    The so-weakened proof remains computationally relevant but only in
    a propositional context.
*)

Inductive inhabited (A:Type) : Prop := inhabits : A -> inhabited A.

Hint Resolve inhabits: core.

Lemma exists_inhabited : forall (A:Type) (P:A->Prop),
  (exists x, P x) -> inhabited A.
Proof.
  destruct 1; auto.
Qed.

Lemma inhabited_covariant (A B : Type) : (A -> B) -> inhabited A -> inhabited B.
Proof.
  intros f [x];exact (inhabits (f x)).
Qed.

(** Declaration of stepl and stepr for eq and iff *)

Lemma eq_stepl : forall (A : Type) (x y z : A), x = y -> x = z -> z = y.
Proof.
  intros A x y z H1 H2. rewrite <- H2; exact H1.
Qed.

Declare Left Step eq_stepl.
Declare Right Step eq_trans.

Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B).
Proof.
  intros ? ? ? [? ?] [? ?]; split; intros; auto.
Qed.

Declare Left Step iff_stepl.
Declare Right Step iff_trans.

Local Notation "'rew' 'dependent' H 'in' H'"
  := (match H with
      | eq_refl => H'
      end)
       (at level 10, H' at level 10,
        format "'[' 'rew'  'dependent'  '/    ' H  in  '/' H' ']'").

(** Equality for [ex] *)
Section ex.
  Local Unset Implicit Arguments.
  Definition eq_ex_uncurried {A : Type} (P : A -> Prop) {u1 v1 : A} {u2 : P u1} {v2 : P v1}
             (pq : exists p : u1 = v1, rew p in u2 = v2)
  : ex_intro P u1 u2 = ex_intro P v1 v2.
  Proof.
    destruct pq as [p q].
    destruct q; simpl in *.
    destruct p; reflexivity.
  Qed.

  Definition eq_ex {A : Type} {P : A -> Prop} (u1 v1 : A) (u2 : P u1) (v2 : P v1)
             (p : u1 = v1) (q : rew p in u2 = v2)
  : ex_intro P u1 u2 = ex_intro P v1 v2
    := eq_ex_uncurried P (ex_intro _ p q).

  Definition eq_ex_hprop {A} {P : A -> Prop} (P_hprop : forall (x : A) (p q : P x), p = q)
             (u1 v1 : A) (u2 : P u1) (v2 : P v1)
             (p : u1 = v1)
    : ex_intro P u1 u2 = ex_intro P v1 v2
    := eq_ex u1 v1 u2 v2 p (P_hprop _ _ _).

  Lemma rew_ex {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : exists p, Q x p) {y} (H : x = y)
  : rew [fun a => exists p, Q a p] H in u
    = match u with
        | ex_intro _ u1 u2
          => ex_intro
               (Q y)
               (rew H in u1)
               (rew dependent H in u2)
      end.
  Proof.
    destruct H, u; reflexivity.
  Qed.
End ex.

(** Equality for [ex2] *)
Section ex2.
  Local Unset Implicit Arguments.

  Definition eq_ex2_uncurried {A : Type} (P Q : A -> Prop) {u1 v1 : A}
             {u2 : P u1} {v2 : P v1}
             {u3 : Q u1} {v3 : Q v1}
             (pq : exists2 p : u1 = v1, rew p in u2 = v2 & rew p in u3 = v3)
  : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3.
  Proof.
    destruct pq as [p q r].
    destruct r, q, p; simpl in *.
    reflexivity.
  Qed.

  Definition eq_ex2 {A : Type} {P Q : A -> Prop}
             (u1 v1 : A)
             (u2 : P u1) (v2 : P v1)
             (u3 : Q u1) (v3 : Q v1)
             (p : u1 = v1) (q : rew p in u2 = v2) (r : rew p in u3 = v3)
  : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3
    := eq_ex2_uncurried P Q (ex_intro2 _ _ p q r).

  Definition eq_ex2_hprop {A} {P Q : A -> Prop}
             (P_hprop : forall (x : A) (p q : P x), p = q)
             (Q_hprop : forall (x : A) (p q : Q x), p = q)
             (u1 v1 : A) (u2 : P u1) (v2 : P v1) (u3 : Q u1) (v3 : Q v1)
             (p : u1 = v1)
    : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3
    := eq_ex2 u1 v1 u2 v2 u3 v3 p (P_hprop _ _ _) (Q_hprop _ _ _).

  Lemma rew_ex2 {A x} {P : A -> Type}
        (Q : forall a, P a -> Prop)
        (R : forall a, P a -> Prop)
        (u : exists2 p, Q x p & R x p) {y} (H : x = y)
  : rew [fun a => exists2 p, Q a p & R a p] H in u
    = match u with
        | ex_intro2 _ _ u1 u2 u3
          => ex_intro2
               (Q y)
               (R y)
               (rew H in u1)
               (rew dependent H in u2)
               (rew dependent H in u3)
      end.
  Proof.
    destruct H, u; reflexivity.
  Qed.
End ex2.


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

Require Import NAxioms NSub NZDiv.

(** Properties of Euclidean Division *)

Module Type NDivProp (Import N : NAxiomsSig')(Import NP : NSubProp N).

(** We benefit from what already exists for NZ *)
Module Import Private_NZDiv := Nop <+ NZDivProp N N NP.

Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l.

(** Let's now state again theorems, but without useless hypothesis. *)

Lemma mod_upper_bound : forall a b, b ~= 0 -> a mod b < b.
Proof. intros. apply mod_bound_pos; auto'. Qed.

(** Another formulation of the main equation *)

Lemma mod_eq :
 forall a b, b~=0 -> a mod b == a - b*(a/b).
Proof.
intros.
symmetry. apply add_sub_eq_l. symmetry.
now apply div_mod.
Qed.

(** Uniqueness theorems *)

Theorem div_mod_unique :
 forall b q1 q2 r1 r2, r1<b -> r2<b ->
  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof. intros. apply div_mod_unique with b; auto'. Qed.

Theorem div_unique:
 forall a b q r, r<b -> a == b*q + r -> q == a/b.
Proof. intros; apply div_unique with r; auto'. Qed.

Theorem mod_unique:
 forall a b q r, r<b -> a == b*q + r -> r == a mod b.
Proof. intros. apply mod_unique with q; auto'. Qed.

Theorem div_unique_exact: forall a b q, b~=0 -> a == b*q -> q == a/b.
Proof. intros. apply div_unique_exact; auto'. Qed.

(** A division by itself returns 1 *)

Lemma div_same : forall a, a~=0 -> a/a == 1.
Proof. intros. apply div_same; auto'. Qed.

Lemma mod_same : forall a, a~=0 -> a mod a == 0.
Proof. intros. apply mod_same; auto'. Qed.

(** A division of a small number by a bigger one yields zero. *)

Theorem div_small: forall a b, a<b -> a/b == 0.
Proof. intros. apply div_small; auto'. Qed.

(** Same situation, in term of modulo: *)

Theorem mod_small: forall a b, a<b -> a mod b == a.
Proof. intros. apply mod_small; auto'. Qed.

(** * Basic values of divisions and modulo. *)

Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
Proof. intros. apply div_0_l; auto'. Qed.

Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
Proof. intros. apply mod_0_l; auto'. Qed.

Lemma div_1_r: forall a, a/1 == a.
Proof. intros. apply div_1_r; auto'. Qed.

Lemma mod_1_r: forall a, a mod 1 == 0.
Proof. intros. apply mod_1_r; auto'. Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof. exact div_1_l. Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof. exact mod_1_l. Qed.

Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
Proof. intros. apply div_mul; auto'. Qed.

Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
Proof. intros. apply mod_mul; auto'. Qed.

(** * Order results about mod and div *)

(** A modulo cannot grow beyond its starting point. *)

Theorem mod_le: forall a b, b~=0 -> a mod b <= a.
Proof. intros. apply mod_le; auto'. Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof. exact div_str_pos. Qed.

Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> a<b).
Proof. intros. apply div_small_iff; auto'. Qed.

Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> a<b).
Proof. intros. apply mod_small_iff; auto'. Qed.

Lemma div_str_pos_iff : forall a b, b~=0 -> (0<a/b <-> b<=a).
Proof. intros. apply div_str_pos_iff; auto'. Qed.

(** As soon as the divisor is strictly greater than 1,
    the division is strictly decreasing. *)

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof. exact div_lt. Qed.

(** [le] is compatible with a positive division. *)

Lemma div_le_mono : forall a b c, c~=0 -> a<=b -> a/c <= b/c.
Proof. intros. apply div_le_mono; auto'. Qed.

Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a.
Proof. intros. apply mul_div_le; auto'. Qed.

Lemma mul_succ_div_gt: forall a b, b~=0 -> a < b*(S (a/b)).
Proof. intros; apply mul_succ_div_gt; auto'. Qed.

(** The previous inequality is exact iff the modulo is zero. *)

Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
Proof. intros. apply div_exact; auto'. Qed.

(** Some additional inequalities about div. *)

Theorem div_lt_upper_bound:
  forall a b q, b~=0 -> a < b*q -> a/b < q.
Proof. intros. apply div_lt_upper_bound; auto'. Qed.

Theorem div_le_upper_bound:
  forall a b q, b~=0 -> a <= b*q -> a/b <= q.
Proof. intros; apply div_le_upper_bound; auto'. Qed.

Theorem div_le_lower_bound:
  forall a b q, b~=0 -> b*q <= a -> q <= a/b.
Proof. intros; apply div_le_lower_bound; auto'. Qed.

(** A division respects opposite monotonicity for the divisor *)

Lemma div_le_compat_l: forall p q r, 0<q<=r -> p/r <= p/q.
Proof. intros. apply div_le_compat_l. auto'. auto. Qed.

(** * Relations between usual operations and mod and div *)

Lemma mod_add : forall a b c, c~=0 ->
 (a + b * c) mod c == a mod c.
Proof. intros. apply mod_add; auto'. Qed.

Lemma div_add : forall a b c, c~=0 ->
 (a + b * c) / c == a / c + b.
Proof. intros. apply div_add; auto'. Qed.

Lemma div_add_l: forall a b c, b~=0 ->
 (a * b + c) / b == a + c / b.
Proof. intros. apply div_add_l; auto'. Qed.

(** Cancellations. *)

Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 ->
 (a*c)/(b*c) == a/b.
Proof. intros. apply div_mul_cancel_r; auto'. Qed.

Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 ->
 (c*a)/(c*b) == a/b.
Proof. intros. apply div_mul_cancel_l; auto'. Qed.

Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 ->
  (a*c) mod (b*c) == (a mod b) * c.
Proof. intros. apply mul_mod_distr_r; auto'. Qed.

Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 ->
  (c*a) mod (c*b) == c * (a mod b).
Proof. intros. apply mul_mod_distr_l; auto'. Qed.

(** Operations modulo. *)

Theorem mod_mod: forall a n, n~=0 ->
 (a mod n) mod n == a mod n.
Proof. intros. apply mod_mod; auto'. Qed.

Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)*b) mod n == (a*b) mod n.
Proof. intros. apply mul_mod_idemp_l; auto'. Qed.

Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
 (a*(b mod n)) mod n == (a*b) mod n.
Proof. intros. apply mul_mod_idemp_r; auto'. Qed.

Theorem mul_mod: forall a b n, n~=0 ->
 (a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof. intros. apply mul_mod; auto'. Qed.

Lemma add_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)+b) mod n == (a+b) mod n.
Proof. intros. apply add_mod_idemp_l; auto'. Qed.

Lemma add_mod_idemp_r : forall a b n, n~=0 ->
 (a+(b mod n)) mod n == (a+b) mod n.
Proof. intros. apply add_mod_idemp_r; auto'. Qed.

Theorem add_mod: forall a b n, n~=0 ->
 (a+b) mod n == (a mod n + b mod n) mod n.
Proof. intros. apply add_mod; auto'. Qed.

Lemma div_div : forall a b c, b~=0 -> c~=0 ->
 (a/b)/c == a/(b*c).
Proof. intros. apply div_div; auto'. Qed.

Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 ->
 a mod (b*c) == a mod b + b*((a/b) mod c).
Proof. intros. apply mod_mul_r; auto'. Qed.

(** A last inequality: *)

Theorem div_mul_le:
 forall a b c, b~=0 -> c*(a/b) <= (c*a)/b.
Proof. intros. apply div_mul_le; auto'. Qed.

(** mod is related to divisibility *)

Lemma mod_divides : forall a b, b~=0 ->
 (a mod b == 0 <-> exists c, a == b*c).
Proof. intros. apply mod_divides; auto'. Qed.

End NDivProp.


Require Import Omega.
Require Import Wf_nat.

Definition f1_aux :
  forall x, (forall z, z < x ->{y:nat | z=0 \/ y < z})->{y:nat | x=0\/ y< x}.
 intros x; case x.
(* value for 0 *)
 intros rec; exists 0; auto.
 intros x'; case x'.
(* value for 1 *)
 intros rec; exists 0; auto.
(* value for x > 1 *)
 refine
    (fun x'' rec =>
      match rec (S x'') _ with
      | (exist v H) =>
        match rec (S v) _ with
        | (exist v' H') => (exist _ (S v') _)
        end
      end); omega.
Defined.

Definition f1' : forall x, {y:nat | x=0 \/ y<x} :=
 (well_founded_induction lt_wf
   (fun x:nat => {y:nat | x=0\/ y<x})
   f1_aux).

Definition f1 (x:nat): nat :=
 match f1' x with (exist v _) => v end.