Require Import List.
(* Funktionen die aus der List Bibliothek importiert und hier verwendet werden sind
 - rev, app und concat. *)

(* Beispiel fuer ein Eingabealphabet: Inductive Sigma := h : Sigma | a : Sigma | l : Sigma | o : Sigma.*)

(** Die Ursprungsidee war auf Listen zu arbeiten. Da die Verfahren aus der Vorlesung
 moeglichst eins zu eins abgebildet werden sollen, ist es notwendig einen induktiven Typen
 [Word] zu definieren, der, anders als bei Listen, die Zeichen am Ende der Zeichenkette anfuegt.
 Da sowohl Listen als auch Woerter fuer die Darstellung benoetigt werden, muessen die Typen
 ineinander ueberfuehrbar sein. *)

(** Definition von Woertern: *)
Inductive Word {A : Type} : Type:=
  | eps   : @Word A
  | snoc : @Word A -> A -> @Word A.

(** Anpassung der Notation der Woerter zur Verbesserung der Lesbarkeit. *)

Notation "[ ]" := eps.
Notation "[ x ; .. ; y ]" := (snoc ( .. (snoc eps x) .. ) y).

(** Grundoperationen auf dem Typ [Word]: *)

(** Einheit der [Word]-Monade. *)

Definition unit_w {A : Type} (a : A) : @Word A := snoc eps a.

(** Berechnung der Wortlaenge. *)

Fixpoint word_length {A : Type} (w : @Word A) : nat :=
  match w with
    | eps          => 0
    | snoc w' x => S (word_length w')
  end.

(** Verknuepfung zweier Woerter. *)

Fixpoint concat_word {A : Type} (w1 w2 : @Word A) : @Word A :=
  match w2 with
    | eps         => w1
    | snoc w x => snoc (concat_word w1 w) x
  end.

(** Ein Wort umdrehen. *)

Fixpoint word_reverse {A : Type} (w : @Word A) : @Word A  :=
  match w with
    | eps           => eps
    | snoc w' x  => concat_word (snoc eps x) (word_reverse w')
  end.

(** Map-Funktion auf Woertern ([Word] ist ein Funktor). *)

Fixpoint map_word {A B : Type} (f : A -> B) (w : @Word A) : @Word B :=
  match w with
    | eps          => eps
    | snoc w' x => snoc (map_word f w') (f x)
  end.

(** Die Map-Funktion ist laengenerhaltend. *)

Lemma map_length_w {A B : Type} : forall (f : A -> B) (w : @Word A),
      word_length (map_word f w) = word_length w.
Proof.
  intros f w.
  induction w as [ | w' IHw].
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHw.
    reflexivity.
Defined.

(** Definition von Listen: *)

(** In der Standardbibliothek befinden sich bereits Listenoperationen wie [concat] und [rev],
 die analog zu [concat_word] und [word_reverse] arbeiten. Zusaetzlich werden noch weitere
 Eigenschaften benoetigt, die nachfolgend gezeigt werden. *)

(** Eigenschaften von [concat] und [rev] ueber Listen: *)

(** Die leere Liste [nil] ist rechtsneutral bzgl. der Konkatenation. (Per Definition ist [nil] auch
linksneutral.) *)

Lemma concat_nil {A : Type} (ls : list A) : (ls ++ nil) = ls.
Proof.
  induction ls.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHls.
    reflexivity.
Defined.

(** Die Konkatenation von Listen ist assoziativ.*)

Lemma concat_associative {A : Type} (l1 l2 l3 : list A) :
     (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  induction l1.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHl1.
    reflexivity.
Defined.

(** Das Umdrehen von Listen ist ein Antihomomorphismus bzgl. der Konkatenation. *)

Lemma rev_concat {A : Type} (l1 l2 : list A) :
      rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
  induction l1.
  - assert (rev nil = @nil A).
    + simpl.
       reflexivity.
    + rewrite H.
       pose (concat_nil (rev l2)).
       rewrite e.
       simpl.
       reflexivity.
  - simpl.
    rewrite IHl1.
    apply concat_associative.
Defined.

(** Das Umdrehen von Listen ist selbstinvers.*)

Lemma rev_involutiv {A : Type} (ls : list A) : rev (rev ls) = ls.
Proof.
  induction ls.
  - simpl.
    reflexivity.
  - simpl.
    pose (rev_concat (rev ls) (a :: nil)).
    rewrite e.
    rewrite IHls.
    simpl.
    reflexivity.
Defined.

(** Analog zum Typen [list] werden diese Eigenschaften ebenfalls fuer die Operationen auf [Word]
 bewiesen.*)

(** Eigenschaften von [concat_word] und [word_reverse].*)

(** Das leere Wort [eps] ist linksneutral bzgl. der Konkatenation. (Per Definition ist [eps] auch
rechtsneutral.)*)

Lemma concat_word_eps {A : Type} (w : @Word A) : concat_word eps w = w.
Proof.
  induction w.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHw.
    reflexivity.
Defined.

Lemma commute_snoc_concat_w {A} (w w': @Word A) (a : A) :
      concat_word (snoc w a) w' =
      concat_word w (concat_word (snoc eps a) w').
Proof.
  destruct w.
  - rewrite concat_word_eps.
    reflexivity.
  - induction w'.
    + simpl.
       reflexivity.
    + simpl.
       rewrite IHw'.
       reflexivity.
Defined.

(** Die Konkatenation von Woertern ist assoziativ.*)

Lemma concat_word_associative {A : Type} (w1 w2 w3 : @Word A) :
      concat_word (concat_word w1 w2) w3 =
      concat_word w1 (concat_word w2 w3).
Proof.
  induction w3.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHw3.
    reflexivity.
Defined.

(** Das Umdrehen von Woertern ist ein Antihomomorphismus bzgl. der Konkatenation. *)

Lemma word_reverse_concat_word {A : Type} (w1 w2 : @Word A) :
      word_reverse (concat_word w1 w2) =
      concat_word (word_reverse w2) (word_reverse w1).
Proof.
  induction w2.
  - assert (word_reverse eps = @eps A).
    + simpl.
       reflexivity.
    + rewrite H.
       simpl.
       pose (concat_word_eps (word_reverse w1)) as con_nil.
       rewrite con_nil.
       reflexivity.
  - simpl.
    rewrite IHw2.
    apply eq_sym.
    apply concat_word_associative.
Defined.

Lemma word_reverse_snoc {A : Type} (w : @Word A) (a : A) :
      word_reverse (snoc w a) = concat_word [a] (word_reverse w).
Proof.
  simpl.
  reflexivity.
Defined.

(** Das Umdrehen von Woertern ist selbstinvers.*)

Lemma word_reverse_involutiv {A : Type} (w : @Word A) :
      word_reverse (word_reverse w) = w.
Proof.
  induction w.
  - simpl.
    reflexivity.
  - simpl.
    pose (word_reverse_concat_word (snoc eps a) (word_reverse w)).
    rewrite e.
    rewrite IHw.
    simpl.
    reflexivity.
Defined.

(** [word_reverse] ist injektiv.*)

Lemma word_reverse_injective {A : Type} (w1 w2 : @Word A) :
      word_reverse w1 = word_reverse w2 -> w1 = w2.
Proof.
  intro revEq.
  apply (f_equal word_reverse) in revEq.
  rewrite <- (word_reverse_involutiv w1).
  rewrite <- (word_reverse_involutiv w2).
  exact revEq.
Defined.

(** Somit ist [Word] als Monoid mit [concat_word] als assoziative Konkatenation
 und [eps] als neutrales Element definiert. Bei [list] erhalten wir die gleichen Eigenschaften
 durch [concat] als assoziative Konkatenation und [nil] als neutrales Element bzgl. der
 Konkatenation.

 Diese Eigenschaften von Listen und Woertern ermoeglichen weitere Schlussfolgerungen
 bzgl. der Ueberfuehrung von Listen in Woertern und anders herum. *)

(** Eine Liste in ein Wort umwandeln:*)

(** Ein Problem das sich hierbei ergibt, ist dass die Typen von Listen und Woertern auf unterschiedlich
 arbeitenden Konstruktoren aufbauen. Die Liste wird von hinten nach vorn aufgebaut, indem das
 naechste Zeichen vorn angehaengt wird und der Aufbau eines Wortes ist entgegengesetzt. Wenn
 die Umwandlung von einer Liste in ein Wort eins zu eins implementiert wird, entsteht die Funktion, die in
 [list_to_word_simple] beschrieben ist.*)

Fixpoint list_to_word_simple {A : Type} (l : list A) : @Word A :=
  match l with
    | nil           => eps
    | cons x l'  => snoc (list_to_word_simple l') x
  end.

(** Das Ergebnis ist jedoch ein Wort in umgedrehter Reihenfolge. Hierbei handelt
es sich um einen Antihomomorphismus: Das neutrale Element wird erhalten, das Bild einer Konkatenation
ist die umgekehrte Konkatenation der Bilder der Einzellisten.*)

Lemma list_to_word_simple_antihom {A: Type} (l1 l2 : list A) :
      list_to_word_simple (l1 ++ l2) =
      concat_word (list_to_word_simple l2) (list_to_word_simple l1).
Proof.
  induction l1.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHl1.
    reflexivity.
Defined.

(** Um eine Liste mit Hilfe von [list_to_word_simple] in ein Wort unter Beachtung der Reihenfolge umzuwandeln,
 koennen zwei verschiedene Ansaetze verwendet werden. Die Liste wird zuerst in ein Wort umgewandelt
und anschliessend wird die Reihenfolge mit [word_reverse] geaendert oder die Liste wird zuerst mit [rev]
umgedreht und anschliessend in ein Wort umgewandelt. Da jeweils zwei Antihomomorphismen hintereinander
ausgefuehrt werden, sind beide entstehenden Funktionen Homomorphismen bzgl. der Konkatenationen.*)

Definition list_to_word' {A : Type} (l : list A) : @Word A :=
           word_reverse (list_to_word_simple l).

Definition list_to_word'' {A : Type} (l : list A) : @Word A :=
           list_to_word_simple (rev l).

(**  [list_to_word'] und [list_to_word''] basieren auf Funktionen, die durch Pattern Matching definiert sind.
Durch Auffaltung der Definitionen koennen auch [list_to_word'] und [list_to_word''] ueber Pattern Matching
definiert werden. Es stellt sich heraus, dass in beiden Faellen dieselbe Funktion [list_to_word] entsteht.
Die Gleichheiten werden in [list_to_word_Lemma] und [list_to_word_Lemma'] gezeigt.*)

Fixpoint list_to_word {A : Type} (l : list A) : @Word A :=
  match l with
    | nil           => eps
    | cons x l'  => concat_word (snoc eps x) (list_to_word l')
  end.

(** [list_to_word_single] auf einelementigen Listen.*)

Lemma list_to_word_single {A : Type} (a : A) :
      list_to_word (cons a nil) = snoc eps a.
Proof.
  simpl.
  reflexivity.
Defined.

(** [list_to_word] ist ein Homomorphismus bzgl. Konkatenationen.*)

Lemma list_to_word_hom {A : Type} (l1 l2 : list A) :
      list_to_word (l1 ++ l2) =
      concat_word (list_to_word l1) (list_to_word l2).
Proof.
  induction l1.
  - simpl.
    rewrite (concat_word_eps (list_to_word l2)).
    reflexivity.
  - simpl.
    rewrite IHl1.
    apply eq_sym.
    apply concat_word_associative.
Defined.

(** [list_to_word], [list_to_word'] und [list_to_word''] beschreiben dieselbe Funktion.*)

Lemma list_to_word_Lemma {A : Type} (l : list A) :
      list_to_word l = list_to_word' l.
Proof.
  unfold list_to_word'.
  induction l.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHl.
    reflexivity.
Defined.

Lemma list_to_word_Lemma' {A : Type} (l : list A) :
      list_to_word l = list_to_word'' l.
Proof.
  unfold list_to_word''.
  induction l.
  - simpl.
    reflexivity.
  - simpl.
    rewrite list_to_word_simple_antihom.
    rewrite IHl.
    reflexivity.
Defined.

Lemma list_to_word'_Lemma {A : Type} (l : list A) :
      list_to_word' l = list_to_word'' l.
Proof.
  rewrite <- list_to_word_Lemma.
  rewrite <- list_to_word_Lemma'.
  reflexivity.
Defined.

(** Ein Wort in eine Liste umwandeln: *)

(** Wie auch schon bei der Umwandlung von einer Liste in ein Wort, besteht auch hier das
 Problem mit der Reihenfolge aufgrund der Konstruktoren. Die eins zu eins Implementierung
 der Umwandlung liefert die Funktion [word_to_list_simple].*)

Fixpoint word_to_list_simple {A : Type} (w : @Word A) : list A :=
  match w with
    | eps           => nil
    | snoc w' x  => cons x (word_to_list_simple w')
  end.

(** [word_to_list_simple] ist ein Antihomomorphismus bzgl. der Konkatenation. *)

Lemma word_to_list_simple_antihom {A: Type} (w1 w2 : @Word A) :
      word_to_list_simple (concat_word w1 w2) =
     (word_to_list_simple w2) ++ (word_to_list_simple w1).
Proof.
  induction w2.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHw2.
    reflexivity.
Defined.

(** Wie schon bei [list_to_word] kann bei [word_to_list] die Reihenfolge durch das Umdrehen der Liste nach der
 Umwandlung mit [rev] oder das vorherige Umdrehen gewaehrleistet werden. Dies wird durch die Funktionen
 [word_to_list'] und [word_to_list''] dargestellt.*)

Definition word_to_list' {A : Type} (w : @Word A) : list A :=
           rev (word_to_list_simple w).

Definition word_to_list'' {A : Type} (w : @Word A) : list A :=
           word_to_list_simple (word_reverse w).

(** Es entsteht durch Auffaltung beider Definitionen dieselbe Funktion [word_to_list],
 siehe [list_to_word].*)

Fixpoint word_to_list {A: Type} (w : @Word A) : list A :=
  match w with
    | eps           => nil
    | snoc w' x  => app (word_to_list w') (cons x nil)
  end.

(** Die Abarbeitung eines Zeichens von [word_to_list].*)

Lemma word_to_list_single {A : Type} (a : A) :
      word_to_list (snoc eps a) = cons a nil.
Proof.
  simpl.
  reflexivity.
Defined.

(** [word_to_list] ist ein Homomorphismus bzgl. der Konkatenation. *)

Lemma word_to_list_hom {A : Type} (w1 w2 : @Word A) :
      word_to_list (concat_word w1 w2) =
      word_to_list w1 ++ word_to_list w2.
Proof.
  induction w2.
  - simpl.
    rewrite (concat_nil (word_to_list w1)).
    reflexivity.
  - simpl.
    rewrite IHw2.
    apply concat_associative.
Defined.

(** [word_to_list], [word_to_list'] und [word_to_list''] beschreiben dieselbe Funktion.*)

Lemma word_to_list_Lemma {A : Type} (w : @Word A) :
      word_to_list w = word_to_list' w.
Proof.
  unfold word_to_list'.
  induction w.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHw.
    reflexivity.
Defined.

Lemma word_to_list_Lemma' {A : Type} (w : @Word A) :
      word_to_list w = word_to_list'' w.
Proof.
  unfold word_to_list''.
  induction w.
  - simpl.
    reflexivity.
  - simpl.
    rewrite word_to_list_simple_antihom.
    rewrite IHw.
    reflexivity.
Defined.

Lemma word_to_list'_Lemma {A : Type} (w : @Word A) :
      word_to_list' w = word_to_list'' w.
Proof.
  rewrite <- word_to_list_Lemma.
  rewrite <- word_to_list_Lemma'.
  reflexivity.
Defined.

(** [list_to_word_simple] und [word_to_list_simple] sind zueinander inverse Isomorphismen.*)

Lemma list_word_list_simple {A : Type} (l : list A) :
      word_to_list_simple (list_to_word_simple l) = l.
Proof.
  induction l.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHl.
    reflexivity.
Qed.

Lemma word_list_word_simple {A : Type} (w : @Word A) :
      list_to_word_simple (word_to_list_simple w) = w.
Proof.
  induction w.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHw.
    reflexivity.
Qed.

(** [list_to_word] und [word_to_list] sind zueinander inverse Isomorphismen.*)

Lemma list_word_list {A : Type} (l : list A) :
      word_to_list (list_to_word l) = l.
Proof.
  rewrite list_to_word_Lemma.
  rewrite word_to_list_Lemma'.
  unfold list_to_word'.
  unfold word_to_list''.
  rewrite word_reverse_involutiv.
  apply list_word_list_simple.
Defined.

Lemma word_list_word {A : Type} (w : @Word A) :
      list_to_word (word_to_list w) = w.
Proof.
  rewrite list_to_word_Lemma.
  rewrite word_to_list_Lemma'.
  unfold list_to_word'.
  unfold word_to_list''.
  rewrite word_list_word_simple.
  apply word_reverse_involutiv.
Defined.

(** Weitere Lemmata zu Word-List und List-Word-Umwandlungen. *)

Lemma lw_pres_eq {A} (l : list A) : forall (w : @Word A),
      l = word_to_list w -> list_to_word l = w.
Proof.
  intros w eq.
  rewrite <- word_list_word.
  rewrite eq.
  reflexivity.
Defined.

(** [word_to_list] ist laengenerhaltend. *)

Lemma wl_pres_length {A : Type} (w : @Word A) :
      length (word_to_list w) = word_length w.
Proof.
  induction w.
  - simpl.
    reflexivity.
  - simpl.
    rewrite app_length.
    simpl.
    rewrite <- plus_n_Sm.
    rewrite <- plus_n_O.
    rewrite IHw.
    reflexivity.
Defined.

Lemma lw_concat {A} (l1 l2: list A) (a : A):
     {w1 : @Word A & {w2 : @Word A &
      concat_word (list_to_word l1) (list_to_word (a :: l2)) =
      concat_word (snoc w1 a) w2 } }.
Proof.
  exists (list_to_word l1).
  exists (list_to_word l2).
  simpl.
  rewrite <- commute_snoc_concat_w.
  reflexivity.
Defined.

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

(** Inits und Tails: *)

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

(** Typsynonym fuer @Word (@Word X) und @Word (@Word (@Word X)). *)

Definition Word2 {X : Type} := (@Word (@Word X)).
Definition Word3 {X : Type} := (@Word (@Word (@Word X))).

(* unbenutzt, aber ok als Standard ? *)

Fixpoint tails_w {X : Type} (w : @Word X) : Word2 :=
  match w with
    | eps          => snoc eps eps
    | snoc xs x => snoc (map_word (fun w => snoc w x) (tails_w xs)) eps
  end.

(** Verschiedene inits-Varianten: *)

Fixpoint inits_l {X : Type} (l : list X) : list (list X) :=
  match l with
    | nil       => nil :: nil
    | x :: xs => nil :: map (cons x) (inits_l xs)
  end.

(* Die fuer das Pumping_Lemma_Word benutzte Variante *)

Fixpoint inits_w {X : Type} (w : @Word X) : Word2 :=
  match w with
    | eps          => snoc eps eps
    | snoc w' x => snoc (inits_w w') w
 end.

Definition inits_w'{X : Type} (w : @Word X) : @Word (@Word X) :=
           list_to_word (map (list_to_word) (inits_l (word_to_list w))).

Fixpoint inits_w''{X : Type} (w : @Word X) : Word2 :=
  match w with
    | eps          => snoc eps eps
    | snoc w' x =>
        concat_word (snoc eps eps)
                    (map_word (fun w'' => concat_word w'' (snoc eps x))
                              (inits_w w'))
  end.

Definition inits_list_w {X : Type} (w : @Word X) : list (@Word X) :=
           map (list_to_word) (inits_l (word_to_list w)).

Fixpoint removelast_w {A} (w : @Word A) :=
  match w with
    |eps          => eps
    |snoc w' _ => w'
  end.

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

(** Lemmata zu inits, concat und map: *)

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

Lemma inits_len_l : forall X : Type, forall l : list X,
      length (inits_l l) = S (length l).
Proof.
  induction l as [ | x l' IHl].
  - simpl.
    reflexivity.
  - simpl.
    rewrite map_length.
    rewrite IHl.
    reflexivity.
Defined.

Lemma inits_len_w : forall X : Type, forall w : @Word X,
      word_length (inits_w w) = S (word_length w).
Proof.
  intros X w.
  induction w as [ | w' IHw x].
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHw.
    reflexivity.
Defined.

Lemma commute_inits_concat_w {A} (w w': @Word A) :
      inits_w (concat_word w w') =
      concat_word (removelast_w (inits_w w))
     (map_word (concat_word w) (inits_w w')).
Proof.
  induction w'.
  - simpl.
    induction w.
    + simpl.
       reflexivity.
    + simpl (inits_w (snoc w a)).
       simpl (removelast_w (snoc (inits_w w) (snoc w a))).
       reflexivity.
  - simpl.
    rewrite IHw'.
    reflexivity.
Defined.

Lemma commute_concat_map_w {A B} (w w': @Word A) (f : A -> B) :
      map_word f (concat_word w w') =
      concat_word (map_word f w) (map_word f w').
Proof.
  induction w'.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHw'.
    reflexivity.
Defined.

Lemma commute_removelast_map_w {A B} (w : @Word A) (f : A -> B) :
      map_word f (removelast_w w) = removelast_w (map_word f w).
Proof.
  induction w.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Defined.

Lemma inits_last_w {A : Type} (w : @Word A) :
      inits_w w = snoc (removelast_w (inits_w w)) w.
Proof.
  destruct w.
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Defined.

Lemma app_length_w {A : Type} : forall (w w' : @Word A),
      word_length (concat_word w w') = word_length w + word_length w'.
Proof.
  intros w w'.
  induction w'.
  - simpl.
    rewrite <- plus_n_O.
   reflexivity.
  - simpl.
    rewrite <- plus_n_Sm.
    rewrite IHw'.
    reflexivity.
Defined.

Lemma absurd_eps_eq_concat_snoc {A : Type} (w w' : @Word A) (a : A) :
      eps = concat_word (snoc w a) w' -> False.
Proof.
  intro eps_eq_waw'.
  destruct w'.
  - simpl in eps_eq_waw'.
    inversion eps_eq_waw'.
  - simpl in eps_eq_waw'.
    inversion eps_eq_waw'.
Defined.

Lemma ex_snoc_map {A B : Type} (w : @Word A) (v : @Word B) (b : B) (f : A -> B) :
      map_word f w = snoc v b ->
     {w' : @Word A & { a : A &
     ((w = snoc w' a) * (map_word f w' = v) * (b = f a))%type } }.
Proof.
  destruct w as [| w' a'].
  - intro eq.
    simpl in eq.
    inversion eq.
  - intro eq.
    exists w'.
    exists a'.
    simpl in eq.
    inversion eq.
    repeat split; reflexivity.
Defined.


(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 6 *)

Require Import Frap.

(* Authors:
 * Ben Sherman (sherman@csail.mit.edu),
 * Joonwon Choi (joonwonc@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

(* In this problem set, we will work with the following simple imperative language with
 * a nondeterministic choice operator. Your task is to define both big-step as well as
 * a particular kind of small-step operational semantics for this language
 * (one that is in fact deterministic), and to prove a theorem connecting the two:
 * if the small-step semantics aborts, then the big-step semantics may abort.
 *
 * This is the first problem set so far in this class that is truly open-ended.
 * We want to give you the flexibility to define the operational semantics as
 * you wish, and if you'd like you may even differ from the template shown here
 * if you find it more convenient.
 * Additionally, this is the first problem set where it is *NOT* sufficient to
 * just get the file compiling without any use of [admit] or [Admitted].
 * This will not necessarily guarantee that you have given reasonable semantics
 * for the programming language, and accordingly, will not necessarily
 * guarantee that you will earn full credit. For instance, if you define
 * your small-step semantics as the empty relation (which is incorrect),
 * the theorem you must prove to connect your big-step and small-step
 * semantics will be trivial.
 *)

(** * Syntax *)

(* Basic arithmetic expressions, as we've seen several times in class. *)
Inductive arith : Set :=
| Const : nat -> arith
| Var : var -> arith
| Plus : arith -> arith -> arith
| Eq : arith -> arith -> arith
(* should return 1 if the two expressions are equal, and 0 otherwise. *)
| Lt : arith -> arith -> arith
(* should return 1 if the two expressions are equal, and 0 otherwise. *)
.

(* The simple imperative language with a [Choose] syntax for
 * nondeterminism. The intended meaning of the program
 * [Choose c c'] is that either [c] should run or [c'] should run.
 *)
Inductive cmd :=
| Assign : var -> arith -> cmd
| Skip : cmd
| Seq : cmd -> cmd -> cmd
| Choose : cmd -> cmd -> cmd (* Here's the main novelty: nondeterministic choice *)
| If : arith -> cmd (* then *) -> cmd (* else *) -> cmd
| While : arith -> cmd -> cmd
| Abort : cmd (* This command should immediately terminate the program *)
.

(** Notations *)

Delimit Scope cmd_scope with cmd.

Coercion Const : nat >-> arith.
Coercion Var : var >-> arith.
Infix "+" := Plus : arith_scope.
Infix "==" := Eq (at level 75) : arith_scope.
Infix "<" := Lt : arith_scope.
Delimit Scope arith_scope with arith.
Notation "x <- e" := (Assign x e%arith) (at level 75) : cmd_scope.
Infix "<|>" := Choose (at level 78) : cmd_scope.
Infix ";;" := Seq (at level 80) : cmd_scope.

Notation "'if_' c 'then' t 'else' f" := (If c%arith t f) (at level 75) : cmd_scope.
Notation "'while' c 'do' p" := (While c%arith p) (at level 75) : cmd_scope.

(** * Examples *)

(* All nondeterministic realizations of [test_prog1] terminate
 * (either normally or by aborting). [test_prog1 5] may abort,
 * but [test_prog1 6] always terminates normally.
 *)
Definition test_prog1 (k : nat) : cmd := (
  "target" <- 8 ;;
  ("x" <- 3 <|> "x" <- 4) ;;
  ("y" <- 1 <|> "y" <- k) ;;
  if_ "x" + "y" == "target"
     then Abort
     else Skip
  )%cmd.

(* No matter the value of [num_iters], [test_prog2 num_iters]
 * always may potentially fail to terminate, and always
 * may potentially abort.
 *)
Definition test_prog2 (num_iters : nat) : cmd := (
   "acc" <- 0 ;;
   "n" <- 0;;
   while ("n" < 1) do (
     (Skip <|> "n" <- 1) ;;
     "acc" <- "acc" + 1
   ) ;;
   if_ "acc" == S num_iters
     then Abort
     else Skip
  )%cmd.

(* We've seen the expression language in class a few times,
 * so here we'll just give you the interpreter for that
 * expression language.
 *)
Definition valuation := fmap var nat.

Fixpoint interp (e : arith) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x =>
    match v $? x with
    | None => 0
    | Some n => n
    end
  | Plus e1 e2 => interp e1 v + interp e2 v
  | Eq e1 e2 => if interp e1 v ==n interp e2 v then 1 else 0
  | Lt e1 e2 => if lt_dec (interp e1 v) (interp e2 v) then 1 else 0
  end.

(** ** Part 1: Big-step operational semantics *)

(* You should define some result type (say, [result]) for values that commands
   in the language run to, and define a big-step operational semantics
   [eval : valuation -> cmd -> result -> Prop]
   that says when a program *may* run to some result in *some* nondeterministic
   realization of the program. Then you should also define a predicate
   [big_aborted : result -> Prop]
   that describes which results indicate that the program aborted.

 * Looking at the examples, we should have
   [exists res, eval $0 (test_prog1 5) res /\ big_aborted res]
   but
   [forall res, eval $0 (test_prog1 6) res -> big_aborted res -> False]
 * . You are not required to prove these facts, but it could be a good
     sanity check!
 *)

Definition result : Type.
Admitted.

Definition eval : valuation -> cmd -> result -> Prop.
Admitted.

Definition big_aborted : result -> Prop.
Admitted.

(* As an optional sanity check, you may attempt to
 * prove that your big-step semantics behaves appropriately
 * for an example program:

Example test_prog1_reachable :
  exists res, eval $0 (test_prog1 5) res /\ big_aborted res.
Proof.
Admitted.

Example test_prog1_unreachable :
  forall res, eval $0 (test_prog1 6) res -> big_aborted res -> False.
Proof.
Admitted.
*)

  (** ** Part 2: Small-step deterministic operational semantics *)

(* Next, you should define a small-step operational semantics for this
   language that in some sense tries to run *all* possible nondeterministic
   realizations and aborts if any possible realization aborts.
   Define a type [state] that represents the underlying state that the
   small-step semantics should take steps on, and then define a small-step
   semantics
   [step : state -> state -> Prop]
   .

   Here's the twist: we ask that you define an operational semantics that
   is *deterministic*, in the sense of the following formal statement:
   [forall s1 s2 s2', step s1 s2 -> step s1 s2' -> s2 = s2'].

   The operational model that we have in mind in this: when we encounter
   a nondeterministic choice, we execute the left branch. If the left
   branch terminates without aborting, we backtrack and try the
   other nondeterministic choice.

   Note that if any possible realization does not terminate,
   we allow the deterministic small-step semantics to diverge as well.
   (It is actually possible to define a semantics that always "finds" aborts,
   even if some branches of nondeterminism diverge!  However, the proof of that
   variant would likely be significantly more complicated, and we haven't tried
   it ourselves.)

   Define a function
   [init : valuation -> cmd -> state]
   that builds starting states for the small-step semantics,
   a predicate
   [small_aborted : state -> Prop]
   that describes which states are considered aborted, and
   a predicate
   [small_terminated : state -> Prop]
   that describes states that have run to completion without any
   nondeterministic branch aborting.

 * Looking at the examples, we should have
   [exists st, step^* (init $0 (test_prog1 5)) st /\ small_aborted st]
   but
   [forall st, step^* (init $0 (test_prog1 6)) st -> small_aborted st -> False]
   . You are not required to prove these facts, but it could be
   a good sanity check!
 *)

Definition state : Type.
Admitted.

Definition step : state -> state -> Prop.
Admitted.

Definition init : valuation -> cmd -> state.
Admitted.

Definition small_aborted : state -> Prop.
Admitted.

Definition small_terminated : state -> Prop.
Admitted.

(* As an optional sanity check, you may attempt to
 * prove that your small-step semantics behaves appropriately
 * for an example program:

Example test_prog1_reachable_small :
  exists st, step^* (init $0 (test_prog1 5)) st /\ small_aborted st.
Proof.
Admitted.

Example test_prog1_unreachable_small :
  forall st, step^* (init $0 (test_prog1 6)) st -> small_aborted st -> False.
Proof.
Admitted.
*)

(** ** Part 3: Connection between big- and small-step semantics *)

(* Prove the following theorem demonstrating the connection between the big-step
 * and small-step semantics:
 *
 * If the small-step semantics aborts, then the big-step semantics may
 * potentially abort.
 *)

Theorem small_abort_big_may_abort : forall v c s,
         step^* (init v c) s
      -> small_aborted s
      -> exists res, eval v c res /\ big_aborted res.
Proof.
Admitted.

(* As an additional challenge, you  you may want to prove the following
 * theorem. Note that this is *NOT* required for this assignment and
 * will not affect your grade.
 *
 * If the small-step semantics terminates without aborting, then the
 * big-step semantics may *not* abort.

Theorem small_terminates_big_may_not_abort :
       forall v c s,
         step^* (init v c) s
      -> small_terminated s
      -> forall res,
             eval v c res
          -> big_aborted res
          -> False.
Proof.
Admitted.
*)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega Wellfounded Permutation.
Require Import list_utils wf_utils bt zip sorted increase bft.

Set Implicit Arguments.

Section bt_branches.

  Variable X : Type.

  Implicit Types (l : list bool) (ll: list(list bool)) (t : bt X).

  (* Depth first traversal, VERY standard algo *)

  Fixpoint dft_std t : list X :=
    match t with
      | leaf x => x::nil
      | node u x v => x::dft_std u++dft_std v
    end.

  Fact dft_std_length t : length (dft_std t) = m_bt t.
  Proof. induction t; simpl; repeat rewrite app_length; omega. Qed.

  (* The tree branches by Depth First Traversal *)

  Fixpoint dft_br t : list (list bool) :=
    nil::match t with
           | leaf _     => nil
           | node u _ v => map (cons false) (dft_br u) ++ map (cons true) (dft_br v)
         end.

  (* dft_br corresponds to dft_std *)

  Theorem dft_br_std t : Forall2 (bt_path_node t) (dft_br t) (dft_std t).
  Proof.
    induction t as [ | ? Hu ? ? Hv ]; simpl; repeat constructor.
    apply Forall2_app; apply Forall2_map_left; [ revert Hu | revert Hv ];
      apply Forall2_mono; constructor; auto.
  Qed.

  (* number of branches equals size of tree *)

  Fact dft_br_length t : length (dft_br t) = m_bt t.
  Proof. rewrite (Forall2_length (dft_br_std t)), dft_std_length; trivial. Qed.

  (* dft_br lists the branches of t *)

  Fact dft_br_spec l t : In l (dft_br t) <-> btb t l.
  Proof.
    split.
    + intros Hl; rewrite btb_spec.
      destruct Forall2_In_inv_left with (1 := dft_br_std t) (2 := Hl) as (x & ? & ?).
      exists x; auto.
    + induction 1 as [ [] | | ]; simpl; auto; right; apply in_or_app;
        [ left | right ]; apply in_map; auto.
   Qed.

  Corollary dft_br_spec_1 t : Forall (btb t) (dft_br t).
  Proof. rewrite Forall_forall; intro; apply dft_br_spec. Qed.

  (* the branches of t in dft_br t are sorted according to lb_lex *)

  Fact dft_br_sorted t : sorted lb_lex (dft_br t).
  Proof.
    induction t; simpl.
    + do 2 constructor.
    + constructor.
      * apply Forall_app; rewrite Forall_forall; intro;
          rewrite in_map_iff; intros (? & ? & ?); subst; constructor.
      * apply sorted_app.
        - intros ? ?; do 2 rewrite in_map_iff.
          intros (? & ? & ?) (? & ? & ?); subst; constructor.
        - apply sorted_map; auto; constructor; auto.
        - apply sorted_map; auto; constructor; auto.
  Qed.

  (* Now niveaux and then Breadth first traversal *)

  Fixpoint niveaux_br (t : bt X) : list (list (list bool)) :=
    match t with
      | leaf _     => (nil::nil) :: nil
      | node a _ b => (nil::nil) :: zip (@app _) (map (map (cons false)) (niveaux_br a))
                                                 (map (map (cons true))  (niveaux_br b))
    end.

  Lemma niveaux_br_niveaux t : Forall2 (Forall2 (bt_path_node t)) (niveaux_br t) (niveaux t).
  Proof.
    induction t as [ | ? Hu ? ? Hv ]; simpl; repeat constructor.
    apply Forall2_zip_app; apply Forall2_map_left;
      [ revert Hu | revert Hv ]; apply Forall2_mono;
      intros ? ? G; apply Forall2_map_left; revert G;
      apply Forall2_mono; constructor; auto.
  Qed.

  Lemma niveaux_br_spec_0 l t : btb t l -> In l (concat (niveaux_br t)).
  Proof.
    induction 1 as [ t | | ].
    + apply in_concat_iff; exists (nil::nil); destruct t; simpl; auto.
    + simpl; right; apply In_concat_zip_app_left; rewrite <- map_concat; apply in_map; assumption.
    + simpl; right; apply In_concat_zip_app_right; rewrite <- map_concat; apply in_map; assumption.
  Qed.

  Corollary niveaux_br_spec_1 t : forall l ll, In l ll -> In ll (niveaux_br t) -> btb t l.
  Proof.
    intros l ll H1 H2.
    destruct Forall2_In_inv_left with (1 := niveaux_br_niveaux t) (2 := H2) as (? & ? & H3).
    destruct Forall2_In_inv_left with (1 := H3) (2 := H1) as (? & ? & ?).
    apply btb_spec; firstorder.
  Qed.

  Fact niveaux_br_increase t : increase (fun n ll => Forall (fun l => length l = n) ll) 0 (niveaux_br t).
  Proof.
    induction t as [ | u Hu x v Hv ]; simpl.
    + do 2 constructor; auto.
    + constructor.
      * constructor; auto.
      * apply zip_increase.
        1: intros; apply Forall_app; auto.
        1,2 : apply map_increase; try assumption;
            intros ? ? G; apply Forall_map; simpl;
            revert G; apply Forall_impl; intros; omega.
  Qed.

  Fact niveaux_br_sorted t : Forall (sorted lb_lex) (niveaux_br t).
  Proof.
    induction t as [ x | u Hu x v Hv ]; simpl.
    + repeat constructor.
    + constructor.
      * repeat constructor.
      * apply zip_monotone.
        - apply Forall_map; revert Hu; apply Forall_impl.
          intros; apply sorted_map; auto.
          intros; constructor; auto.
        - apply Forall_map; revert Hv; apply Forall_impl.
          intros; apply sorted_map; auto.
          intros; constructor; auto.
        - rewrite Forall_forall in Hu, Hv.
          intros ? ?; do 2 rewrite in_map_iff;
            intros (? & ? & ?) (? & ? & ?); subst.
          apply sorted_app.
          ++ intros ? ?; do 2 rewrite in_map_iff;
             intros (? & ? & ?) (? & ? & ?); subst; constructor.
          ++ apply sorted_map; auto; intros; constructor; auto.
          ++ apply sorted_map; auto; intros; constructor; auto.
  Qed.

  Definition bft_br t : list (list bool) := concat (niveaux_br t).

  (* bft_br corresponds to bft_std *)

  Theorem bft_br_std t : Forall2 (bt_path_node t) (bft_br t) (bft_std t).
  Proof. apply Forall2_concat, niveaux_br_niveaux. Qed.

  (* bft_br contains the branches of t *)

  Fact bft_br_spec l t : In l (bft_br t) <-> btb t l.
  Proof.
    unfold bft_br; split.
    + rewrite in_concat_iff; intros (? & H1 & H2); revert H1 H2; apply niveaux_br_spec_1.
    + apply niveaux_br_spec_0.
  Qed.

  Hint Resolve niveaux_br_increase niveaux_br_sorted.

  (* The list of branches generated by bft_br is sorted according to bft_order *)

  Theorem bft_br_sorted t : sorted bft_order (bft_br t).
  Proof.
    apply concat_sorted with (P := fun n ll => Forall (fun l => length l = n) ll) (n := 0); auto.
    + intros i j x l y m; do 2 rewrite Forall_forall; intros H1 H2 H3 H4 H5.
      apply H2 in H4; apply H3 in H5; left; omega.
    + generalize (niveaux_br_sorted t).
      do 2 rewrite Forall_forall.
      intros H l Hl; generalize (H _ Hl).
      apply sorted_mono.
      intros x y H1 H2 H3; right; split; auto.
      generalize (niveaux_br_increase t); intros H4.
      apply increase_inv with (2 := Hl) in H4.
      destruct H4 as (k & _ & H4).
      rewrite Forall_forall in H4.
      repeat rewrite H4; auto.
  Qed.

  Hint Resolve dft_br_sorted bft_br_sorted lb_lex_irrefl bft_order_irrefl.

  (* dft_br and bft_br compute the same list of branches ... up to permutation *)

  Theorem bft_br_dft_br t : dft_br t ~p bft_br t.
  Proof.
    apply sorted_perm with (R := lb_lex) (S := bft_order); auto.
    intro; rewrite dft_br_spec, bft_br_spec; tauto.
  Qed.

  Corollary bft_br_length t : length (bft_br t) = m_bt t.
  Proof. rewrite <- (Permutation_length (bft_br_dft_br t)); apply dft_br_length. Qed.

  Corollary bft_std_length t : length (bft_std t) = m_bt t.
  Proof.
    generalize (bft_br_std t); intros H.
    apply Forall2_length in H.
    rewrite <- H, bft_br_length; trivial.
  Qed.

End bt_branches.

Check dft_br_spec.
Check dft_br_length.
Check dft_br_sorted.
Check dft_br_std.

Check bft_br_spec.
Check bft_br_length.
Check bft_br_sorted.
Check bft_br_std.

Check bft_br_dft_br.


(* ** Abstract Reduction Systems *)
(* from Semantics Lecture at Programming Systems Lab, https://www.ps.uni-saarland.de/courses/sem-ws13/ *)

Require Export Undecidability.Shared.Libs.PSL.Base Lia Arith.

Module ARSNotations.
  Notation "p '<=1' q" := (forall x, p x -> q x) (at level 70).
  Notation "p '=1' q" := (forall x, p x <-> q x) (at level 70).
  Notation "R '<=2' S" := (forall x y, R x y -> S x y) (at level 70).
  Notation "R '=2' S"  := (forall x y, R x y <-> S x y) (at level 70).
End ARSNotations.

Import ARSNotations.

(* Relational composition *)

Definition rcomp X Y Z (R : X -> Y -> Prop) (S : Y -> Z -> Prop)
: X -> Z -> Prop :=
  fun x z => exists y, R x y /\ S y z.

(* Power predicates *)

Require Import Arith.
Definition pow X R n : X -> X -> Prop := it (rcomp R) n eq.

Definition functional {X Y} (R: X -> Y -> Prop) := forall x y1 y2, R x y1 -> R x y2 -> y1 = y2.
Definition terminal {X Y} (R: X -> Y -> Prop) x:= forall y, ~ R x y.

Section FixX.
  Variable X : Type.
  Implicit Types R S : X -> X -> Prop.
  Implicit Types x y z : X.

  Definition reflexive R := forall x, R x x.
  Definition symmetric R := forall x y, R x y -> R y x.
  Definition transitive R := forall x y z, R x y -> R y z -> R x z.

  (* Reflexive transitive closure *)

  Inductive star R : X -> X -> Prop :=
  | starR x : star R x x
  | starC x y z : R x y -> star R y z -> star R x z.

  Definition evaluates R x y := star R x y /\ terminal R y.

  (* Making first argument a non-uniform parameter doesn't simplify the induction principle. *)

  Lemma star_simpl_ind R (p : X -> Prop) y :
    p y ->
    (forall x x', R x x' -> star R x' y -> p x' -> p x) ->
    forall x, star R x y -> p x.
  Proof.
    intros A B. induction 1; eauto.
  Qed.

  Lemma star_trans R:
    transitive (star R).
  Proof.
    induction 1; eauto using star.
  Qed.

  Lemma R_star R: R <=2 star R.
  Proof.
    eauto using star.
  Qed.

  Instance star_PO R: PreOrder (star R).
  Proof.
    constructor;repeat intro;try eapply star_trans;  now eauto using star.
  Qed.

  (* Power characterization *)

  Lemma star_pow R x y :
    star R x y <-> exists n, pow R n x y.
  Proof.
    split; intros A.
    - induction A as [|x x' y B _ [n IH]].
      + exists 0. reflexivity.
               + exists (S n), x'. auto.
               - destruct A as [n A].
                 revert x A. induction n; intros x A.
                 + destruct A. constructor.
                 + destruct A as [x' [A B]]. econstructor; eauto.
  Qed.

  Lemma pow_star R x y n:
    pow R n x y -> star R x y.
  Proof.
    intros A. erewrite star_pow. eauto.
  Qed.

  (* Equivalence closure *)

  Inductive ecl R : X -> X -> Prop :=
  | eclR x : ecl R x x
  | eclC x y z : R x y -> ecl R y z -> ecl R x z
  | eclS x y z : R y x -> ecl R y z -> ecl R x z.

  Lemma ecl_trans R :
    transitive (ecl R).
  Proof.
    induction 1; eauto using ecl.
  Qed.

  Lemma ecl_sym R :
    symmetric (ecl R).
  Proof.
    induction 1; eauto using ecl, (@ecl_trans R).
  Qed.

  Lemma star_ecl R :
    star R <=2 ecl R.
  Proof.
    induction 1; eauto using ecl.
  Qed.

  (* Diamond, confluence, Church-Rosser *)

  Definition joinable R x y :=
    exists z, R x z /\ R y z.

  Definition diamond R :=
    forall x y z, R x y -> R x z -> joinable R y z.

  Definition confluent R := diamond (star R).

  Definition semi_confluent R :=
    forall x y z, R x y -> star R x z -> joinable (star R) y z.

  Definition church_rosser R :=
    ecl R <=2 joinable (star R).

  Goal forall R, diamond R -> semi_confluent R.
  Proof.
    intros R A x y z B C.
    revert x C y B.
    refine (star_simpl_ind _ _).
    - intros y C. exists y. eauto using star.
    - intros x x' C D IH y E.
      destruct (A _ _ _ C E) as [v [F G]].
      destruct (IH _ F) as [u [H I]].
      assert (J:= starC G H).
      exists u. eauto using star.
  Qed.

  Lemma diamond_to_semi_confluent R :
    diamond R -> semi_confluent R.
  Proof.
    intros A x y z B C. revert y B.
    induction C as [|x x' z D _ IH]; intros y B.
    - exists y. eauto using star.
             - destruct (A _ _ _ B D) as [v [E F]].
               destruct (IH _ F) as [u [G H]].
               exists u. eauto using star.
  Qed.

  Lemma semi_confluent_confluent R :
    semi_confluent R <-> confluent R.
  Proof.
    split; intros A x y z B C.
    - revert y B.
      induction C as [|x x' z D _ IH]; intros y B.
      + exists y. eauto using star.
               + destruct (A _ _ _ D B) as [v [E F]].
                 destruct (IH _ E) as [u [G H]].
                 exists u. eauto using (@star_trans R).
               - apply (A x y z); eauto using star.
  Qed.

  Lemma diamond_to_confluent R :
    diamond R -> confluent R.
  Proof.
    intros A. apply semi_confluent_confluent, diamond_to_semi_confluent, A.
  Qed.

  Lemma confluent_CR R :
    church_rosser R <-> confluent R.
  Proof.
    split; intros A.
    - intros x y z B C. apply A.
      eauto using (@ecl_trans R), star_ecl, (@ecl_sym R).
    - intros x y B. apply semi_confluent_confluent in A.
      induction B as [x|x x' y C B IH|x x' y C B IH].
      + exists x. eauto using star.
               + destruct IH as [z [D E]]. exists z. eauto using star.
               + destruct IH as [u [D E]].
                 destruct (A _ _ _ C D) as [z [F G]].
                 exists z. eauto using (@star_trans R).
  Qed.

  (* End Semantics Library *)

  (* Uniform confluence and parametrized confluence *)

  Definition uniform_confluent (R : X -> X -> Prop ) := forall s t1 t2, R s t1 -> R s t2 -> t1 = t2 \/ exists u, R t1 u /\ R t2 u.

  Lemma functional_uc R :
    functional R -> uniform_confluent R.
  Proof.
    intros F ? ? ? H1 H2. left. eapply F. all:eauto.
  Qed.

  Lemma pow_add R n m (s t : X) : pow R (n + m) s t <-> rcomp (pow R n) (pow R m) s t.
  Proof.
    revert m s t; induction n; intros m s t.
    - simpl. split; intros. econstructor. split. unfold pow. simpl. reflexivity. eassumption.
      destruct H as [u [H1 H2]]. unfold pow in H1. simpl in *. subst s. eassumption.
    - simpl in *; split; intros.
      + destruct H as [u [H1 H2]].
        change (it (rcomp R) (n + m) eq) with (pow R (n+m)) in H2.
        rewrite IHn in H2.
        destruct H2 as [u' [A B]]. unfold pow in A.
        econstructor.
        split. econstructor. repeat split; repeat eassumption. eassumption.
      + destruct H as [u [H1 H2]].
        destruct H1 as [u' [A B]].
        econstructor.  split. eassumption. change (it (rcomp R) (n + m) eq) with (pow R (n + m)).
        rewrite IHn. econstructor. split; eassumption.
  Qed.

  Lemma rcomp_eq (R S R' S' : X -> X -> Prop) (s t : X) : (R =2 R') -> (S =2 S') -> (rcomp R S s t <-> rcomp R' S' s t).
  Proof.
    intros A B.
    split; intros H; destruct H as [u [H1 H2]];
    eapply A in H1; eapply B in H2;
    econstructor; split; eassumption.
  Qed.

  Lemma eq_ref : forall (R : X -> X -> Prop), R =2 R.
  Proof.
    split; tauto.
  Qed.

  Lemma rcomp_1 (R : X -> X -> Prop): R =2 pow R 1.
  Proof.
    intros s t; split;unfold pow in *; simpl in *; intros H.
    - econstructor. split; eauto.
    - destruct H as [u [H1 H2]]; subst u; eassumption.
  Qed.

  Lemma parametrized_semi_confluence (R : X -> X -> Prop) (m : nat) (s t1 t2 : X) :
    uniform_confluent R ->
    pow R m s t1 ->
    R s t2 ->
    exists k l u,
      k <= 1 /\ l <= m /\ pow R k t1 u /\ pow R l t2 u /\ m + k = S l.
  Proof.
    intros unifConfR; revert s t1 t2; induction m; intros s t1 t2 s_to_t1 s_to_t2.
    - unfold pow in s_to_t1. simpl in *. subst s.
      exists 1, 0, t2.
      repeat split; try lia.
      econstructor. split; try eassumption; econstructor.
    - destruct s_to_t1 as [v [s_to_v v_to_t1]].
      destruct (unifConfR _ _ _ s_to_v s_to_t2) as [H | [u [v_to_u t2_to_u]]].
      + subst v. eexists 0, m, t1; repeat split; try lia; eassumption.
      + destruct (IHm _ _ _ v_to_t1 v_to_u) as [k [l [u' H]]].
        eexists k, (S l), u'; repeat split; try lia; try tauto.
        econstructor. split. eassumption. tauto.
  Qed.

  Lemma rcomp_comm R m (s t : X) : rcomp R (it (rcomp R) m eq) s t <-> rcomp (it (rcomp R) m eq) R s t.
  Proof.
    split; intros H;
    [rewrite (rcomp_eq s t (rcomp_1 R) (eq_ref _)) in H;
      rewrite (rcomp_eq s t (eq_ref _) (rcomp_1 R)) |
     rewrite (rcomp_eq s t (eq_ref _) (rcomp_1 R)) in H;
       rewrite (rcomp_eq s t (rcomp_1 R) (eq_ref _))];
    change ((it (rcomp R) m eq)) with (pow R m) in *;
    try rewrite <- pow_add in *;
    rewrite Nat.add_comm; eassumption.
  Qed.

  Lemma parametrized_confluence (R : X -> X -> Prop) (m n : nat) (s t1 t2 : X) :
    uniform_confluent R ->
    pow R m s t1 ->
    pow R n s t2 ->
    exists k l u,
      k <= n /\ l <= m /\ pow R k t1 u /\ pow R l t2 u /\ m + k = n + l.
  Proof.
    revert n s t1 t2; induction m; intros n s t1 t2 unifConR s_to_t1 s_to_t2.
    - unfold pow in s_to_t1. simpl in s_to_t1. subst s.
      exists n, 0, t2. repeat split; try now lia. eassumption.
    - unfold pow in s_to_t1. simpl in *.
      destruct s_to_t1 as [v [s_to_v v_to_t1]].
      destruct (parametrized_semi_confluence unifConR s_to_t2 s_to_v) as
          [k [l [u [k_lt_1 [l_lt_n [t2_to_u [v_to_u H]]]]]]].
      destruct (IHm _ _ _ _ unifConR v_to_t1 v_to_u) as
          [l'[k'[u'[l'_lt_l [k'_lt_m [t1_to_u' [u_to_u' H2]]]]]]].
      exists l', (k + k'), u'.
      repeat split; try lia. eassumption.
      rewrite pow_add.
      econstructor; split; eassumption.
  Qed.

  Lemma uniform_confluent_noloop R x y:
    uniform_confluent R ->
    star R x y -> (forall y', ~ R y y') ->
    ~exists z k, star R x z /\ pow R (S k) z z.
  Proof.
    intros UC (k0&R0)%star_pow Term (z&k1&R1&RL).
    induction R1 in k0,RL,R0|-*.
    -edestruct parametrized_confluence with (m:=k0) (n:=S k1 + k0) as (i0&i1&?&?&?&?&?&?).
     1,2:eassumption.
     now eapply pow_add;eexists;split;eassumption.
     destruct i0. destruct i1.
     +now lia.
     +destruct H2 as (?&?&_). edestruct Term. eauto.
     +destruct H1 as (?&?&_). edestruct Term. eauto.
    -edestruct parametrized_semi_confluence with (R:=R) (2:= R0) as (i0&?&?&?&?&?&?&?). 1,2:eassumption.
     destruct i0. 2:{ destruct H2 as (?&?&_). edestruct Term. eauto. }
     cbn in H2;inv H2.
     eapply IHR1. all:eauto.
  Qed.

 Lemma uc_terminal R x y z n:
    uniform_confluent R ->
    R x y ->
    pow R n x z ->
    terminal R z ->
    exists n' , n = S n' /\ pow R n' y z.
  Proof.
    intros ? ? ? ter. edestruct parametrized_semi_confluence as (k&?&?&?&?&R'&?&?). 1-3:now eauto.
    destruct k as [|].
    -inv R'. rewrite <- plus_n_O in *. eauto.
    -edestruct R' as (?&?&?). edestruct ter. eauto.
  Qed.

End FixX.


Set Implicit Arguments.
Unset Strict Implicit.
Require Import List. Import ListNotations.
Require Import QArith.
Require Import Coq.micromega.Lqa.

Require Import GrappaCoq.Domain.

(** A Poset instance for Coq rationals. *)
Section rationalPoset.
  Instance rationalOrder : PosetOrder := Qle.
  Program Instance rationalPoset : Poset rationalOrder.
  Next Obligation. unfold le, rationalOrder; lra. Qed.
  Next Obligation. unfold equiv, le, rationalOrder in *; lra. Qed.
End rationalPoset.

Section rationalLemmas.
  Existing Instance rationalOrder.
  Existing Instance rationalPoset.

  Lemma Qdiv_mult_shift :
    forall x y z, ~ y == 0 -> x / y * z == x * z / y.
  Proof. intros x y z Hy; field; auto. Qed.

  Lemma Qdiv_2_not_equiv x :
    0 < x ->
    ~ x / (2 # 1) ~~ x.
  Proof.
    intros H0 [H1 H2]; unfold le, rationalOrder in *.
    assert (H4: x * (2#1) == x / (2#1) * (2#1)).
    { apply Qmult_inj_r; lra. }
    rewrite Qdiv_mult_shift in H4; try lra.
    rewrite Qdiv_mult_l in H4; lra.
  Qed.

  Lemma Qplus_Qdiv_2_not_equiv x y :
    0 < x ->
    ~ y == 0 ->
    ~ y == x ->
    ~ (x + y) / (2 # 1) ~~ x.
  Proof.
    intros H0 H1 H2 [H3 H4]; unfold le, rationalOrder in *.
    assert (H6: x * (2#1) == (x + y) / (2#1) * (2#1)).
    { apply Qmult_inj_r; lra. }
    rewrite Qdiv_mult_shift in H6; try lra.
    rewrite Qdiv_mult_l in H6; lra.
  Qed.

  Lemma Qdiv_2_le x :
    0 < x ->
    x / (2 # 1) <= x.
  Proof. intros H0; apply Qle_shift_div_r; lra. Qed.
End rationalLemmas.


Require Import Arith.
Definition f x := x + 100.

Compute f 10.

Definition g x := x - 100.

Compute g 110.

Theorem g_f : forall x, g (f x) = x.
Proof.
  intros x. unfold f, g.
  rewrite Nat.add_sub. reflexivity.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


(* Exercise 30 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_030 : (~A /\ ~B) -> ~((A -> B) -> B).
Proof.
imp_i Sigma.
neg_i B first.
con_e2 (~A).
hyp Sigma.
neg_e (A).
con_e1 (~B).
hyp Sigma.
neg_e' B second.
con_e2 (~A).
hyp Sigma.
imp_e (A -> B).
hyp first.
imp_i third.
neg_e A.
hyp second.
hyp third.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf2 : natural) (lf1 : natural) (y : natural) (x : natural)
  : natural := plus y 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 (lf2 : natural) : natural := mult lf2 (Succ Zero).


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".

From LF Require Export Lists.

Inductive natlist : Type :=
| nat_nil
| nat_cons (n : nat) (lst : natlist).

Inductive boollist : Type :=
| bool_nil
| bool_cons (b : bool) (lst : boollist).

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

Check list : Type -> Type.

Check (nil nat) : list nat.

Check (cons nat 3 (nil nat)) : list nat.

Check nil : forall (X : Type), list X.

Check cons : forall (X : Type), X -> list X -> list X.

Check (cons nat 2 (cons nat 2 (nil nat))) : list nat.

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Example test_repeat_1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.

Example test_repeat_2 :
  repeat bool false 2 = cons bool false (cons bool false (nil bool)).
Proof. reflexivity. Qed.

Module MumbleGrumble.
Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.
Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).

(*
d (b a 5) - No
d mumble (b a 5) - Yes
d bool (b a 5) - No
e bool true - Yes
e mumble (b c 0) - Yes
e bool (b c 0) - No
c - No
*)
End MumbleGrumble.

Fixpoint repeat' X x count : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check repeat' : forall X : Type, X -> nat -> list X.

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0 => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Definition  list_123 := cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

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

Definition  list_123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X: Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.

Fixpoint app {X : Type} (l_1 l_2 : list X) : list X :=
  match l_1 with
  | nil => l_2
  | cons h t => cons h (app t l_2)
  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 _ t => S (length t)
  end.

  Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Fail Definition mynil := nil.

Definition mynil : list nat := nil.

Check @nil : forall X : Type, list X.

Definition mynil' := @nil nat.

Definition mynil'' := @nil. Check mynil''.

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).

Definition list_123''' := [1; 2; 3].

Theorem app_assoc : forall X (lst1 lst2 lst3 : list X),
  (lst1 ++ lst2) ++ lst3 = lst1 ++ (lst2 ++ lst3).
Proof.
  intros X lst1 lst2 lst3.
  induction lst1 as [| h1 t1].
  - simpl. reflexivity.
  - simpl. rewrite IHt1. reflexivity.
Qed.

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros X l.
  induction l as [|h t].
  - simpl. reflexivity.
  - simpl. rewrite IHt. reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2.
  induction l1 as [|h1 t1].
  - simpl. reflexivity.
  - simpl. rewrite IHt1. reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  induction l1 as [|h1 t1].
  - simpl. rewrite app_nil_r. reflexivity.
  - simpl. rewrite <- app_assoc. rewrite <- IHt1. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l.
  induction l as [|h t].
  - simpl. reflexivity.
  - simpl. rewrite rev_app_distr. rewrite IHt. simpl. reflexivity.
Qed.

(* Polymorphic pairs *)

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.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X * Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Example combine_ex : combine [1;2] [3;4] = [(1,3); (2,4)].
Proof. reflexivity. Qed.

(* Polymorphic Options *)

Module OptionPlayGround.

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

Arguments Some {X}.
Arguments None {X}.

End OptionPlayGround.

Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
  match l with
  | [] => None
  | a :: l' => match n with
              | 0 => 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.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

Check @combine : forall X Y : Type, list X -> list Y -> list (X * Y).
Compute (combine [1;2] [false;false;true;true]).

Fixpoint split {X Y : Type} (l : list (X * Y)) : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (m, n) :: t => match (split t) with
             | (l1, l2) => (m :: l1, n :: l2)
             end
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. simpl. reflexivity. Qed.

Theorem split_pair : forall (X Y : Type) (x : X) (y : Y),
  split [(x, y)] = ([x], [y]).
Proof.
  intros X Y x y.
  simpl.
  reflexivity.
Qed.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | h :: _ => Some h
  end.
Check @hd_error : forall X : Type, list X -> option X.
Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. simpl. reflexivity. Qed.
Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof. simpl. reflexivity. Qed.

(* Higher-order functions *)

Definition doit3times {X : Type} (f : X -> X) (n : X) :=
  f (f (f n)).

Check @doit3times : forall X : Type, (X -> X) -> X -> X.

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity. Qed.

Fixpoint filter {X : Type} (test : X -> bool) (l : list X) : list X :=
  match l with
  | [] => []
  | h :: t => if test h then h :: (filter test t) else filter test t
  end.

Example test_filter1: filter even [1;2;3;4] = [2;4].
  Proof. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.
Example test_filter2:
      filter length_is_1
             [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
    = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Definition countoddmembers' (l:list nat) : nat :=
  length (filter odd l).
Example test_countoddmembers'1: countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers'3: countoddmembers' nil = 0.
Proof. reflexivity. Qed.

Example test_anon_fun' : doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity. Qed.

Example test_filter2':
    filter (fun l => (length l) =? 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => (even n) && (leb 7 n)) l.
Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
  Proof. reflexivity. Qed.
Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
  Proof. reflexivity. Qed.

Definition partition {X : Type} (test : X -> bool) (l : list X) : list X * list X :=
  (filter test l, filter (fun n => negb (test n)) l).
Example test_partition1: partition odd [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y : Type} (f : X->Y) (l : list X) : list Y :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.
Example test_map2: map odd [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.
Example test_map3: map (fun n => [even n;odd n]) [2;1;2;5] = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity. Qed.

Lemma map_app : forall {X Y : Type} (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = (map f l1) ++ (map f l2).
Proof.
  intros X Y f l1 l2.
  induction l1 as [|h1 t1].
  - simpl. reflexivity.
  - simpl. rewrite <- IHt1. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l as [|h t].
  - simpl. reflexivity.
  - simpl. rewrite <- IHt. rewrite map_app. simpl. reflexivity.
Qed.
Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X) : list Y :=
  match l with
  | [] => []
  | h :: t => (f h) ++ (flat_map f t)
  end.

Example test_flat_map1: flat_map (fun n => [n;n;n]) [1;5;4] = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. simpl. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X) : option Y :=
  match xo with
  | None => None
  | Some x => Some (f x)
  end.

Fixpoint fold {X Y : Type} (f : X->Y->Y) (l : list X) (b : Y) : Y :=
  match l with
  | [] => b
  | h :: t => f h (fold f t b)
  end.

Check (fold andb) : list bool -> bool -> bool.
Example fold_example1 :
  fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 :
  fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 :
  fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

Definition constfun {X: Type} (x: X) : nat -> X :=
  fun (k:nat) => x.
Definition ftrue := constfun true.
Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Definition plus3 := plus 3.
Check plus3 : nat -> nat.
Example test_plus3 : plus3 4 = 7.
Proof. reflexivity. Qed.
Example test_plus3' : doit3times plus3 0 = 9.
Proof. reflexivity. Qed.
Example test_plus3'' : doit3times (plus 3) 0 = 9.
Proof. reflexivity. Qed.

Module Exercises.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.
Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l.
  induction l as [|h t].
  - reflexivity.
  - simpl. rewrite <- IHt. reflexivity.
Qed.

Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y :=
  fold (fun x b => (f x) :: b) l [].

Theorem fold_map_correct : forall (X Y : Type) (f: X -> Y) (l : list X),
  map f l = fold_map f l.
Proof.
  intros X Y f l.
  induction l as [|h t].
  - reflexivity.
  - simpl. rewrite IHt. reflexivity.
Qed.

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z :=
f (x, y).

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z :=
f (fst p) (snd p).

Example test_map1': map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros X Y Z f x y.
  reflexivity.
Qed.

Theorem curry_uncurry : forall (X Y Z : Type) (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros X Y Z f p.
  destruct p.
  reflexivity.
Qed.

(* Church Numerals (Advanced) *)
Module Church.
Definition cnat := forall X : Type, (X -> X) -> X -> X.

Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

Definition three : cnat := @doit3times.

Definition zero' : cnat :=
  fun (X : Type) (succ : X -> X) (zero : X) => zero.
Definition one' : cnat :=
  fun (X : Type) (succ : X -> X) (zero : X) => succ zero.
Definition two' : cnat :=
  fun (X : Type) (succ : X -> X) (zero : X) => succ (succ zero).

Example zero_church_peano : zero nat S O = 0.
Proof. reflexivity. Qed.
Example one_church_peano : one nat S O = 1.
Proof. reflexivity. Qed.
Example two_church_peano : two nat S O = 2.
Proof. reflexivity. Qed.

Definition scc (n : cnat) : cnat :=
  fun (X : Type) (succ : X -> X) (x : X) => n X succ(succ x).

Example scc_1 : scc zero = one.
Proof. reflexivity. Qed.
Example scc_2 : scc one = two.
Proof. reflexivity. Qed.
Example scc_3 : scc two = three.
Proof. reflexivity. Qed.

Definition plus (n m : cnat) : cnat :=
  fun (X : Type) (succ : X -> X) (x : X) => n X succ (m X succ x).

Compute (plus zero zero).

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.
Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.
Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

Definition mult (n m : cnat) : cnat :=
  fun (X : Type) (succ : X -> X) => n X (m X succ).

Compute (mult zero one).

Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.
Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.
Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

Definition exp (n m : cnat) : cnat :=
  fun (X : Type) => m (X -> X) (n X).
Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.
Example exp_2 : exp three zero = one.
Proof. reflexivity. Qed.
Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.

End Church.
End Exercises.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

Require Import Orders OrdersTac OrdersFacts Setoid Morphisms Basics.

(** * A Generic construction of min and max *)

(** ** First, an interface for types with [max] and/or [min] *)

Module Type HasMax (Import E:EqLe').
 Parameter Inline max : t -> t -> t.
 Parameter max_l : forall x y, y<=x -> max x y == x.
 Parameter max_r : forall x y, x<=y -> max x y == y.
End HasMax.

Module Type HasMin (Import E:EqLe').
 Parameter Inline min : t -> t -> t.
 Parameter min_l : forall x y, x<=y -> min x y == x.
 Parameter min_r : forall x y, y<=x -> min x y == y.
End HasMin.

Module Type HasMinMax (E:EqLe) := HasMax E <+ HasMin E.

(** ** Any [OrderedTypeFull] can be equipped by [max] and [min]
    based on the compare function. *)

Definition gmax {A} (cmp : A->A->comparison) x y :=
 match cmp x y with Lt => y | _ => x end.
Definition gmin {A} (cmp : A->A->comparison) x y :=
 match cmp x y with Gt => y | _ => x end.

Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O.

 Definition max := gmax O.compare.
 Definition min := gmin O.compare.

 Lemma ge_not_lt : forall x y, y<=x -> x<y -> False.
 Proof.
 intros x y H H'.
 apply (StrictOrder_Irreflexive x).
 rewrite le_lteq in *; destruct H as [H|H].
 transitivity y; auto.
 rewrite H in H'; auto.
 Qed.

 Lemma max_l : forall x y, y<=x -> max x y == x.
 Proof.
 intros. unfold max, gmax. case compare_spec; auto with relations.
 intros; elim (ge_not_lt x y); auto.
 Qed.

 Lemma max_r : forall x y, x<=y -> max x y == y.
 Proof.
 intros. unfold max, gmax. case compare_spec; auto with relations.
 intros; elim (ge_not_lt y x); auto.
 Qed.

 Lemma min_l : forall x y, x<=y -> min x y == x.
 Proof.
 intros. unfold min, gmin. case compare_spec; auto with relations.
 intros; elim (ge_not_lt y x); auto.
 Qed.

 Lemma min_r : forall x y, y<=x -> min x y == y.
 Proof.
 intros. unfold min, gmin. case compare_spec; auto with relations.
 intros; elim (ge_not_lt x y); auto.
 Qed.

End GenericMinMax.

(** ** Consequences of the minimalist interface: facts about [max]. *)

Module MaxLogicalProperties (Import O:TotalOrder')(Import M:HasMax O).
 Module Import T := !MakeOrderTac O.

(** An alternative caracterisation of [max], equivalent to
    [max_l /\ max_r] *)

Lemma max_spec : forall n m,
  (n < m /\ max n m == m)  \/ (m <= n /\ max n m == n).
Proof.
 intros n m.
 destruct (lt_total n m); [left|right].
 split; auto. apply max_r. rewrite le_lteq; auto.
 assert (m <= n) by (rewrite le_lteq; intuition).
 split; auto. apply max_l; auto.
Qed.

(** A more symmetric version of [max_spec], based only on [le].
    Beware that left and right alternatives overlap. *)

Lemma max_spec_le : forall n m,
 (n <= m /\ max n m == m) \/ (m <= n /\ max n m == n).
Proof.
 intros. destruct (max_spec n m); [left|right]; intuition; order.
Qed.

Instance : Proper (eq==>eq==>iff) le.
Proof. repeat red. intuition order. Qed.

Instance max_compat : Proper (eq==>eq==>eq) max.
Proof.
intros x x' Hx y y' Hy.
assert (H1 := max_spec x y). assert (H2 := max_spec x' y').
set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'.
rewrite <- Hx, <- Hy in *.
destruct (lt_total x y); intuition order.
Qed.

(** A function satisfying the same specification is equal to [max]. *)

Lemma max_unicity : forall n m p,
 ((n < m /\ p == m)  \/ (m <= n /\ p == n)) ->  p == max n m.
Proof.
 intros. assert (Hm := max_spec n m).
 destruct (lt_total n m); intuition; order.
Qed.

Lemma max_unicity_ext : forall f,
 (forall n m, (n < m /\ f n m == m)  \/ (m <= n /\ f n m == n)) ->
 (forall n m, f n m == max n m).
Proof.
 intros. apply max_unicity; auto.
Qed.

(** [max] commutes with monotone functions. *)

Lemma max_mono: forall f,
 (Proper (eq ==> eq) f) ->
 (Proper (le ==> le) f) ->
 forall x y, max (f x) (f y) == f (max x y).
Proof.
 intros f Eqf Lef x y.
 destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E;
  destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto.
 assert (f x <= f y) by (apply Lef; order). order.
 assert (f y <= f x) by (apply Lef; order). order.
Qed.

(** *** Semi-lattice algebraic properties of [max] *)

Lemma max_id : forall n, max n n == n.
Proof.
 intros. destruct (max_spec n n); intuition.
Qed.

Notation max_idempotent := max_id (only parsing).

Lemma max_assoc : forall m n p, max m (max n p) == max (max m n) p.
Proof.
 intros.
 destruct (max_spec n p) as [(H,Eq)|(H,Eq)]; rewrite Eq.
 destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'.
 destruct (max_spec m p); intuition; order. order.
 destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'. order.
 destruct (max_spec m p); intuition; order.
Qed.

Lemma max_comm : forall n m, max n m == max m n.
Proof.
 intros.
 destruct (max_spec n m) as [(H,Eq)|(H,Eq)]; rewrite Eq.
 destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order.
 destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order.
Qed.

(** *** Least-upper bound properties of [max] *)

Lemma le_max_l : forall n m, n <= max n m.
Proof.
 intros; destruct (max_spec n m); intuition; order.
Qed.

Lemma le_max_r : forall n m, m <= max n m.
Proof.
 intros; destruct (max_spec n m); intuition; order.
Qed.

Lemma max_l_iff : forall n m, max n m == n <-> m <= n.
Proof.
 split. intro H; rewrite <- H. apply le_max_r. apply max_l.
Qed.

Lemma max_r_iff : forall n m, max n m == m <-> n <= m.
Proof.
 split. intro H; rewrite <- H. apply le_max_l. apply max_r.
Qed.

Lemma max_le : forall n m p, p <= max n m -> p <= n \/ p <= m.
Proof.
 intros n m p H; destruct (max_spec n m);
  [right|left]; intuition; order.
Qed.

Lemma max_le_iff : forall n m p, p <= max n m <-> p <= n \/ p <= m.
Proof.
 intros. split. apply max_le.
 destruct (max_spec n m); intuition; order.
Qed.

Lemma max_lt_iff : forall n m p, p < max n m <-> p < n \/ p < m.
Proof.
 intros. destruct (max_spec n m); intuition;
  order || (right; order) || (left; order).
Qed.

Lemma max_lub_l : forall n m p, max n m <= p -> n <= p.
Proof.
 intros; destruct (max_spec n m); intuition; order.
Qed.

Lemma max_lub_r : forall n m p, max n m <= p -> m <= p.
Proof.
 intros; destruct (max_spec n m); intuition; order.
Qed.

Lemma max_lub : forall n m p, n <= p -> m <= p -> max n m <= p.
Proof.
 intros; destruct (max_spec n m); intuition; order.
Qed.

Lemma max_lub_iff : forall n m p, max n m <= p <-> n <= p /\ m <= p.
Proof.
 intros; destruct (max_spec n m); intuition; order.
Qed.

Lemma max_lub_lt : forall n m p, n < p -> m < p -> max n m < p.
Proof.
 intros; destruct (max_spec n m); intuition; order.
Qed.

Lemma max_lub_lt_iff : forall n m p, max n m < p <-> n < p /\ m < p.
Proof.
 intros; destruct (max_spec n m); intuition; order.
Qed.

Lemma max_le_compat_l : forall n m p, n <= m -> max p n <= max p m.
Proof.
 intros.
 destruct (max_spec p n) as [(LT,E)|(LE,E)]; rewrite E.
 assert (LE' := le_max_r p m). order.
 apply le_max_l.
Qed.

Lemma max_le_compat_r : forall n m p, n <= m -> max n p <= max m p.
Proof.
 intros. rewrite (max_comm n p), (max_comm m p).
 auto using max_le_compat_l.
Qed.

Lemma max_le_compat : forall n m p q, n <= m -> p <= q ->
 max n p <= max m q.
Proof.
 intros  n m p q Hnm Hpq.
 assert (LE := max_le_compat_l _ _ m Hpq).
 assert (LE' := max_le_compat_r _ _ p Hnm).
 order.
Qed.

End MaxLogicalProperties.

(** ** Properties concernant [min], then both [min] and [max].

   To avoid too much code duplication, we exploit that [min] can be
   seen as a [max] of the reversed order.
*)

Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O).
 Include MaxLogicalProperties O M.
 Import T.

 Module ORev := TotalOrderRev O.
 Module MRev <: HasMax ORev.
  Definition max x y := M.min y x.
  Definition max_l x y := M.min_r y x.
  Definition max_r x y := M.min_l y x.
 End MRev.
 Module MPRev := MaxLogicalProperties ORev MRev.

Instance min_compat : Proper (eq==>eq==>eq) min.
Proof. intros x x' Hx y y' Hy. apply MPRev.max_compat; assumption. Qed.

Lemma min_spec : forall n m,
 (n < m /\ min n m == n) \/ (m <= n /\ min n m == m).
Proof. intros. exact (MPRev.max_spec m n). Qed.

Lemma min_spec_le : forall n m,
 (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m).
Proof. intros. exact (MPRev.max_spec_le m n). Qed.

Lemma min_mono: forall f,
 (Proper (eq ==> eq) f) ->
 (Proper (le ==> le) f) ->
 forall x y, min (f x) (f y) == f (min x y).
Proof.
 intros. apply MPRev.max_mono; auto. compute in *; eauto.
Qed.

Lemma min_unicity : forall n m p,
 ((n < m /\ p == n)  \/ (m <= n /\ p == m)) ->  p == min n m.
Proof. intros n m p. apply MPRev.max_unicity. Qed.

Lemma min_unicity_ext : forall f,
 (forall n m, (n < m /\ f n m == n)  \/ (m <= n /\ f n m == m)) ->
 (forall n m, f n m == min n m).
Proof. intros f H n m. apply MPRev.max_unicity, H; auto. Qed.

Lemma min_id : forall n, min n n == n.
Proof. intros. exact (MPRev.max_id n). Qed.

Notation min_idempotent := min_id (only parsing).

Lemma min_assoc : forall m n p, min m (min n p) == min (min m n) p.
Proof. intros. symmetry; apply MPRev.max_assoc. Qed.

Lemma min_comm : forall n m, min n m == min m n.
Proof. intros. exact (MPRev.max_comm m n). Qed.

Lemma le_min_r : forall n m, min n m <= m.
Proof. intros. exact (MPRev.le_max_l m n). Qed.

Lemma le_min_l : forall n m, min n m <= n.
Proof. intros. exact (MPRev.le_max_r m n). Qed.

Lemma min_l_iff : forall n m, min n m == n <-> n <= m.
Proof. intros n m. exact (MPRev.max_r_iff m n). Qed.

Lemma min_r_iff : forall n m, min n m == m <-> m <= n.
Proof. intros n m. exact (MPRev.max_l_iff m n). Qed.

Lemma min_le : forall n m p, min n m <= p -> n <= p \/ m <= p.
Proof. intros n m p H. destruct (MPRev.max_le _ _ _ H); auto. Qed.

Lemma min_le_iff : forall n m p, min n m <= p <-> n <= p \/ m <= p.
Proof. intros n m p. rewrite (MPRev.max_le_iff m n p); intuition. Qed.

Lemma min_lt_iff : forall n m p, min n m < p <-> n < p \/ m < p.
Proof. intros n m p. rewrite (MPRev.max_lt_iff m n p); intuition. Qed.

Lemma min_glb_l : forall n m p, p <= min n m -> p <= n.
Proof. intros n m. exact (MPRev.max_lub_r m n). Qed.

Lemma min_glb_r : forall n m p, p <= min n m -> p <= m.
Proof. intros n m. exact (MPRev.max_lub_l m n). Qed.

Lemma min_glb : forall n m p, p <= n -> p <= m -> p <= min n m.
Proof. intros. apply MPRev.max_lub; auto. Qed.

Lemma min_glb_iff : forall n m p, p <= min n m <-> p <= n /\ p <= m.
Proof. intros. rewrite (MPRev.max_lub_iff m n p); intuition. Qed.

Lemma min_glb_lt : forall n m p, p < n -> p < m -> p < min n m.
Proof. intros. apply MPRev.max_lub_lt; auto. Qed.

Lemma min_glb_lt_iff : forall n m p, p < min n m <-> p < n /\ p < m.
Proof. intros. rewrite (MPRev.max_lub_lt_iff m n p); intuition. Qed.

Lemma min_le_compat_l : forall n m p, n <= m -> min p n <= min p m.
Proof. intros n m. exact (MPRev.max_le_compat_r m n). Qed.

Lemma min_le_compat_r : forall n m p, n <= m -> min n p <= min m p.
Proof. intros n m. exact (MPRev.max_le_compat_l m n). Qed.

Lemma min_le_compat : forall n m p q, n <= m -> p <= q ->
 min n p <= min m q.
Proof. intros. apply MPRev.max_le_compat; auto. Qed.

(** *** Combined properties of min and max *)

Lemma min_max_absorption : forall n m, max n (min n m) == n.
Proof.
 intros.
 destruct (min_spec n m) as [(C,E)|(C,E)]; rewrite E.
 apply max_l. order.
 destruct (max_spec n m); intuition; order.
Qed.

Lemma max_min_absorption : forall n m, min n (max n m) == n.
Proof.
 intros.
 destruct (max_spec n m) as [(C,E)|(C,E)]; rewrite E.
 destruct (min_spec n m) as [(C',E')|(C',E')]; auto. order.
 apply min_l; auto. order.
Qed.

(** Distributivity *)

Lemma max_min_distr : forall n m p,
 max n (min m p) == min (max n m) (max n p).
Proof.
 intros. symmetry. apply min_mono.
 eauto with *.
 repeat red; intros. apply max_le_compat_l; auto.
Qed.

Lemma min_max_distr : forall n m p,
 min n (max m p) == max (min n m) (min n p).
Proof.
 intros. symmetry. apply max_mono.
 eauto with *.
 repeat red; intros. apply min_le_compat_l; auto.
Qed.

(** Modularity *)

Lemma max_min_modular : forall n m p,
 max n (min m (max n p)) == min (max n m) (max n p).
Proof.
 intros. rewrite <- max_min_distr.
 destruct (max_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *.
 destruct (min_spec m n) as [(C',E')|(C',E')]; rewrite E'.
 rewrite 2 max_l; try order. rewrite min_le_iff; auto.
 rewrite 2 max_l; try order. rewrite min_le_iff; auto.
Qed.

Lemma min_max_modular : forall n m p,
 min n (max m (min n p)) == max (min n m) (min n p).
Proof.
 intros. rewrite <- min_max_distr.
 destruct (min_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *.
 destruct (max_spec m n) as [(C',E')|(C',E')]; rewrite E'.
 rewrite 2 min_l; try order. rewrite max_le_iff; right; order.
 rewrite 2 min_l; try order. rewrite max_le_iff; auto.
Qed.

(** Disassociativity *)

Lemma max_min_disassoc : forall n m p,
 min n (max m p) <= max (min n m) p.
Proof.
 intros. rewrite min_max_distr.
 auto using max_le_compat_l, le_min_r.
Qed.

(** Anti-monotonicity swaps the role of [min] and [max] *)

Lemma max_min_antimono : forall f,
 Proper (eq==>eq) f ->
 Proper (le==>inverse le) f ->
 forall x y, max (f x) (f y) == f (min x y).
Proof.
 intros f Eqf Lef x y.
 destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E;
  destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto.
 assert (f y <= f x) by (apply Lef; order). order.
 assert (f x <= f y) by (apply Lef; order). order.
Qed.

Lemma min_max_antimono : forall f,
 Proper (eq==>eq) f ->
 Proper (le==>inverse le) f ->
 forall x y, min (f x) (f y) == f (max x y).
Proof.
 intros f Eqf Lef x y.
 destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E;
  destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto.
 assert (f y <= f x) by (apply Lef; order). order.
 assert (f x <= f y) by (apply Lef; order). order.
Qed.

End MinMaxLogicalProperties.

(** ** Properties requiring a decidable order *)

Module MinMaxDecProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O).

(** Induction principles for [max]. *)

Lemma max_case_strong : forall n m (P:t -> Type),
  (forall x y, x==y -> P x -> P y) ->
  (m<=n -> P n) -> (n<=m -> P m) -> P (max n m).
Proof.
intros n m P Compat Hl Hr.
destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT].
assert (n<=m) by (rewrite le_lteq; auto).
apply (Compat m), Hr; auto. symmetry; apply max_r; auto.
assert (n<=m) by (rewrite le_lteq; auto).
apply (Compat m), Hr; auto. symmetry; apply max_r; auto.
assert (m<=n) by (rewrite le_lteq; auto).
apply (Compat n), Hl; auto. symmetry; apply max_l; auto.
Defined.

Lemma max_case : forall n m (P:t -> Type),
  (forall x y, x == y -> P x -> P y) ->
  P n -> P m -> P (max n m).
Proof. intros. apply max_case_strong; auto. Defined.

(** [max] returns one of its arguments. *)

Lemma max_dec : forall n m, {max n m == n} + {max n m == m}.
Proof.
 intros n m. apply max_case; auto with relations.
 intros x y H [E|E]; [left|right]; rewrite <-H; auto.
Defined.

(** Idem for [min] *)

Lemma min_case_strong : forall n m (P:O.t -> Type),
 (forall x y, x == y -> P x -> P y) ->
 (n<=m -> P n) -> (m<=n -> P m) -> P (min n m).
Proof.
intros n m P Compat Hl Hr.
destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT].
assert (n<=m) by (rewrite le_lteq; auto).
apply (Compat n), Hl; auto. symmetry; apply min_l; auto.
assert (n<=m) by (rewrite le_lteq; auto).
apply (Compat n), Hl; auto. symmetry; apply min_l; auto.
assert (m<=n) by (rewrite le_lteq; auto).
apply (Compat m), Hr; auto. symmetry; apply min_r; auto.
Defined.

Lemma min_case : forall n m (P:O.t -> Type),
  (forall x y, x == y -> P x -> P y) ->
  P n -> P m -> P (min n m).
Proof. intros. apply min_case_strong; auto. Defined.

Lemma min_dec : forall n m, {min n m == n} + {min n m == m}.
Proof.
 intros. apply min_case; auto with relations.
 intros x y H [E|E]; [left|right]; rewrite <- E; auto with relations.
Defined.

End MinMaxDecProperties.

Module MinMaxProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O).
 Module OT := OTF_to_TotalOrder O.
 Include MinMaxLogicalProperties OT M.
 Include MinMaxDecProperties O M.
 Definition max_l := max_l.
 Definition max_r := max_r.
 Definition min_l := min_l.
 Definition min_r := min_r.
 Notation max_monotone := max_mono.
 Notation min_monotone := min_mono.
 Notation max_min_antimonotone := max_min_antimono.
 Notation min_max_antimonotone := min_max_antimono.
End MinMaxProperties.

(** ** When the equality is Leibniz, we can skip a few [Proper] precondition. *)

Module UsualMinMaxLogicalProperties
 (Import O:UsualTotalOrder')(Import M:HasMinMax O).

 Include MinMaxLogicalProperties O M.

 Lemma max_monotone : forall f, Proper (le ==> le) f ->
  forall x y, max (f x) (f y) = f (max x y).
 Proof. intros; apply max_mono; auto. congruence. Qed.

 Lemma min_monotone : forall f, Proper (le ==> le) f ->
  forall x y, min (f x) (f y) = f (min x y).
 Proof. intros; apply min_mono; auto. congruence. Qed.

 Lemma min_max_antimonotone : forall f, Proper (le ==> inverse le) f ->
  forall x y, min (f x) (f y) = f (max x y).
 Proof. intros; apply min_max_antimono; auto. congruence. Qed.

 Lemma max_min_antimonotone : forall f, Proper (le ==> inverse le) f ->
  forall x y, max (f x) (f y) = f (min x y).
 Proof. intros; apply max_min_antimono; auto. congruence. Qed.

End UsualMinMaxLogicalProperties.

Module UsualMinMaxDecProperties
 (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O).

 Module P := MinMaxDecProperties O M.

 Lemma max_case_strong : forall n m (P:t -> Type),
  (m<=n -> P n) -> (n<=m -> P m) -> P (max n m).
 Proof. intros; apply P.max_case_strong; auto. congruence. Defined.

 Lemma max_case : forall n m (P:t -> Type),
  P n -> P m -> P (max n m).
 Proof. intros; apply max_case_strong; auto. Defined.

 Lemma max_dec : forall n m, {max n m = n} + {max n m = m}.
 Proof. exact P.max_dec. Defined.

 Lemma min_case_strong : forall n m (P:O.t -> Type),
  (n<=m -> P n) -> (m<=n -> P m) -> P (min n m).
 Proof. intros; apply P.min_case_strong; auto. congruence. Defined.

 Lemma min_case : forall n m (P:O.t -> Type),
  P n -> P m -> P (min n m).
 Proof. intros. apply min_case_strong; auto. Defined.

 Lemma min_dec : forall n m, {min n m = n} + {min n m = m}.
 Proof. exact P.min_dec. Defined.

End UsualMinMaxDecProperties.

Module UsualMinMaxProperties
 (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O).
 Module OT := OTF_to_TotalOrder O.
 Include UsualMinMaxLogicalProperties OT M.
 Include UsualMinMaxDecProperties O M.
 Definition max_l := max_l.
 Definition max_r := max_r.
 Definition min_l := min_l.
 Definition min_r := min_r.
End UsualMinMaxProperties.

(** From [TotalOrder] and [HasMax] and [HasEqDec], we can prove
    that the order is decidable and build an [OrderedTypeFull]. *)

Module TOMaxEqDec_to_Compare
 (Import O:TotalOrder')(Import M:HasMax O)(Import E:HasEqDec O) <: HasCompare O.

 Definition compare x y :=
  if eq_dec x y then Eq
  else if eq_dec (M.max x y) y then Lt else Gt.

 Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
 Proof.
 intros; unfold compare; repeat destruct eq_dec; auto; constructor.
 destruct (lt_total x y); auto.
 absurd (x==y); auto. transitivity (max x y); auto.
 symmetry. apply max_l. rewrite le_lteq; intuition.
 destruct (lt_total y x); auto.
 absurd (max x y == y); auto. apply max_r; rewrite le_lteq; intuition.
 Qed.

End TOMaxEqDec_to_Compare.

Module TOMaxEqDec_to_OTF (O:TotalOrder)(M:HasMax O)(E:HasEqDec O)
 <: OrderedTypeFull
 := O <+ E <+ TOMaxEqDec_to_Compare O M E.

(** TODO: Some Remaining questions...

--> Compare with a type-classes version ?

--> Is max_unicity and max_unicity_ext really convenient to express
    that any possible definition of max will in fact be equivalent ?

--> Is it possible to avoid copy-paste about min even more ?

*)


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

Require Import NAxioms NSub NDiv NGcd.

(** * Least Common Multiple *)

(** Unlike other functions around, we will define lcm below instead of
  axiomatizing it. Indeed, there is no "prior art" about lcm in the
  standard library to be compliant with, and the generic definition
  of lcm via gcd is quite reasonable.

  By the way, we also state here some combined properties of div/mod
  and gcd.
*)

Module Type NLcmProp
 (Import A : NAxiomsSig')
 (Import B : NSubProp A)
 (Import C : NDivProp A B)
 (Import D : NGcdProp A B).

(** Divibility and modulo *)

Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)).
Proof.
 intros a b Hb. split.
 intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 2.
  rewrite Hab; now nzsimpl.
 intros (c,Hc). rewrite <- Hc, mul_comm. now apply mod_mul.
Qed.

Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) ->
 (c*a)/b == c*(a/b).
Proof.
 intros a b c Hb H.
 apply mul_cancel_l with b; trivial.
 rewrite mul_assoc, mul_shuffle0.
 assert (H':=H). apply mod_divide, div_exact in H'; trivial.
 rewrite <- H', (mul_comm a c).
 symmetry. apply div_exact; trivial.
 apply mod_divide; trivial.
 now apply divide_mul_r.
Qed.

(** Gcd of divided elements, for exact divisions *)

Lemma gcd_div_factor : forall a b c, c~=0 -> (c|a) -> (c|b) ->
 gcd (a/c) (b/c) == (gcd a b)/c.
Proof.
 intros a b c Hc Ha Hb.
 apply mul_cancel_l with c; try order.
 assert (H:=gcd_greatest _ _ _ Ha Hb).
 apply mod_divide, div_exact in H; try order.
 rewrite <- H.
 rewrite <- gcd_mul_mono_l; try order.
 f_equiv; symmetry; apply div_exact; try order;
  apply mod_divide; trivial; try order.
Qed.

Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b ->
 gcd (a/g) (b/g) == 1.
Proof.
 intros a b g NZ EQ. rewrite gcd_div_factor.
 now rewrite <- EQ, div_same.
 generalize (gcd_nonneg a b); order.
 rewrite EQ; apply gcd_divide_l.
 rewrite EQ; apply gcd_divide_r.
Qed.

(** The following equality is crucial for Euclid algorithm *)

Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a.
Proof.
 intros a b Hb. rewrite (gcd_comm _ b).
 rewrite <- (gcd_add_mult_diag_r b (a mod b) (a/b)).
 now rewrite add_comm, mul_comm, <- div_mod.
Qed.

(** We now define lcm thanks to gcd:

    lcm a b = a * (b / gcd a b)
            = (a / gcd a b) * b
            = (a*b) / gcd a b

   Nota: [lcm 0 0] should be 0, which isn't garantee with the third
   equation above.
*)

Definition lcm a b := a*(b/gcd a b).

Instance lcm_wd : Proper (eq==>eq==>eq) lcm.
Proof. unfold lcm. solve_proper. Qed.

Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 ->
  a * (b / gcd a b) == (a*b)/gcd a b.
Proof.
 intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r.
Qed.

Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 ->
  (a / gcd a b) * b == (a*b)/gcd a b.
Proof.
 intros a b H. rewrite 2 (mul_comm _ b).
 rewrite divide_div_mul_exact; try easy. apply gcd_divide_l.
Qed.

Lemma gcd_div_swap : forall a b,
 (a / gcd a b) * b == a * (b / gcd a b).
Proof.
 intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
 apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl.
 now rewrite lcm_equiv1, <-lcm_equiv2.
Qed.

Lemma divide_lcm_l : forall a b, (a | lcm a b).
Proof.
 unfold lcm. intros a b. apply divide_factor_l.
Qed.

Lemma divide_lcm_r : forall a b, (b | lcm a b).
Proof.
 unfold lcm. intros a b. rewrite <- gcd_div_swap.
 apply divide_factor_r.
Qed.

Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a).
Proof.
 intros a b c Ha Hb (c',Hc). exists c'.
 now rewrite mul_comm, <- divide_div_mul_exact, mul_comm, Hc.
Qed.

Lemma lcm_least : forall a b c,
 (a | c) -> (b | c) -> (lcm a b | c).
Proof.
 intros a b c Ha Hb. unfold lcm.
 destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
 apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl.
 assert (Ga := gcd_divide_l a b).
 assert (Gb := gcd_divide_r a b).
 set (g:=gcd a b) in *.
 assert (Ha' := divide_div g a c NEQ Ga Ha).
 assert (Hb' := divide_div g b c NEQ Gb Hb).
 destruct Ha' as (a',Ha'). rewrite <- Ha' in Hb'.
 apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm].
 destruct Hb' as (b',Hb').
 exists b'.
 rewrite <- mul_assoc, Hb'.
 rewrite (proj2 (div_exact c g NEQ)).
 rewrite <- Ha', mul_assoc. f_equiv.
 apply div_exact; trivial.
 apply mod_divide; trivial.
 apply mod_divide; trivial. transitivity a; trivial.
Qed.

Lemma lcm_comm : forall a b, lcm a b == lcm b a.
Proof.
 intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b).
 now rewrite <- gcd_div_swap.
Qed.

Lemma lcm_divide_iff : forall n m p,
  (lcm n m | p) <-> (n | p) /\ (m | p).
Proof.
 intros. split. split.
 transitivity (lcm n m); trivial using divide_lcm_l.
 transitivity (lcm n m); trivial using divide_lcm_r.
 intros (H,H'). now apply lcm_least.
Qed.

Lemma lcm_unique : forall n m p,
 0<=p -> (n|p) -> (m|p) ->
 (forall q, (n|q) -> (m|q) -> (p|q)) ->
 lcm n m == p.
Proof.
 intros n m p Hp Hn Hm H.
 apply divide_antisym; trivial.
 now apply lcm_least.
 apply H. apply divide_lcm_l. apply divide_lcm_r.
Qed.

Lemma lcm_unique_alt : forall n m p, 0<=p ->
 (forall q, (p|q) <-> (n|q) /\ (m|q)) ->
 lcm n m == p.
Proof.
 intros n m p Hp H.
 apply lcm_unique; trivial.
 apply H, divide_refl.
 apply H, divide_refl.
 intros. apply H. now split.
Qed.

Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p.
Proof.
 intros. apply lcm_unique_alt. apply le_0_l.
 intros. now rewrite !lcm_divide_iff, and_assoc.
Qed.

Lemma lcm_0_l : forall n, lcm 0 n == 0.
Proof.
 intros. apply lcm_unique; trivial. order.
 apply divide_refl.
 apply divide_0_r.
Qed.

Lemma lcm_0_r : forall n, lcm n 0 == 0.
Proof.
 intros. now rewrite lcm_comm, lcm_0_l.
Qed.

Lemma lcm_1_l : forall n, lcm 1 n == n.
Proof.
 intros. apply lcm_unique; trivial using divide_1_l, le_0_l, divide_refl.
Qed.

Lemma lcm_1_r : forall n, lcm n 1 == n.
Proof.
 intros. now rewrite lcm_comm, lcm_1_l.
Qed.

Lemma lcm_diag : forall n, lcm n n == n.
Proof.
 intros. apply lcm_unique; trivial using divide_refl, le_0_l.
Qed.

Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0.
Proof.
 intros. split.
 intros EQ.
 apply eq_mul_0.
 apply divide_0_l. rewrite <- EQ. apply lcm_least.
  apply divide_factor_l. apply divide_factor_r.
 destruct 1 as [EQ|EQ]; rewrite EQ. apply lcm_0_l. apply lcm_0_r.
Qed.

Lemma divide_lcm_eq_r : forall n m, (n|m) -> lcm n m == m.
Proof.
 intros n m H. apply lcm_unique_alt; trivial using le_0_l.
 intros q. split. split; trivial. now transitivity m.
 now destruct 1.
Qed.

Lemma divide_lcm_iff : forall n m, (n|m) <-> lcm n m == m.
Proof.
 intros n m. split. now apply divide_lcm_eq_r.
 intros EQ. rewrite <- EQ. apply divide_lcm_l.
Qed.

Lemma lcm_mul_mono_l :
  forall n m p, lcm (p * n) (p * m) == p * lcm n m.
Proof.
 intros n m p.
 destruct (eq_decidable p 0) as [Hp|Hp].
  rewrite Hp. nzsimpl. rewrite lcm_0_l. now nzsimpl.
 destruct (eq_decidable (gcd n m) 0) as [Hg|Hg].
  apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm.
  nzsimpl. rewrite lcm_0_l. now nzsimpl.
 unfold lcm.
 rewrite gcd_mul_mono_l.
 rewrite mul_assoc. f_equiv.
 now rewrite div_mul_cancel_l.
Qed.

Lemma lcm_mul_mono_r :
 forall n m p, lcm (n * p) (m * p) == lcm n m * p.
Proof.
 intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm.
Qed.

Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 ->
 (gcd n m == 1 <-> lcm n m == n*m).
Proof.
 intros n m Hn Hm. split; intros H.
 unfold lcm. rewrite H. now rewrite div_1_r.
 unfold lcm in *.
 apply mul_cancel_l in H; trivial.
 assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order).
 assert (H' := gcd_divide_r n m).
 apply mod_divide in H'; trivial. apply div_exact in H'; trivial.
 rewrite H in H'.
 rewrite <- (mul_1_l m) in H' at 1.
 now apply mul_cancel_r in H'.
Qed.

End NLcmProp.