(* exercise 8.5 *)
(****************)

Require Export List.
Require Export Arith.
(* In our exercises we consider strings with only opening and closing
  parentheses. *)

Inductive par : Set :=
  | open : par
  | close : par.
(* This is the definition of well-parenthesized expressions that is
  probably the easiest to agree on. solution to \ref{exo-wp-1} *)

Inductive wp : list par -> Prop :=
  | wp_nil : wp nil
  | wp_concat : forall l1 l2:list par, wp l1 -> wp l2 -> wp (l1 ++ l2)
  | wp_encapsulate :
      forall l:list par, wp l -> wp (open :: l ++ close :: nil).

Theorem wp_oc : wp (open :: close :: nil).
Proof.
 change (wp (open :: nil ++ close :: nil)) in |- *.
 apply wp_encapsulate.
 apply wp_nil.
Qed.

Theorem wp_o_head_c :
 forall l1 l2:list par, wp l1 -> wp l2 -> wp (open :: l1 ++ close :: l2).
Proof.
 intros l1 l2 H1 H2.
 replace (open :: l1 ++ close :: l2) with ((open :: l1 ++ close :: nil) ++ l2).
 -  apply wp_concat.
    apply wp_encapsulate; trivial.
    trivial.
 -  repeat (simpl in |- *; rewrite app_ass); simpl in |- *.
    trivial.
Qed.

Theorem wp_o_tail_c :
 forall l1 l2:list par,
   wp l1 -> wp l2 -> wp (l1 ++ open :: l2 ++ close :: nil).
Proof.
 intros l1 l2 H1 H2;  apply wp_concat.
 -  trivial.
 - now  apply wp_encapsulate.
Qed.

(* exercice 8.6 *)
(****************)

(* The structure of well-parenthesized expressions can actually be
  represented by binary trees.*)

Inductive bin : Set :=
  | L : bin
  | N : bin -> bin -> bin.

Fixpoint bin_to_string (t:bin) : list par :=
  match t with
  | L => nil (A:=par)
  | N u v => open :: bin_to_string u ++ close :: bin_to_string v
  end.

(**  Tests

Compute bin_to_string (N (N L L) L).

Compute bin_to_string (N (N L L) (N L L)).

*)

Theorem bin_to_string_wp : forall t:bin, wp (bin_to_string t).
Proof.
 simple induction t.
 -  simpl ; apply wp_nil.
 -  simpl ; intros t1 H1 t2 H2; apply wp_o_head_c; trivial.
Qed.

Hint Resolve wp_nil wp_concat wp_encapsulate wp_o_head_c wp_o_tail_c wp_oc.

Fixpoint bin_to_string' (t:bin) : list par :=
  match t with
  | L => nil (A:=par)
  | N u v =>
      bin_to_string' u ++ open :: bin_to_string' v ++ close :: nil
  end.

(* This is the correction for exercise 8.7 *)

Theorem bin_to_string'_wp : forall t:bin, wp (bin_to_string' t).
Proof.
 simple induction t; simpl ; auto.
Qed.

(*  This is the correction for exercise 8.24 *)

Inductive parse_rel : list par -> list par -> bin -> Prop :=
  | parse_node :
      forall (l1 l2 l3:list par) (t1 t2:bin),
        parse_rel l1 (close :: l2) t1 ->
        parse_rel l2 l3 t2 -> parse_rel (open :: l1) l3 (N t1 t2)
  | parse_leaf_nil : parse_rel nil nil L
  | parse_leaf_close :
      forall l:list par, parse_rel (close :: l) (close :: l) L.

Theorem parse_rel_sound_aux :
 forall (l1 l2:list par) (t:bin),
   parse_rel l1 l2 t -> l1 = bin_to_string t ++ l2.
Proof.
 intros l1 l2 t H; elim H; clear H l1 l2 t.
 -  intros l1 l2 l3 t1 t2 Hp Hr1 Hp2 Hr2; simpl.
     rewrite app_ass, Hr1; simpl.
     now      rewrite Hr2.
 -  reflexivity.
 -  reflexivity.
Qed.

Theorem parse_rel_sound :
 forall l:list par, (exists t : bin, parse_rel l nil t) -> wp l.
Proof.
 intros l [t H]; replace l with (bin_to_string t).
 -  apply bin_to_string_wp.
 -  symmetry;
   replace (bin_to_string t) with (bin_to_string t ++ nil).
   +  apply parse_rel_sound_aux; auto.
   +  rewrite app_nil_end; auto.
Qed.

(* correction to exercise 8.19 *)

(* This is another possible definition of well-parenthesized expressions,
  actually better adapted to showing that a given parser is correct. *)

Inductive wp' : list par -> Prop :=
  | wp'_nil : wp' nil
  | wp'_cons :
      forall l1 l2:list par,
        wp' l1 -> wp' l2 -> wp' (open :: l1 ++ close :: l2).

(* To prove that the two definitions of well-parenthesized expressions are
  equivalent, we need to prove that each predicate satisfies the constructors
  of the other. *)

Theorem wp'_concat :
 forall l1 l2:list par, wp' l1 -> wp' l2 -> wp' (l1 ++ l2).
Proof.
 intros l1 l2 H; generalize l2; clear l2.
 elim H.
 -  simpl; auto.
 -  intros l1' l2' Hb1' Hr1 Hb2' Hr2 l2 Hb2; simpl; rewrite app_ass.
    simpl; apply wp'_cons; auto.
Qed.

Hint Resolve wp'_nil wp'_cons wp'_concat.

(* This is the other constructor of wp, also satisfied by wp'. *)

Theorem wp'_encapsulate :
 forall l:list par, wp' l -> wp' (open :: l ++ close :: nil).
Proof.
 intros l H; elim H; auto.
Qed.

(* One interpretation of inductive definitions of predicates is that
  the defined predicate is the least (with respect to implication) to
  satisfy the constructors.  Thus, having proved that one of the predicates
  satisfies the constructors of the other gives a simple way to prove
  that one predicate implies the other.  The proof is done by induction
  on the predicate. solution to \ref{exo-wp-2}*)

Theorem wp_imp_wp' : forall l:list par, wp l -> wp' l.
Proof.
 intros l H; elim H.
 -  apply wp'_nil.
 -  intros; apply wp'_concat; trivial.
 -  intros; apply wp'_encapsulate; trivial.
Qed.

Theorem wp'_imp_wp : forall l:list par, wp' l -> wp l.
Proof.
 intros l H; elim H; auto.
Qed.

(* correction of exercise 8.20 *)

(* Here is an alternative definition, the same as before, but with the
  second constructor that privileges parentheses on the right. *)

Inductive wp'' : list par -> Prop :=
  | wp''_nil : wp'' nil
  | wp''_cons :
      forall l1 l2:list par,
        wp'' l1 -> wp'' l2 -> wp'' (l1 ++ open :: l2 ++ close :: nil).

Hint Resolve wp''_nil wp''_cons.

(* Obviously this one also satisfies the concatenation property. *)

Lemma wp''_concat :
 forall l1 l2:list par, wp'' l1 -> wp'' l2 -> wp'' (l1 ++ l2).
Proof.
 (* Only a proof by induction on the fact that the second list is
    well-parenthesized   is needed. *)
 intros l1 l2 H1 H2; generalize l1 H1; clear H1 l1; elim H2.
 -  intros; rewrite <- app_nil_end; trivial.
 -  intros; rewrite ass_app; auto.
Qed.

Theorem wp''_encapsulate :
 forall l:list par, wp'' l -> wp'' (open :: l ++ close :: nil).
Proof.
 intros l H; change (wp'' (nil ++ open :: l ++ close :: nil));
 auto.
Qed.
Hint Resolve wp''_concat wp''_encapsulate.

(* solution to exercise \ref{exo-wp-4} *)

Theorem wp_imp_wp'' : forall l:list par, wp l -> wp'' l.
Proof.
 simple induction 1; auto.
Qed.

Theorem wp''_imp_wp : forall l:list par, wp'' l -> wp l.
Proof.
 simple induction 1; auto.
Qed.

Fixpoint recognize (n:nat) (l:list par) {struct l} : bool :=
  match l with
  | nil => match n with
           | O => true
           | _ => false
           end
  | open :: l' => recognize (S n) l'
  | close :: l' => match n with
                   | O => false
                   | S n' => recognize n' l'
                   end
  end.

(* solution to exercise 8.21 *)

Theorem recognize_complete_aux :
 forall l:list par,
   wp l ->
   forall (n:nat) (l':list par), recognize n (l ++ l') = recognize n l'.
Proof.
 intros l H; elim H.
 -  simpl; auto.
 -  intros l1 l2 H1 Hrec1 H2 Hrec2 n l'.
    rewrite app_ass; transitivity (recognize n (l2 ++ l')); auto.
 -  intros l1 H1 Hrec n l'; simpl ; rewrite app_ass; rewrite Hrec;
    simpl ; auto.
Qed.

Theorem recognize_complete : forall l:list par, wp l -> recognize 0 l = true.
Proof.
 intros l H; rewrite (app_nil_end l),  recognize_complete_aux; auto.
Qed.

(* solution of exercise 8.22 *)

Theorem app_decompose :
 forall (A:Type) (l1 l2 l3 l4:list A),
   l1 ++ l2 = l3 ++ l4 ->
   (exists l1' : list A, l1 = l3 ++ l1' /\ l4 = l1' ++ l2) \/
   (exists a : A,
      exists l2' : list A, l3 = l1 ++ a :: l2' /\ l2 = (a :: l2') ++ l4).
Proof.
 simple induction l1.
 -  intros l2 l3; case l3.
   +  intros l4 H; left; exists (nil (A:=A)); auto.
   +  intros a l3' Heq; right; exists a; exists l3'; auto.
 -  clear l1; intros a l1 Hrec l2 l3; case l3.
   +  intros l4 H; left; exists (a :: l1); auto.
   +  simpl ; intros a' l3' l4 Heq; injection Heq; intros Heq' Heq''.
       elim Hrec with (1 := Heq').
       intros [l1' [Heq3 Heq4]]; left; exists l1'; split; auto.
       rewrite Heq''; rewrite Heq3; auto.
       intros [a'' [l2' [Heq3 Heq4]]]; right; exists a'', l2'; split; auto.
       rewrite Heq''; rewrite Heq3; auto.
Qed.

(* length of lists is actually an abstract view of lists.  There is
  a morphism between appending and addition.  This is already visible
  in the structure of the two functions app and plus and the proof of
  this theorem follows in a simple way the structure of app (and plus by
  the same occasion). *)

Theorem length_app :
 forall {A:Type} (l1 l2:list A), length (l1 ++ l2) = length l1 + length l2.
Proof.
 simple induction l1; simpl in |- *; auto.
Qed.

Theorem length_rev : forall {A:Type} (l:list A), length l = length (rev l).
Proof.
 simple induction l; auto.
 -  intros a l' H; simpl in |- *.
    rewrite length_app.
    simpl in |- *; rewrite <- plus_n_Sm; rewrite H; auto with arith.
Qed.

Theorem cons_to_app_end :
 forall {A:Type} (l:list A) (a:A),
    exists b : A, exists l' : list A, a :: l = l' ++ b :: nil.
Proof.
 intros A l a.
 rewrite <- (rev_involutive (a :: l)).
 (* We want to use the first element of (rev (a :: l)) but we
  need to say that this list has at least one element. *)
 assert (H : 0 < length (rev (a :: l)))
  by  (rewrite <- length_rev; simpl ; auto with arith).

 destruct (rev (a :: l)) as [ | a0 l0].
 -  (* If (rev (cons a l)) was nil, then there would be a contradiction. *)
   simpl ; elim (lt_n_O 0); auto.
 -  exists a0,  (rev l0); simpl ; auto.
Qed.

Theorem last_same :
 forall {A:Type} (a b:A) (l1 l2:list A),
   l1 ++ a :: nil = l2 ++ b :: nil -> l1 = l2 /\ a = b.
Proof.
 intros A a b l1 l2 H.
 assert (e: a :: rev l1 = b :: rev l2).
 -  repeat rewrite <- rev_unit; now rewrite H.
 -  injection e; intros H1 H2; split; auto.
    rewrite <- (rev_involutive l1), H1; apply rev_involutive.
Qed.

Theorem wp_remove_oc_aux :
 forall l:list par,
   wp l ->
   forall l1 l2:list par, l1 ++ l2 = l -> wp (l1 ++ open :: close :: l2).
Proof.
 intros l H; elim H.
 -
 (* In the first case l is the empty list, there is only one way to insert
  an open-string pair.  We use the theorem app_eq_nil to determine
  l1 and l2.  This theorem has implicit arguments. *)

 intros l1 l2 H1; elim (app_eq_nil _ _ H1); auto.
 simpl in |- *; intros Heq1 Heq2; rewrite Heq1; rewrite Heq2; apply wp_oc.

 -  (* In the second case l is already a concatenation of two well-parenthesized
    expressions l1 and l2.  We need to now whether the open-close pair is
   inserted in l1' or in l2', the theorem app_decompose helps here. *)
   intros l1 l2 Hp1 Hr1 Hp2 Hr2 l3 l4 Heq.
   elim app_decompose with (1 := Heq).
   intros [l1' [Heq1 Heq2]]; rewrite Heq1, app_ass;
   apply wp_concat; auto.
   intros [a' [l2' [Heq1 Heq2]]].
   rewrite Heq2.
   repeat rewrite app_comm_cons.
   rewrite ass_app.
  apply wp_concat; auto.

- (* In the third case, we have to check three possibilities: either
   the open-close pair has been inserted before the existing open character,
  or between the two parentheses, or after. *)
 idtac.
 intros l' Hp'' Hrec l1; case l1.
 simpl ; intros l2 Heq; rewrite Heq.
 change (wp (open :: nil ++ close :: open :: l' ++ close :: nil));
 auto.
 simpl; intros c l1' l2; case l2.
(* If l2 is nil, then the open-close pair was introduced after the
  closing parenthesis. *)
 +  intros Heq; injection Heq; intros Heq1 Heq2.
    rewrite <- app_nil_end in Heq1; rewrite Heq1; rewrite Heq2.
    rewrite app_comm_cons.
    apply wp_concat; auto.
 + (* if l2 is non nil then the open-close pair was introduced between the
   parentheses *)
 intros c' l2'; elim (cons_to_app_end  l2' c').
 intros c'' [l2'' Heq]; rewrite Heq.
 rewrite ass_app; intros Heq1.
 injection Heq1; intros Heq2 Heq3; elim last_same with (1 := Heq2).
 intros Heq4 Heq5; rewrite Heq5; rewrite Heq3.
 change (wp (open :: l1' ++ (open :: close :: l2'') ++ close :: nil)) .
 rewrite ass_app; auto.
Qed.

Theorem wp_remove_oc :
 forall l1 l2:list par, wp (l1 ++ l2) -> wp (l1 ++ open :: close :: l2).
Proof.
 intros; apply wp_remove_oc_aux with (l := l1 ++ l2); auto.
Qed.

Fixpoint make_list (A:Type) (a:A) (n:nat) {struct n} :
 list A := match n with
           | O => nil (A:=A)
           | S n' => a :: make_list A a n'
           end.

Theorem make_list_end :
 forall (A:Type) (a:A) (n:nat) (l:list A),
   make_list A a (S n) ++ l = make_list A a n ++ a :: l.
Proof.
 simple induction n; simpl.
 -  trivial.
-  intros n' H l; rewrite H; trivial.
Qed.

(* Now we want to express that only well-parenthesized expressions are accepted.  Again,
  we prove a more general statement, where n is understood as the number of
  unmatched opening parentheses recognized so far. *)

Theorem recognize_sound_aux :
 forall (l:list par) (n:nat),
   recognize n l = true -> wp (make_list _ open n ++ l).
Proof.
 simple induction l; simpl.
-  intros n; case n.
   simpl ; intros; apply wp_nil.
   intros n' H; discriminate H.
-  intros a; case a; simpl ; clear a.
   + intros l' H n H0.
     rewrite <- make_list_end; auto.
   +  intros l' H n; case n; clear n.
      intros H'; discriminate H'.
      intros n H0; rewrite make_list_end; apply wp_remove_oc;auto.
Qed.

(* The soundness statement is the general statement specialized to value 0.
 *)

Theorem recognize_sound : forall l:list par, recognize 0 l = true -> wp l.
Proof.
 intros l H; generalize (recognize_sound_aux _ _ H); simpl; auto.
Qed.

(* Now we want to write a real parser, that is, a function that constructs
  a term representing the structure of the string.
  The parsing function is a tail-recursive representation of a stack automaton.
   The argument s is the stack, the argument t is the tree representing the
  the last well-formed expression that was recognized.  The return value is
  None if the string is rejected and (Some t) if the string is accepted.  In
  this case one should be able to reconstruct the recognized string from t,
  but this is done later as another exercise. *)

(* exercise 8.23 *)
Fixpoint parse (s:list bin) (t:bin) (l:list par) {struct l} :
 option bin :=
  match l with
  | nil => match s with
           | nil => Some t
           | _ => None (A:=bin)
           end
  | open :: l' => parse (t :: s) L l'
  | close :: l' =>
      match s with
      | t' :: s' => parse s' (N t' t) l'
      | _ => None (A:=bin)
      end
  end.

(* The length of the stack plays the same role as argument n in the
  function recognize. *)

Theorem parse_reject_indep_t :
 forall (l:list par) (s:list bin) (t:bin),
   parse s t l = None ->
   forall (s':list bin) (t':bin),
     length s' = length s -> parse s' t' l = None.
Proof.
 simple induction l.
-  intros s; case s.
   +  simpl; intros t H; discriminate H.
   + intros t0 s0 t H s'; case s'.
     *  simpl; intros t' Hle; discriminate Hle.
     *  simpl; auto.
-  intros a; case a; simpl; clear a; intros l' Hrec s.
   + intros t H s' t' Hle.
     apply Hrec with (1 := H).
     simpl; auto with arith.
   +  case s.
      *  intros t H s'; case s'; simpl; auto.
         intros t0 s0 t' Hle; discriminate Hle.
      *  intros t0 s0 t H s'; case s'; simpl.
         intros t' H0; discriminate H0.
         intros t'0 s'0 t' Hle; apply Hrec with (1 := H).
         simpl in Hle; auto with arith.
Qed.

(* Rejected strings are those for which the return value is None.
  In the completeness theorem we actually talk about the rejected strings.
  Here it is more convenient to use wp' as the definition of well-parenthesized
  expressions to organize the proof.*)

Theorem parse_complete_aux :
 forall l:list par,
   wp' l ->
   forall (s:list bin) (t:bin) (l':list par),
     parse s t (l ++ l') = None ->
     forall (s':list bin) (t':bin),
       length s' = length s -> parse s' t' l' = None.
Proof.
 simple induction 1.
 -  simpl; intros; eapply parse_reject_indep_t; eauto.
 -  intros l1 l2 Hp1 Hr1 Hp2 Hr2 s t l' Hrej s' t' Hle.
    apply Hr2 with (s := s') (t := N t L).
    change (parse (t :: s') L (close :: l2 ++ l') = None) in |- *.
    simpl in Hrej.
    rewrite app_ass in Hrej.
    apply Hr1 with (1 := Hrej).
    simpl; auto with arith.
   auto.
Qed.

Theorem parse_complete : forall l:list par, wp l -> parse nil L l <> None.
Proof.
 intros l H; replace l with (l ++ nil).
 red in |- *; intros H'.
 assert (e : parse nil L nil = None).
 -   apply parse_complete_aux with (2 := H'); auto.
     apply wp_imp_wp'; auto.
 - discriminate.
 - rewrite <- app_nil_end; auto.
Qed.

(* We will use bin_to_string' to map binary trees to strings of characters.
  Stacks also represent strings. *)

Fixpoint unparse_stack (s:list bin) : list par :=
  match s with
  | nil => nil (A:=par)
  | t :: s' => unparse_stack s' ++ bin_to_string' t ++ open :: nil
  end.

Theorem parse_invert_aux :
 forall (l:list par) (s:list bin) (t t':bin),
   parse s t l = Some t' ->
   bin_to_string' t' = unparse_stack s ++ bin_to_string' t ++ l.
Proof.
 simple induction l.
-  intros s; case s.
 + simpl.
   intros t t' H; injection H; intros Heq.
   rewrite Heq; apply app_nil_end.
 +  simpl ; intros t0 s0 t t' H; discriminate H.
-  intros a; case a; simpl; clear a; intros l' Hrec s.
  +  intros t t' H; rewrite Hrec with (1 := H).
     simpl; repeat (rewrite app_ass; simpl); auto.
  + case s.
   *  intros t t' H; discriminate H.
   *  intros t0 s0 t t' Hp; rewrite Hrec with (1 := Hp);
      simpl; repeat (rewrite app_ass; simpl); auto.
Qed.

Theorem parse_invert :
 forall (l:list par) (t:bin), parse nil L l = Some t -> bin_to_string' t = l.
Proof.
 intros; replace l with (unparse_stack nil ++ bin_to_string' L ++ l); auto.
 apply parse_invert_aux; auto.
Qed.

(* With this last theorem, we know that our parser is correct, that is
  sound and complete. *)

Theorem parse_sound :
 forall (l:list par) (t:bin), parse nil L l = Some t -> wp l.
Proof.
 intros l t H; rewrite <- parse_invert with (1 := H).
 apply bin_to_string'_wp.
Qed.

(* Now, an exercise for which we do not give the solution is the exercise
          where strings can also contain other characters that play no role
          with  respect to parentheses, but should not be forgotten by the
 parser.*)


(**
Deux objectifs dans ce TD :
- deux structures linéaires qui serviront constamment,
  les listes et les entiers naturels,
  et les pricipes de récurrence associés
- extensions des expressions arithmétiques
*)

(** * Listes et entiers naturels *)

(** ** Listes *)

(**
On oublie pour l'instant les entiers prédéfinis en Coq,
car on les refera à partir de zéro (c'est le cas de le dire).

Pour avoir des listes de quelque chose, on reprend donc le type
des couleurs vu auparavant.
On verra plus tard que, comme en OCaml, Coq permet de
travailler sur des listes d'éléments dont le type n'est pas fixé
a priori.
 *)

Inductive coulfeu : Set :=
  | Vert : coulfeu
  | Orange : coulfeu
  | Rouge : coulfeu
.

Inductive listc : Set  :=
  | Nilc  : listc
  | Consc : coulfeu -> listc -> listc
.

Example l1 := Consc Vert (Consc Rouge Nilc).
Example l2 := Consc Orange (Consc Orange Nilc).

(** La fonction la plus importante sur les listes est la concaténation,
    vue en PF sous le nom append.
    Elle se définit récursivement par analyse (ou filtrage) du *premier* argument
 *)

Fixpoint app u v : listc :=
  match u with
  | Nilc       => v
  | Consc x u' => Consc x (app u' v)
  end.

Compute (app l1 l2).

(** Exercice à faire à la maison :
    tenter de définir app par filtrage du second argument *)

Fixpoint app' u v : listc :=
    match v with
    | Nilc => u
    | Consc x v' => app' u v' (* FAUX *)
    end.
(* La structure du type listc rend cette façon de
 * définir app impossible *)

(** Remarque : pour une définition récursive on écrit
    [Fixpoint app u v := ]
    plutôt que
    [Definition app := fun u v => ].
 *)

(** On commence par deux lemmes dont l'énoncé est semblable
    ([Nilc] est neutre à gauche et à droite de [app])
    mais dont les démonstrations sont très différentes *)

Theorem app_Nilc_l : forall l, app Nilc l = l.
Proof.
  intro l. cbn [app]. reflexivity.
Qed.

(** Exprimer cette preuve en français *)

(*
  Soit l une liste (listc).
  Si on applique `app` à `Nilc` et à `l` on obtient `l`
  (on entre dans la première branche du match comme `u = Nilc`
  donc `app` renvoie `v = l`).
  Or `l = l`.
  Donc `app Nilc l = l` quel que soit `l`.
*)

Theorem app_Nilc_r : forall l, app l Nilc = l.
Proof.
  intro l. cbn [app]. (* aucun effet : pourquoi ? *)
  (* Ce cbn  n'a aucun effet car on ne peut pas
     déterminer quelle branche du match sera exécutée,
     étant donné qu'on ne sait rien sur `l`. *)
  (** terminer au moyen d'une preuve par récurrence *)
  induction l.
  - cbn [app]. reflexivity.
  - cbn [app]. rewrite IHl. reflexivity.
Qed.

(** Lemme fondamental : app est associative *)

Theorem app_assoc : forall u v w, app u (app v w) = app (app u v) w.
Proof.
  intros u v w. (** équivalent à intro u. intro v. intro w. *)
  (** Comme app analyse son premier argument on tente une récurrence sur u *)
  induction u as [ | x u' Hrecu'].
  - cbn [app]. reflexivity.
  - cbn [app]. rewrite Hrecu'. reflexivity.
Qed.

(* ----------------------------------------------------------------------- *)
(** DEBUT QUESTIONS FACULTATIVES (1) *)

Fixpoint renv u : listc :=
  match u with
  | Nilc       => Nilc
  | Consc x u' => app (renv u') (Consc x Nilc)
  end.

(* Penser à utiliser les théorèmes précédents *)
Lemma app_renv : forall u v, renv (app u v) = app (renv v) (renv u).
Proof.
  intros.
  induction u.
  - cbn [app renv]. rewrite app_Nilc_r. reflexivity.
  - cbn [app renv]. rewrite IHu. rewrite app_assoc. reflexivity.
Qed.

Lemma renv_renv : forall u, renv (renv u) = u.
Proof.
  intros.
  induction u.
  - cbn [renv]. reflexivity.
  - cbn [renv].
    rewrite app_renv.
    rewrite IHu.
    cbn [renv].
    cbn [app].
    reflexivity.
Qed.

(** FIN QUESTIONS FACULTATIVES (1) *)
(* ----------------------------------------------------------------------- *)

(** ** Entiers naturels *)

(** En mathématiques, les entiers ne sont plus une notion primitive depuis
    les travaux de Dedekind et Peano au 19e siècle : ils sont obtenus
    à partir de deux constructions élémentaires :
    - l'entier nul, que l'on notera O ;
    - le successeur d'un entier [n] déjà construit, que l'on notera [S n].
    C'est exactement ce que l'on obtient avec le type inductif suivant.
*)

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

Check (S (S O)). (** représente l'entier noté usuellement 2 *)

(** En comparant les définitions de [nat] et de [listc], on voit
    que les entiers naturels sont analogues à des listes décolorées.
    Scoop : la récurrence structurelle sur nat correspond exactement à
    la récurrence usuelle sur les entiers !
    L'opération qui correspond à [app], mais sur [nat], est tout
    simplement l'addition.
    Les exercices suivants peuvent être résolus en procédant de manière
    analogue à ce qui a été fait sur les listes.
 *)

Fixpoint plus (n m : nat) : nat :=
    match n with
    | O => m
    | S n' => S (plus n' m)
    end.
(** remplacer ". Admitted" par " := bonne_définition ." *)

Theorem plus_0_l : forall n, plus O n = n.
  intros.
  cbn [plus]. reflexivity.
Qed.

Theorem plus_0_r : forall n, plus n O = n.
  intros.
  induction n.
  - cbn [plus]. reflexivity.
  - cbn [plus]. rewrite IHn. reflexivity.
Qed.

(** Pour les exercices suivants une récurrence structurelle simple suffit,
    il faut bien choisir la variable qur laquelle elle porte *)

Theorem plus_assoc : forall n m p, plus n (plus m p) = plus (plus n m) p.
  intros.
  induction n.
  - cbn [plus]. reflexivity.
  - cbn [plus]. rewrite IHn. reflexivity.
Qed.

(* ----------------------------------------------------------------------- *)
(** DEBUT QUESTIONS FACULTATIVES (2) *)

Theorem plus_Sm_r : forall n m, plus n (S m) = S (plus n m).
  intros.
  induction n.
  - cbn [plus]. reflexivity.
  - cbn [plus]. rewrite IHn. reflexivity.
Qed.

(* Penser à utliser les théorèmes précédents *)
Theorem plus_com : forall n m, plus n m = plus m n.
  intros.
  induction n.
  - cbn [plus]. rewrite plus_0_r. reflexivity.
  - cbn [plus]. rewrite IHn. rewrite plus_Sm_r. reflexivity.
Qed.

(** Longueur d'une liste :
    il est plus simple de la définir avec [S] plutôt qu'avec [plus]
*)
Fixpoint long (l : listc) : nat :=
    match l with
    | Nilc => O
    | Consc x xs => S (long xs)
    end.

Theorem long_app : forall u v, long (app u v) = plus (long u) (long v).
  intros.
  induction u.
  - cbn [long app plus]. reflexivity.
  - cbn [long app plus]. rewrite IHu. reflexivity.
Qed.
(** FIN QUESTIONS FACULTATIVES (2) *)
(* ----------------------------------------------------------------------- *)

(** Les entiers naturels de Coq sont définis exactement comme ci-dessus *)

(** On annule ce qui a été fait depuis notre définition de nat,
    pou retrouver la situation fournie par Coq. *)
Reset nat.
Print nat.

(** Mais on a dispose alors facilités de notation, par exemple,
    [S (S O)] s'écrit [2] *)

Fact deux : 2 = S (S O).
Proof. (** regarder le but écrit par Coq *) reflexivity. Qed.

(** * Quelques commandes de recherche d'information *)

(** Quelle est la fonction qui est derrière le symbole "+" ? *)
Locate "+".
(**  Print est connu *)
Print Nat.add.
(** Intégration de l'espace de nommage Nat *)
Import Nat.
Locate "+".
(* Quelles fonctions de type [nat -> nat -> nat] sot disponibles ? *)
Search (nat -> nat -> nat).

(** * AST d'expressions arithmétiques, le retour *)

(** On considère des expressions arithmétiques comprenant
    non seulement des opération et des constantes, mais aussi des noms
    de variables.
    Pour simplifier on considère que ces variables s'écriraient "x0", "x1",
    "x2", etc., ce qui permet de les représenter par un simple entier naturel.
    Noter que les constructeurs [Ana] et [Ava] permettent de distinguer
    la constante 2 de la variable x2.
*)

Inductive aexp :=
| Aco : nat -> aexp (* constantes *)
| Ava : nat -> aexp (* variables *)
| Apl : aexp -> aexp -> aexp
| Amu : aexp -> aexp -> aexp
| Amo : aexp -> aexp -> aexp
.

(* Définir les expressions aexp correspondant à
  (1 + x2) * 3 et  (x1 * 2) + x3
 *)

 Example expr1 := Amu (Apl (Aco 1) (Ava 2)) (Aco 3).
 Example expr2 := Apl (Amu (Ava 1) (Aco 2)) (Ava 3).

(** Pour évaluer une expression représentée par un tel AST,
    on considère un *état*, c'est à dire une association entre
    chaque nom de variable et un valeur dans [nat].
    On choisit de représenter un tel état par une liste d'entiers,
    avec comme convention :
    - le premier élément de cette liste est la valeur associée à x0
    - le second élément de cette liste est la valeur associée à x1
    - et ainsi de suite ;
    - pour les noms restants, la valeur associée est 0.
    Par exemple, dans l'état Cons 3 (Cons 0 (Cons 8 Nil)),
    la valeur associée à x0 est 3, la valeur associée à x1 est 0,
    la valeur associée à x2 est 8, et la valeur associée à x3, x4, etc.
    est 0.
 *)

Inductive state :=
  | Nil : state
  | Cons : nat -> state -> state
.

(* ----------------------------------------------------------------------- *)
(** DEBUT QUESTIONS FACULTATIVES (3) *)

(** Définir une fonction [get] qui rend la valeur associée à xi dans l'état s *)

Fixpoint get (i: nat) (s: state) : nat :=
    match (i, s) with
    | (0, Cons x s') => x
    | (n, Cons x s') => get (n - 1) s'
    | _ => 0
    end.

(** FIN QUESTIONS FACULTATIVES (3) *)
(* ----------------------------------------------------------------------- *)

(** Définir une fonction [eval] qui rend la valeur d'une aexp dans l'état s *)

(** Même si la fonction get ci-dessus a été laissée 'Admitted', elle est
    utilisable dans les questions suivantes.  *)

Fixpoint eval (a: aexp) (s: state) : nat :=
    match a with
    | Aco c => c
    | Ava x => get x s
    | Apl x y => (eval x s) + (eval y s)
    | Amu x y => (eval x s) * (eval y s)
    | Amo x y => (eval x s) - (eval y s)
    end.

(* ----------------------------------------------------------------------- *)
(** DEBUT QUESTIONS FACULTATIVES (4) *)

(** Définir une fonction [renomme] qui prend une aexp [a] et rend [a] où
    les variables correspondant à x0, x1, x2... ont été respectivement
    renommées en x1, x2, x3...  *)

Fixpoint renomme (a: aexp) : aexp :=
    match a with
    | Aco c => Aco c
    | Ava x => Ava (1 + x)
    | Apl x y => Apl (renomme x) (renomme y)
    | Amu x y => Amu (renomme x) (renomme y)
    | Amo x y => Amo (renomme x) (renomme y)
    end.

(** Définir une fonction [decale] qui prend un état [s] et rend
    l'état dans lequel la valeur de x0 est 0,
    la valeur de x1 est la valeur de x0 dans [s],
    la valeur de x2 est la valeur de x1 dans [s],
    la valeur de x3 est la valeur de x2 dans [s], etc.
    Indication : ce n'est PAS un Fixpoint *)

Definition decale (s : state) : state := Cons 0 s.

(** Démontrer qu'évaluer une expression renommée dans un environnement
    décalé rend la même chose qu'avant *)

Require Import Arith. Import Nat.

Lemma eval_renomme_decale : forall a s, eval a s = eval (renomme a) (decale s).
Proof.
    intros.
    induction a.
    - cbn [renomme eval]. reflexivity.
    - unfold decale. cbn [eval renomme get].
      simpl. rewrite Nat.sub_0_r. reflexivity.
    - cbn [eval renomme]. rewrite IHa1, IHa2. reflexivity.
    - cbn [eval renomme]. rewrite IHa1, IHa2. reflexivity.
    - cbn [eval renomme]. rewrite IHa1, IHa2. reflexivity.
Qed.

(** FIN QUESTIONS FACULTATIVES (4) *)
(* ----------------------------------------------------------------------- *)

(* ----------------------------------------------------------------------- *)
(** DEBUT QUESTIONS FACULTATIVES (5) *)

(** ** Expressions booléennes *)

(** Définir un type d'AST nommé bexp pour des expressions booléennes
    comprenant :
    - les constantes booléennes Btrue et Bfalse
    - un opérateur booléen unaire Bnot
    - des opérateurs booléens binaires Band et Bor
    - un opérateur de comparaison représentant le test d'égalité
      entre deux expressions arithmétiques
*)

(** L'environnenent initial de Coq comprend, en plus de [nat],
    un type énuméré nommé [bool à deux valeurs nommées [true] et [false]
    ainsi que des fonctions telles que la disjonction entre deux valeurs
    de type [bool].
    Vous pouvez découvrir tout cela au moyen de la commande "Print bool"
    et de la commande Search indiquée ci-dessus, mais on vous demande de
    reprogrammer les fonctions booléennes par vous-même en utilisant, comme
    pour [coulfeu], match with suivant le schéma :

      match blabla_booléen with
      | true => ...
      | false => ...
      end

    L'opération de comparaison entre deux entiers devra aussi être programmée.

    Définir une fonction d'évaluation sur bexp en s'appuyant sur ces fonctions.
*)

Inductive bexp :=
  | Btrue : bexp
  | Bfalse : bexp
  | Bnot : bexp -> bexp
  | Band : bexp -> bexp -> bexp
  | Bor : bexp -> bexp -> bexp
  | Beq : aexp -> aexp -> bexp
  .

Fixpoint beval b s := match b with
  | Btrue => true
  | Bfalse => false
  | Bnot x => negb (beval x s)
  | Band x y => andb (beval x s) (beval y s)
  | Bor x y => orb (beval x s) (beval y s)
  | Beq x y => Nat.eqb (eval x s) (eval y s)
  end.

(** FIN QUESTIONS FACULTATIVES (5) *)
(* ----------------------------------------------------------------------- *)


Require Import MyTactics.
Require Import PreLattice.
Require Import Arith.
Require Import Omega.
Require Import Classical.

Instance NatJoinPreLattice : JoinPreLattice nat le :=
{ join := max }.
Proof.
* auto with arith.
* auto with arith.
* auto using Max.max_lub.
Defined.

Instance NatMeetPreLattice : MeetPreLattice nat le :=
{ meet := min }.
Proof.
* auto with arith.
* auto with arith.
* auto using Min.min_glb.
Qed.

Instance NatHasBottom : HasBottom nat le :=
{ bottom := 0 }.
Proof.
intro t. auto with arith.
Qed.

Lemma not_empty_is_sup_in :
  forall (P: nat -> Prop) (sup: nat),
    (exists n, P n) ->
    is_sup P sup ->
    P sup.
Proof.
intros P sup [n0 Hn0] H.
generalize dependent P. revert n0. induction sup; intros n0 P Hn0 Hsup.
* destruct Hsup. specialize (H n0 Hn0).
  compute in H. destruct n0; trivial.
  exfalso. omega.
* destruct (eq_nat_dec n0 (S sup)).
  + congruence.
  + assert (n0 <= sup).
    { destruct Hsup. specialize (H n0 Hn0). compute in H. omega. }
    pose (P' n := P (S n)).
    assert (exists n1, P' n1) as [n1 Hn1].
    { apply NNPP. intro Hempty.
      assert (forall n, ~ P' n) as HP' by firstorder. clear Hempty.
      { unfold P' in HP'.
        assert (is_upper_bound P 0) as H0.
        { intros m Hm. destruct m.
          - reflexivity.
          - exfalso. apply (HP' _ Hm).
        }
        destruct Hsup as [_ HLUB].
        specialize (HLUB _ H0). omega.
      }
    }
    destruct Hsup as [HUB HLUB].
    assert (is_sup P' sup) as Hsup'.
    { unfold P'. split.
      - intros m Hm. specialize (HUB _ Hm). omega.
      - intros m Hm.
        assert (S sup <= S m) as HSm.
        { apply HLUB. intros k Hk.
          destruct k. auto with arith.
          assert (k <= m). { apply Hm. eauto. }
          auto with arith.
        }
        auto with arith.
    }
    specialize (IHsup _ P' Hn1 Hsup').
    assumption.
Qed.

(** The set of all natural numbers. *)
Definition Naturals : nat -> Prop := fun _ => True.

Lemma Naturals_sup_directed : sup_directed Naturals.
Proof.
split.
* exists 0. compute. trivial.
* intros m n Hm Hn. exists (max m n). splits.
  - compute. trivial.
  - auto with arith.
  - auto with arith.
Qed.


From Coq Require Import Arith.
From Coq Require Import Relations.
From KBase Require Import Tactics.
From KBase Require Import Relations.

(** Definition of the terms *)
Inductive tm : Set :=
  | I : nat -> tm (* de Bruijn indices *)
  | Abs : tm -> tm
  | App : tm -> tm -> tm.

(** Shifting de Bruijn indices in terms *)

(* The function shift adds n to all indices greater or equal to k in the term t.
The index k takes into account the number of lambda abstraction *)
Fixpoint shift (t : tm) (n k : nat) : tm :=
  match t with
  | I i => if lt_dec i k then I i else I (i + n)
  | Abs t => Abs (shift t n (k + 1))
  | App t1 t2 => App (shift t1 n k) (shift t2 n k)
  end.

(* Let us prove some usefull theorems about shift. *)

Theorem shift_0 : forall t k,
  shift t 0 k = t.
Proof.
  induction t; crush; autodestruct; crush.
Qed.
#[export] Hint Resolve shift_0 : KBaseHints.
#[export] Hint Rewrite shift_0 : KBaseHints.

Theorem shift_merge : forall t n1 k1 n2 k2,
  k1 <= k2 ->
  k2 <= k1 + n1 ->
  shift (shift t n1 k1) n2 k2 = shift t (n1 + n2) k1.
Proof.
  induction t; crush; repeat (autodestruct; crush).
Qed.
#[export] Hint Resolve shift_merge : KBaseHints.
#[export] Hint Rewrite shift_merge : KBaseHints.

Theorem shift_swap_le : forall t n1 k1 n2 k2,
  k2 <= k1 ->
  shift (shift t n1 k1) n2 k2 = shift (shift t n2 k2) n1 (k1 + n2).
Proof.
  induction t; crush; repeat (autodestruct; crush).
Qed.
#[export] Hint Rewrite shift_swap_le : KBaseHints.

(* This theorem is the reverse of the preceding one *)
Theorem shift_swap_ge : forall t n1 k1 n2 k2,
  k2 >= k1 + n1 ->
  shift (shift t n1 k1) n2 k2 = shift (shift t n2 (k2 - n1)) n1 k1.
Proof.
  induction t; crush; repeat (autodestruct; crush).
Qed.
#[export] Hint Rewrite shift_swap_ge : KBaseHints.

(** Let us now define the substitution *)
Fixpoint subst (t u : tm) (k : nat) : tm :=
  match t with
  | I i => match lt_eq_lt_dec i k with
            | inleft (left _) => I i
            | inleft (right _) => shift u k 0
            | inright _ => I (i - 1)
           end
  | Abs t => Abs (subst t u (k + 1))
  | App t1 t2 => App (subst t1 u k) (subst t2 u k)
  end.

(** Theorems about the substitution function *)
Theorem subst_shift_swap : forall t u k1 n2 k2,
  k2 <= k1 ->
  shift (subst t u k1) n2 k2 = subst (shift t n2 k2) u (k1 + n2).
Proof.
  induction t; crush; repeat (autodestruct; crush).
Qed.
#[export] Hint Resolve subst_shift_swap : KBaseHints.

Theorem subst_shift_merge : forall t u k1 n2 k2,
  k2 <= k1 ->
  k1 < k2 + n2 ->
  subst (shift t n2 k2) u k1 = shift t (n2 - 1) k2.
Proof.
  induction t; crush; repeat (autodestruct; crush).
Qed.
#[export] Hint Resolve subst_shift_merge : KBaseHints.

Theorem subst_shift_shift : forall t u k1 n2 k2 n3 k3,
  k1 + k3 < k2 ->
  k2 <= k1 + k3 + 1 + (n3 - n2) ->
  n2 <= n3 ->
  subst (shift t n2 k2) (shift u n3 k3) k1 =
  shift (subst t (shift u (n3 - n2) k3) k1) n2 (k2 - 1).
Proof.
  induction t; crush; repeat (autodestruct; crush).
  repeat match goal with
  | [ |- context [shift (shift ?x ?n1 ?k1) ?k2 0]] =>
      rewrite (shift_swap_le x n1 k1 k2 0) by crush
  | [ |- shift ?x ?n1 ?k1 = shift (shift ?x (?n1 - ?n2) ?k1) ?n2 ?k2 ] =>
      rewrite (shift_merge x (n1 - n2) k1 n2 k2) by crush
  | [ |- context [?x - ?y + ?y]] => assert (x - y + y = x) by crush; auto
  end.
Qed.
#[export] Hint Resolve subst_shift_shift : KBaseHints.
#[export] Hint Rewrite subst_shift_shift : KBaseHints.

(** Also known as the substitution lemma *)
Theorem subst_swap : forall t u1 k1 u2 k2,
  k1 <= k2 ->
  subst (subst t u1 k1) u2 k2 = subst (subst t u2 (S k2)) (subst u1 u2 (k2 - k1)) k1.
Proof.
  induction t; crush; repeat (autodestruct; crush);
  (* We are left with to cases where we need to massage the hypothesis
     a little bit to apply subst_shift_swap and subst_shift_merge *)
  match goal with
  | [ |- subst (shift ?u1 ?k1 0) ?u2 ?k2 = shift (subst ?u1 ?u2 (?k2 - ?k1)) ?k1 0] =>
        let H1 := fresh "H1" in
        let H2 := fresh "H2" in
        let H3 := fresh "H3" in
        assert (H1 : 0 <= k2 - k1) by lia';
        pose proof (subst_shift_swap u1 u2 (k2 - k1) k1 0 H1) as H2;
        assert (H3 : k2 - k1 + k1 = k2) by lia';
        rewrite H3 in H2;
        auto
  | [ |- shift ?u2 ?n2 0 = subst (shift ?u (S ?n2) 0) ?u1 ?k1] =>
      let H1 := fresh "H1" in
      let H2 := fresh "H2" in
      assert (H1 : 0 <= k1) by lia';
      assert (H2 : k1 < S n2) by lia';
      pose proof (subst_shift_merge u2 u1 k1 (S n2) 0 H1 H2);
      crush
  end.
Qed.
#[export] Hint Resolve subst_swap : KBaseHints.
#[export] Hint Rewrite <- subst_swap : KBaseHints.

(** Small steps *)
Inductive ss : tm -> tm -> Prop :=
  | ss_left : forall t1 t1' t2, ss t1 t1' -> ss (App t1 t2) (App t1' t2)
  | ss_right : forall t1 t2 t2', ss t2 t2' -> ss (App t1 t2) (App t1 t2')
  | ss_abs : forall t t', ss t t' -> ss (Abs t) (Abs t')
  | ss_beta : forall t u, ss (App (Abs t) u) (subst t u 0).

#[export] Hint Constructors ss : KBaseHints.

Notation "ss*" := (clos_refl_trans_1n tm ss).

Lemma ss_shift : forall t t' n k,
  ss t t' ->
  ss (shift t n k) (shift t' n k).
Proof.
  intros t t' n k t_t';
  generalize dependent k;
  induction t_t'; intro k; crush.
  - pose proof (ss_beta (shift t n (k + 1)) (shift u n k));
    rewrite (subst_shift_shift t u 0 n (k + 1) n k) in H by crush;
    assert (H2 : k + 1 - 1 = k) by crush;
    rewrite H2 in H;
    assert (H3 : n - n = 0) by crush;
    rewrite H3 in H;
    rewrite (shift_0 u k) in H;
    auto.
Qed.
#[global] Hint Resolve ss_shift : KBaseHints.

Lemma ss_subst_left : forall t t' u k,
  ss t t' ->
  ss (subst t u k) (subst t' u k).
Proof.
  intros t t' u k t_t';
  generalize dependent k;
  induction t_t'; crush; repeat (autodestruct; crush).
  - pose proof (ss_beta (subst t u (k + 1)) (subst u0 u k)).
    assert (H3 : 0 <= k) by crush.
    pose proof (subst_swap t u0 0 u k H3) as H4.
    assert (S k = k + 1) by crush.
    assert (k - 0 = k) by crush.
    crush.
Qed.
#[global] Hint Resolve ss_subst_left : KBaseHints.

(** We want to prove the confluence of the small steps relation. We will first
        show that ss and pss defined below have the same reflexive transitive
        closure. Then prove that pss is confluent, thus proving ss confluent.*)

(** Parallel small steps *)
Inductive pss : tm -> tm -> Prop :=
| pss_i : forall i, pss (I i) (I i)
| pss_para : forall t1 t1' t2 t2',
    pss t1 t1' ->
    pss t2 t2' ->
    pss (App t1 t2) (App t1' t2')
| pss_abs : forall t t',
    pss t t' ->
    pss (Abs t) (Abs t')
| pss_beta : forall t t' u u',
    pss t t' ->
    pss u u' ->
  pss (App (Abs t) u) (subst t' u' 0).

#[local] Hint Constructors pss : KBaseHints.

Notation "pss*" := (clos_refl_trans_1n tm pss).

Lemma pss_refl : reflexive tm pss.
Proof.
  intro t1;
  induction t1; crush.
Qed.
#[local] Hint Resolve pss_refl : KBaseHints.

Lemma inclusion_ss_pss : inclusion tm ss pss.
Proof.
  intros x y x_y; induction x_y; crush.
Qed.
#[local] Hint Resolve inclusion_ss_pss : KBaseHints.

Lemma inclusion_pss_ss_rt : inclusion tm pss ss*.
Proof.
  intros x y x_y; induction x_y; crush.
  - assert (H : ss* (App (Abs t) u) (App (Abs t') u')) by crush.
    pose proof (ss_beta t' u').
    crush.
Qed.
#[local] Hint Resolve inclusion_pss_ss_rt : KBaseHints.

Lemma pss_shift : forall t t' n k,
  pss t t' ->
  pss (shift t n k) (shift t' n k).
Proof.
  intros t t' n k t_t';
  generalize dependent k;
  induction t_t'; crush.
  - specialize (IHt_t'1 (k + 1)).
    specialize (IHt_t'2 k).
    pose proof (pss_beta _ _ _ _ IHt_t'1  IHt_t'2) as H.
    rewrite (subst_shift_shift t' u' 0 n (k + 1) n k) in H by crush.
    assert (H2 : k + 1 - 1 = k) by crush.
    rewrite H2 in H.
    assert (H3 : n - n = 0) by crush.
    rewrite H3 in H.
    rewrite (shift_0 u' k) in H.
    crush.
Qed.
#[local] Hint Resolve pss_shift : KBaseHints.

Lemma pss_subst : forall t t' u u' k,
  pss t t' ->
  pss u u' ->
  pss (subst t u k) (subst t' u' k).
Proof.
  intros t t' u u' k t_t';
  generalize dependent k;
  induction t_t'; crush; repeat (autodestruct; crush).
  - specialize (IHt_t'1 (k + 1) H).
    specialize (IHt_t'2 k H).
    pose proof (pss_beta _ _ _ _ IHt_t'1  IHt_t'2) as H2.
    assert (H3 : 0 <= k) by crush.
    pose proof (subst_swap t' u'0 0 u' k H3) as H4.
    assert (S k = k + 1) by crush.
    assert (k - 0 = k) by crush.
    crush.
Qed.
#[local] Hint Resolve pss_subst : KBaseHints.

(* Now we can easily prove ss_subst_right *)
(* Crush will use the fact that pss is sandwich between
   ss and ss*. *)
Lemma ss_subst_right : forall t u u' k,
  ss u u' ->
  ss* (subst t u k) (subst t u' k).
Proof.
  crush.
Qed.
#[global] Hint Resolve ss_subst_right : KBaseHints.

Lemma ss_subst_para : forall t t' u u' k,
  ss* t t' ->
  ss* u u' ->
  ss* (subst t' u' k) (subst t' u' k).
Proof.
  crush.
Qed.
#[global] Hint Resolve ss_subst_para : KBaseHints.

Fixpoint pss_normalizer (x : tm) : tm :=
  match x with
  | I i => I i
  | Abs t => Abs (pss_normalizer t)
  | App (Abs t) u => subst (pss_normalizer t) (pss_normalizer u) 0
  | App t1 t2 => App (pss_normalizer t1) (pss_normalizer t2)
  end.

Lemma Triangle_pss_normalizer : triangle_op pss pss_normalizer.
Proof.
  intros x y x_y; induction x_y; crush; autodestruct; crush.
  - inversion x_y1; subst.
    inversion IHx_y1; subst.
    crush.
Qed.
#[local] Hint Resolve Triangle_pss_normalizer : KBaseHints.

Lemma pss_diamond : diamond pss.
Proof.
  exact (triangle_diamond pss pss_normalizer Triangle_pss_normalizer).
Qed.
#[local] Hint Resolve pss_diamond : KBaseHints.

Lemma ss_confluent : confluent ss.
Proof.
  apply (triangle_confluent ss pss pss_normalizer); crush.
Qed.
#[global] Hint Resolve ss_confluent : KBaseHints.


(** Can you write down three "different" proofs of transitivity (they should all be judgmentally different; [refl] should not prove any two of them the same. *)

Definition trans1
: forall A (x y z : A),
    x = y -> y = z -> x = z.
intros. rewrite <- H in H0. apply H0. Defined.
Definition trans2
: forall A (x y z : A),
    x = y -> y = z -> x = z.
intros. transitivity y. auto. auto. Defined.
Definition trans3
: forall A (x y z : A),
    x = y -> y = z -> x = z.
intros. rewrite H. rewrite H0. auto. Defined.
(** Now we have Coq check that they are not the same; these lines should compile unmodified. *)

Fail Check eq_refl : trans1 = trans2.

Fail Check eq_refl : trans2 = trans3.

Fail Check eq_refl : trans1 = trans3.

(** Now prove that these are all equal (propositionally, but not judgmentally. *)

Definition trans_12
: forall A (x y z : A) (H0 : x = y) (H1 : y = z),
    trans1 A x y z H0 H1 = trans2 A x y z H0 H1.
Proof.
  unfold trans1. unfold trans2. intros.
  subst. auto.
Qed.
Definition trans_23
: forall A (x y z : A) (H0 : x = y) (H1 : y = z),
    trans2 A x y z H0 H1 = trans3 A x y z H0 H1.
Proof.
  unfold trans2. unfold trans3. intros.
  subst. auto.
Qed.

(** We can also prove associativity. *)

Definition trans_assoc
: forall A (x y z w : A) (H0 : x = y) (H1 : y = z) (H2 : z = w),
    eq_trans H0 (eq_trans H1 H2) = eq_trans (eq_trans H0 H1) H2.
Proof. intros. subst. auto. Qed.

Definition trans_Vp
: forall A (x y : A) (H : x = y),
    eq_trans (eq_sym H) H = eq_refl.
Proof. intros. subst. auto. Qed.

Definition trans_pV
: forall A (x y : A) (H : x = y),
    eq_trans H (eq_sym H) = eq_refl.
Proof. intros. subst. auto. Qed.

Definition trans_1p
: forall A (x y : A) (H : x = y),
    eq_trans eq_refl H = H.
Proof. intros. subst. auto. Qed.

Definition trans_p1
: forall A (x y : A) (H : x = y),
    eq_trans H eq_refl = H.
Proof. intros. subst. auto. Qed.

Definition trans_sym
: forall A (x y z : A) (H0 : x = y) (H1 : y = z),
    eq_sym (eq_trans H0 H1) = eq_trans (eq_sym H1) (eq_sym H0).
Proof. intros. subst. auto. Qed.


(* week-04_equational-reasoning.v *)
(* FPP 2020 - YSC3236 2020-2021, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 06 Sep 2020, with the mirror function *)
(* was: *)
(* Version of 05 Sep 2020, with the fold-unfold lemmas for the power function *)
(* was: *)
(* Version of 05 Sep 2020 *)

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

(* Paraphernalia: *)

Ltac fold_unfold_tactic name := intros; unfold name; fold name; reflexivity.

Require Import Arith.

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

Definition recursive_specification_of_addition (add : nat -> nat -> nat) :=
  (forall y : nat,
      add O y = y)
  /\
  (forall x' y : nat,
      add (S x') y = S (add x' y)).

Fixpoint add_v1 (i j : nat) : nat :=
  match i with
  | O =>
    j
  | S i' =>
    S (add_v1 i' j)
  end.

Lemma fold_unfold_add_v1_O :
  forall j : nat,
    add_v1 O j =
    j.
Proof.
  fold_unfold_tactic add_v1.
Qed.

Lemma fold_unfold_add_v1_S :
  forall i' j : nat,
    add_v1 (S i') j =
    S (add_v1 i' j).
Proof.
  fold_unfold_tactic add_v1.
Qed.

Theorem add_v1_satisfies_the_recursive_specification_of_addition :
  recursive_specification_of_addition add_v1.
Proof.
  unfold recursive_specification_of_addition.
  split.

  - exact fold_unfold_add_v1_O.

  - exact fold_unfold_add_v1_S.
Qed.

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

Fixpoint power (x n : nat) : nat :=
  match n with
  | O =>
    1
  | S n' =>
    x * power x n'
  end.

Lemma fold_unfold_power_O :
  forall x : nat,
    power x O =
    1.
Proof.
  fold_unfold_tactic power.
Qed.

Lemma fold_unfold_power_S :
  forall x n' : nat,
    power x (S n') =
    x * power x n'.
Proof.
  fold_unfold_tactic power.
Qed.

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

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

Lemma fold_unfold_fib_v1_O :
  fib_v1 O =
  0.
Proof.
  fold_unfold_tactic fib_v1.
Qed.

Lemma fold_unfold_fib_v1_S :
  forall n' : nat,
    fib_v1 (S n') =
    match n' with
    | 0 => 1
    | S n'' => fib_v1 n' + fib_v1 n''
    end.
Proof.
  fold_unfold_tactic fib_v1.
Qed.

Corollary fold_unfold_fib_v1_1 :
  fib_v1 1 =
  1.
Proof.
  rewrite -> (fold_unfold_fib_v1_S 0).
  reflexivity.
Qed.

Corollary fold_unfold_fib_v1_SS :
  forall n'' : nat,
    fib_v1 (S (S n'')) =
    fib_v1 (S n'') + fib_v1 n''.
Proof.
  intro n''.
  rewrite -> (fold_unfold_fib_v1_S (S n'')).
  reflexivity.
Qed.

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

Inductive binary_tree (V : Type) : Type :=
| Leaf : V -> binary_tree V
| Node : binary_tree V -> binary_tree V -> binary_tree V.

(* ***** *)

Definition specification_of_mirror (mirror : forall V : Type, binary_tree V -> binary_tree V) : Prop :=
  (forall (V : Type)
          (v : V),
      mirror V (Leaf V v) =
      Leaf V v)
  /\
  (forall (V : Type)
          (t1 t2 : binary_tree V),
      mirror V (Node V t1 t2) =
      Node V (mirror V t2) (mirror V t1)).

(* ***** *)

Fixpoint mirror (V : Type) (t : binary_tree V) : binary_tree V :=
  match t with
  | Leaf _ v =>
    Leaf V v
  | Node _ t1 t2 =>
    Node V (mirror V t2) (mirror V t1)
  end.

Lemma fold_unfold_mirror_Leaf :
  forall (V : Type)
         (v : V),
    mirror V (Leaf V v) =
    Leaf V v.
Proof.
  fold_unfold_tactic mirror.
Qed.

Lemma fold_unfold_mirror_Node :
  forall (V : Type)
         (t1 t2 : binary_tree V),
    mirror V (Node V t1 t2) =
    Node V (mirror V t2) (mirror V t1).
Proof.
  fold_unfold_tactic mirror.
Qed.

(* ***** *)

Proposition there_is_at_least_one_mirror_function :
  specification_of_mirror mirror.
Proof.
  unfold specification_of_mirror.
  split.
  - exact fold_unfold_mirror_Leaf.
  - exact fold_unfold_mirror_Node.
Qed.

(* ***** *)

Theorem mirror_is_involutory :
  forall (V : Type)
         (t : binary_tree V),
    mirror V (mirror V t) = t.
Proof.
  intros V t.
  induction t as [v | t1 IHt1 t2 IHt2].
  - rewrite -> (fold_unfold_mirror_Leaf V v).
    exact (fold_unfold_mirror_Leaf V v).
  - rewrite -> (fold_unfold_mirror_Node V t1 t2).
    rewrite -> (fold_unfold_mirror_Node V (mirror V t2) (mirror V t1)).
    rewrite -> IHt1.
    rewrite -> IHt2.
    reflexivity.
Qed.

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

(* end of week-04_equational-reasoning.v *)


Require Import
  Algebra.SetsC
  Algebra.OrderC
  Algebra.PreOrder
  Types.List
  Coq.Lists.List.

Import ListNotations.

Local Open Scope FT.

Module ML.
Section FreeMeetLattice.

Context {X : PreOrder}
        {POX : PreO.t (le X)}.

Definition FreeML : PreOrder :=
  {| PO_car := list X
  ; le := fun a b => Each (fun ub => LSome (fun ua => ua <=[X] ub) a) b
  |}.

Global Instance PO : PreO.t (le FreeML).
Proof.
constructor; simpl; intros.
- intros x' mem. econstructor. eassumption.
  reflexivity.
- unfold Each. intros.
  specialize (X1 x0 X2). simpl in X1.
  induction X1.
  specialize (X0 _ S_member). simpl in X0.
  induction X0.
  econstructor. eassumption.
  etransitivity; eassumption.
Qed.

Lemma FSubset_le (xs ys : FreeML) : (ys ⊆ xs)%list -> xs <= ys.
Proof.
simpl. unfold FSubset, Each.
intros H x mem.
eexists x. apply H. assumption.
reflexivity.
Qed.

Local Open Scope Subset.

Definition bmeet (xs ys : FreeML) : FreeML := xs ++ ys.

Local Infix "++" := bmeet.

Lemma bmeet_le_r (l r : FreeML)
  : l ++ r <= r.
Proof.
unfold bmeet. apply FSubset_le. apply FSubset_app_r.
Qed.

Lemma bmeet_le_l (l r : FreeML)
  : l ++ r <= l.
Proof.
unfold bmeet. apply FSubset_le. apply FSubset_app_l.
Qed.

Lemma app_le (xs ys : FreeML) :
  xs <= ys -> xs <= (xs ++ ys).
Proof.
simpl. unfold bmeet, Each. intros H x mem.
apply member_app in mem. induction mem.
- econstructor. eassumption. reflexivity.
- apply H. assumption.
Qed.

Lemma le_app_r (xs xs' ys : FreeML)
  : xs <= xs' -> (xs ++ ys) <= (xs' ++ ys).
Proof.
simpl. unfold Each, bmeet. intros H x mem.
apply member_app in mem. apply LSome_app.
induction mem.
- left. apply H. assumption.
- right. econstructor. eassumption. reflexivity.
Qed.

Definition inj (a : X) : FreeML := [a].

Lemma le_singleton (a b : X)
  : a <= b -> inj a <= inj b.
Proof.
simpl; unfold Each, inj; intros H x mem.
apply member_singleton in mem.
subst. econstructor. econstructor. eassumption.
Qed.

Lemma le_singleton_opp (a b : X)
  : inj a <= inj b -> a <= b.
Proof.
simpl; unfold Each, inj; intros H.
specialize (H _ here). induction H.
apply member_singleton in S_member.
subst. assumption.
Qed.

Lemma bmeet_comm (xs ys : FreeML)
  : (xs ++ ys) <= (ys ++ xs).
Proof.
simpl. unfold Each, bmeet. intros x mem.
apply member_app in mem. apply LSome_app.
induction mem; [right | left];
  (econstructor; [eassumption | reflexivity]).
Qed.

Lemma le_app_l (ys ys' xs : FreeML)
  : ys <= ys' -> (ys ++ xs) <= (ys' ++ xs).
Proof.
intros H.
rewrite (bmeet_comm ys).
etransitivity.
Focus 2. eapply le_app_r. eassumption.
apply bmeet_comm.
Qed.

Lemma le_app_distr {xs xs' ys ys' : FreeML}
  : xs <= xs' -> ys <= ys' -> (xs ++ ys) <= (xs' ++ ys').
Proof.
simpl. unfold Each, bmeet.
intros Hx Hy x mem.
apply member_app in mem. apply LSome_app.
induction mem.
- left. apply Hx. assumption.
- right. apply Hy. assumption.
Qed.

Lemma le_cons (a b : X) (xs ys : FreeML)
  : a <= b -> xs <= ys -> (inj a ++ xs) <=[FreeML] (inj b ++ ys).
Proof.
intros H H'.
apply (@le_app_distr [a] [b] xs ys).
apply le_singleton. assumption. assumption.
Qed.

Lemma le_cons_r {xs ys : FreeML} {a : X}
  (Ha : xs <= inj a) (Hys : xs <= ys)
  : xs <=[FreeML] (inj a ++ ys).
Proof.
simpl. unfold Each.
intros x mem. inv mem.
- apply Ha. constructor.
- apply Hys. assumption.
Qed.

Lemma le_app_each (l x y : FreeML)
  (lx : l <= x) (ly : l <= y)
  : l <= (x ++ y).
Proof.
simpl. unfold Each, bmeet. intros u mem.
apply member_app in mem. destruct mem.
- apply lx. assumption.
- apply ly. assumption.
Qed.

Lemma down_app (b c : FreeML) : (eq b ↓ eq c) === ⇓ (eq (b ++ c) : FreeML -> Prop).
Proof.
apply Same_set_iff.
intros bc. split; intros.
- destruct X0. le_downH d. le_downH d0.
  le_down.
  apply le_app_each; assumption.
- le_downH X0. split; le_down.
  etransitivity. eassumption. apply FSubset_le.
  apply FSubset_app_l.
  etransitivity. eassumption. apply FSubset_le.
  apply FSubset_app_r.
Qed.

Lemma Each_monotone (P : X -> Type)
  (Pmono : forall x y, x <= y -> P x -> P y)
  (xs ys : FreeML)
  (H : xs <= ys) : Each P xs -> Each P ys.
Proof.
intros E x mem. specialize (H x mem).
simpl in H. induction H.
eapply Pmono. eassumption. apply E. assumption.
Qed.

End FreeMeetLattice.
End ML.

Arguments ML.FreeML : clear implicits.

Delimit Scope FreeML_scope with FreeML.
Infix "∧" := ML.bmeet (at level 60) : FreeML_scope.


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

Axiom replace_with_your_solution_here : forall {A : Type}, A.

Section InsertionSort.

Variable T : eqType.
Variable leT : rel T.
Implicit Types x y z : T.

(** Insert an element [e] into a sorted list [s] *)
Fixpoint insert e s : seq T :=
  if s is x :: s' then
    if leT e x then e :: s
    else x :: (insert e s')
  else [:: e].

(** Sort input list [s] *)
Fixpoint sort s : seq T :=
  if s is x :: s' then insert x (sort s')
  else [::].

Hypothesis leT_total : total leT.
Hypothesis leT_tr : transitive leT.

Lemma insert_path z e s :
  leT z e ->
  path leT z s ->
  path leT z (insert e s).
Proof.
move: z.
elim: s=> [/=| x1 s IHs] z.
- by move => ->.
move=> z_le_e.
move=> /=.
case/andP=> z_le_x1 path_x1_s.
case: ifP.
- by rewrite /= z_le_e path_x1_s => ->.
move=> /= e_gt_x1.
rewrite z_le_x1.
have:= leT_total e x1.
rewrite {}e_gt_x1 /= => x1_le_e.
exact: IHs.
Qed.

Lemma insert_sorted e s :
  sorted leT s ->
  sorted leT (insert e s).
Proof.
rewrite /sorted.
case: s=> // x s.
move=> /=.
case: ifP; first by move=> /= ->->.
move=> e_gt_x.
apply: insert_path.
have:= leT_total e x.
by rewrite e_gt_x /= => ->.
Qed.

Lemma sort_sorted s : sorted leT (sort s).
Proof.
  rewrite /sorted.
  elim : s.
  - by rewrite //.
  - move => a l IH.
    move => //=.
    move : (@insert_sorted a (sort l) IH).
    rewrite /sorted.
    done.
Qed.

(** * Exercise *)

Lemma path_let e x l : leT e x -> path leT x l -> path leT e l.
Proof.
  elim : l.
  - by move => /=.
  - move => a l ih /= le_e_x.
    case/andP.
    move => le_x_a.
    move : (leT_tr le_e_x le_x_a).
    move => h1 h2.
    rewrite h1 h2.
    done.
Qed.

Lemma filter_keeps_sorted : forall l p x,
    sorted leT (x :: l) ->
    sorted leT (x :: filter p l).
Proof.
  elim.
  - by rewrite /=.
  - move => e l IH p x /=.
    case : ifP.
    set ih := (IH p e).
    move => h1.
    case/andP.
    move => le_x_e h2.
    have h3 : sorted leT (e :: l).
      by rewrite /sorted.
      move : (ih h3).
      rewrite /sorted /= le_x_e.
        by done.
  - move => h1.
    case/andP.
    move => le_x_e h2.
    set ih := IH p x.
    have h3 : sorted leT (x :: l).
    rewrite /=.
      by exact (path_let le_x_e h2).
      move : (ih h3) => /=.
      done.
Qed.

Lemma path_sorted a l : path leT a l -> sorted leT l.
Proof.
  elim : l.
  - by rewrite /=.
  - move => e l ih /=; case/andP; by done.
Qed.

Lemma insert_in_sorted e l :
  sorted leT (e :: l) -> insert e l = e :: l.
Proof.
  case : l.
  - by rewrite /=.
  - move => a l.
    rewrite /sorted /=.
    case/andP => h1 h2.
    rewrite h1.
    by done.
Qed.

Lemma sort_of_sorted l : sorted leT l -> (sort l) = l.
Proof.
  elim : l.
  - by rewrite /=.
  - move => a l ih.
    rewrite /=.
    move => h1.
    set h2 := path_sorted h1.
    rewrite (ih h2).
    have h3 : sorted leT (a :: l).
    by rewrite /sorted.
    by exact (insert_in_sorted h3).
Qed.

Lemma path_le a e l : leT e a -> path leT a l -> path leT e l.
Proof.
  case l.
  - by rewrite /=.
  - move => x xs /= le_e_a.
    case/andP => le_a_x.
    move : (leT_tr le_e_a le_a_x) => le_e_x p_a_x.
    by rewrite le_e_x p_a_x.
Qed.

Lemma insert_filtered_path (p : T -> bool) e l :
  p e ->
  path leT e l ->
  insert e (filter p l) = e :: (filter p l).
Proof.
  move : e.
  elim : l.
  - by rewrite /=.
  - move => a l ih e pe /=.
    case/andP => le_e_a p_a_l.
  - case : ifP => pa.
    by rewrite /= le_e_a.
  - set p_e_l := path_le le_e_a p_a_l.
    by rewrite (ih e pe p_e_l).
Qed.

Lemma filter_path p e l:
  path leT e l -> path leT e (filter p l).
Proof.
  move : e.
  elim : l.
  - by rewrite /=.
  - move => a l ih e.
    rewrite /=.
    case/andP => le_e_a p_a_l.
    set p_e_l := path_le le_e_a p_a_l.
    case : ifP => pa.
  - rewrite /=.
    set h1 := (ih a p_a_l).
    by rewrite le_e_a h1.
  - by exact (ih e (path_le le_e_a p_a_l)).
Qed.

Lemma insert_filtered (p : T -> bool) a l :
  p a
  -> (sorted leT l)
  -> insert a (filter p l) = filter p (insert a l).
Proof.
  move : a.
  elim : l => a.
  - move => pa /=. by rewrite pa.
  - move => l ih e pe.
    rewrite /=.
    move => path_al.
    case : ifP => pa /=.
  - case : ifP => le_e_a.
  - by rewrite /= pe pa.
  - rewrite {2}/filter pa.
    by rewrite (ih e pe (path_sorted path_al)).
  - case : ifP => le_e_a.
  - set h1 := (path_le le_e_a path_al).
    set h2 := (@filter_path p e l h1).
    set h3 := (@insert_filtered_path p e l pe h1).
    by rewrite h3 /= pe pa.
  - rewrite /= pa.
    set h1 := (@path_sorted a l path_al).
    by rewrite (ih e pe h1).
Qed.

Lemma mis_insert_filtered (p : T -> bool) a l:
  p a = false
  -> sorted leT l
  -> filter p (insert a l) = filter p l.
Proof.
  move : a.
  elim : l => e.
  - move => npe.
      by rewrite /= npe.
  - move => l ih a npa.
    rewrite /sorted /= => p_e_l.
    case : ifP => le_a_e.
  - by rewrite /= npa.
  - rewrite /=.
    case : ifP => pe.
    by rewrite (ih a npa (path_sorted p_e_l)).
  - by rewrite (ih a npa (path_sorted p_e_l)).
Qed.

Lemma filter_sort p l :
  filter p (sort l) = sort (filter p l).
Proof.
  Show.
  elim : l.
  - by done.
  - move => a l ih /=.
    case : ifP.
    rewrite /= => pa.
    set h0 := sort_sorted l.
    set h1 := @insert_filtered p a (sort l) pa h0.
    by rewrite -h1 ih.
  - move => npa.
    set h1 := @mis_insert_filtered p a (sort l) npa (sort_sorted l).
    by rewrite h1 ih.
Qed.

(** Hint: you will probably need to introduce a number of helper lemmas *)

End InsertionSort.

Section AccPredicate.

(* To help you understand the meaning of the `Acc` predicate, here is how
 it can be used to write recursive functions without explicitly using recursion: *)

(** * Exercise:  understand how `addn_f` works *)
Section AdditionViaFix_F.

(* First, let's redefine the addition on natural numbers
   using the `Fix_F` combinator: *)
About Fix_F.

Print Fix_F.

(* notice we do recursion on the `a : Acc R x` argument *)

(* To define addition, we first need to choose the relation `R`
   which "connects" successive value.
   In the case of addition `R x y` can simply mean `y = x.+1` *)

Definition R m n := n = m.+1.

(* This definition has to be transparent, otherwise
   evaluation will get stuck *)

Definition esucc_inj : injective succn. by move=> n m []. Defined.

(* Every natural number is accessible w.r.t. R defined above *)
Fixpoint acc (n : nat) : Acc R n :=
  if n is n'.+1 then
      Acc_intro n'.+1 (fun y (pf : n'.+1 = y.+1) =>
                         eq_ind n' _ (acc n') y (esucc_inj pf))
  else Acc_intro 0 (fun y contra => False_ind _ (O_S y contra)).

Check acc.
(*
By the way, `forall n : nat, Acc R n` means that `R` is a well-founded
relation: https://en.wikipedia.org/wiki/Well-founded_relation.
*)
Print well_founded.

About Fix_F.

(* Addition via `Fix_F` *)
Definition addn_f : nat -> nat -> nat :=
  fun m =>
    @Fix_F nat
           R
           (fun=> nat -> nat)
           (fun m rec =>
              match m return (_ = m -> nat -> nat) with
              | m'.+1 => fun (eq : m = m'.+1) => succn \o rec m' eq
              | 0 => fun=> id
              end erefl)
           m
           (acc m).

Compute addn_f 4.

(* This would get stuck if esucc *)
Check erefl : addn_f 2 4 = 6.

Lemma addn_equiv_addn_f :
  addn =2 addn_f.
Proof. by elim=> // m IHm n; rewrite addSn IHm. Qed.

End AdditionViaFix_F.

(** Exercise: implement multiplication on natural numbers using `Fix_F`:
    no explicit recursion, Program Fixpoint or things like that! *)

Section MultiplicationViaFix_F.

Definition muln_f : nat -> nat -> nat :=
  fun m n =>
    @Fix_F nat
           R
           (fun => nat)
           (fun k rec =>
              match k return (_ = k -> nat) with
              | (S k') =>
                fun (eq : k = (S k')) => addn n (rec k' eq)
              | O => fun => 0
              end erefl)
           m
           (acc m).

Compute muln_f 11.

(* this should not fail *)
Check erefl : muln_f 21 2 = 42.

Lemma muln_equiv_muln_f :
  muln =2 muln_f.
Proof.
  elim => // m ih n.
  rewrite mulSn (ih n) /muln_f /=.
  done.
Qed.

End MultiplicationViaFix_F.

End AccPredicate.


Record iso (A B : Set) : Set :=
  bijection {
    A_to_B : A -> B;
    B_to_A : B -> A;
    A_B_A  : forall a : A, B_to_A (A_to_B a) = a;
    B_A_B  : forall b : B, A_to_B (B_to_A b) = b
  }.

Require Import Arith.
Require Import PeanoNat.
Require Import Omega.

Theorem iso_refl : forall A : Set, iso A A.
Proof.
  intros. apply (bijection _ _ (fun x => x) (fun x => x)).
  auto. auto.
Qed.

Theorem iso_sym : forall A B : Set, iso A B -> iso B A.
Proof.
  intros. inversion H.
  apply (bijection B A B_to_A0 A_to_B0).
  auto. auto.
Qed.

Theorem iso_trans : forall A B C : Set, iso A B -> iso B C -> iso A C.
Proof.
  intros. inversion H. inversion H0.
  apply (bijection A C (fun x => A_to_B1 (A_to_B0 x)) (fun x => (B_to_A0 (B_to_A1 x)))).
  intros. specialize (A_B_A1 (A_to_B0 a)). rewrite A_B_A1. auto.
  intros. specialize (B_A_B0 (B_to_A1 b)). rewrite B_A_B0. auto.
Qed.

Theorem bijection_alt : forall (A B : Set) (A2B : A -> B) (B2A : B -> A),
  (forall a, B2A (A2B a) = a) -> (forall b1 b2, B2A b1 = B2A b2 -> b1 = b2) -> iso A B.
Proof.
  intros. assert(H' : forall b : B, A2B (B2A b) = b).
  intros. specialize (H0 (A2B (B2A b)) b). specialize (H (B2A b)).
  apply H0 in H. auto.
  apply (bijection _ _ A2B B2A H H').
Qed.

Inductive nat_plus_1 : Set := null | is_nat (n : nat).

Definition nat_to_nat_plus_1 (n : nat) : nat_plus_1 :=
  match n with
  | 0 => null
  | S n => is_nat n
  end.

Definition nat_plus_1_to_nat (n : nat_plus_1) : nat :=
  match n with
  | null => 0
  | is_nat n => S n
  end.

Theorem nat_iso_natp1 : iso nat nat_plus_1.
Proof.
  apply (bijection _ _ nat_to_nat_plus_1 nat_plus_1_to_nat).
  intros. destruct a. auto. auto.
  intros. destruct b. auto. auto.
Qed.

Inductive nat_plus_nat : Set := left (n : nat) | right (n : nat).

Fixpoint nat_to_nat_plus_nat (n : nat) :=
  match n with
  | O => left O
  | S n => match nat_to_nat_plus_nat n with
           | left n => right n
           | right n => left (S n)
           end
  end.

Definition nat_plus_nat_to_nat (a : nat_plus_nat) : nat :=
  match a with
  | left n' => n' * 2
  | right n' => S (n' * 2)
  end.

Theorem nat_iso_natpnat : iso nat nat_plus_nat.
Proof.
  apply (bijection _ _ nat_to_nat_plus_nat nat_plus_nat_to_nat);intros.
  - induction a;simpl;auto;destruct (nat_to_nat_plus_nat);subst;simpl;omega.
  - destruct b;simpl;induction n;auto;simpl in *;rewrite IHn;auto.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


From NAT Require Import Peanos_axioms.
From NAT Require Import Tutorial_World.
From NAT Require Import Addition_World.

Section Multiplication_World.
(*Well, here we go again. One of Peanos axioms states that m * 0 = 0. However, the reverse has not been shown, so let us do it now.*)
Proposition zero_mul (m : nat) : 0 * m = 0.
Proof.
    induction m.
    rewrite mul_zero.
    (*This base case is very interesting, since in some sense we are on the verge of derivining the fact that like terms commute. After all, you cannot tell the difference between 1*1 and 1*1, even though I swapped the order of the ones.(You cannot prove I did not)*)
    reflexivity.
    (*Now again we can use another axiom, and then easily simplify.*)
    rewrite succ_dist. rewrite add_zero. exact IHm.
Qed.

Proposition mul_one (m : nat) : m*1 = m.
Proof.
    induction m.
    rewrite zero_mul. reflexivity.
    rewrite succ_dist.
    rewrite mul_zero. rewrite zero_add. reflexivity.
Qed.

Proposition one_mul (m : nat) : 1*m = m.
Proof.
    induction m.
    rewrite mul_zero. reflexivity.
    rewrite succ_dist.
    rewrite IHm.
    rewrite succ_add. rewrite add_zero. reflexivity.
Qed.
(*Now we will derive one of the most important propositions in this section. That is, leftward distribtivity. The best thing to do here is to try and see which inductive variable suits you the best. It is most likely possible using any of them, but not without tears.*)
Proposition mul_add ( t a b : nat) : t*(a + b) = (t * a) + (t * b).
Proof.
    induction a. rewrite zero_add. rewrite mul_zero. rewrite zero_add.
    reflexivity.
    rewrite succ_dist. rewrite (commute (t *a)(t)).
    symmetry. rewrite add_assoc. rewrite <- IHa.
    rewrite commute. rewrite <- succ_dist. reflexivity.
Qed.
(*This is another important result, we are now going to show that multiplicaiton is associative. If you are an algebrist proving this now seems out of order, since to prove a ring structure you usually show this first. Indeed, if this angers you feel free to contact Dr. Steven Clonz at sclontz@southalabama.edu. On the other hand if you are enjoying this expierence, and wish to find an outlet for your praise, then by all means try brandon.sisler1118@gmail.com. *)
Proposition mul_assoc (a b c : nat) : (a * b) * c = a * (b * c).
Proof.
    induction c.
    rewrite mul_zero. rewrite mul_zero. rewrite mul_zero. reflexivity.
    rewrite succ_dist. rewrite succ_dist.
    rewrite mul_add. rewrite IHc. reflexivity.
Qed.
(*Now, in secret, we are going to use the next result to obtain a commutative ring. But in any case, this uses the same techniques you have been using the whole time.*)
Proposition succ_mul (a b : nat) : S (a) * b = a * b + b.
Proof.
    induction b.
    rewrite mul_zero. rewrite mul_zero. rewrite add_zero. reflexivity.
    rewrite succ_dist. rewrite IHb. rewrite add_one. symmetry.
    rewrite add_one. rewrite mul_add. rewrite mul_one. rewrite add_assoc.
    rewrite add_assoc. rewrite <- (add_assoc (a)(b)(1)).
    rewrite (commute (a)(b)). rewrite add_assoc. reflexivity.
Qed.
(*Now, let us show rightward associativity.*)
Proposition add_mul (a b t : nat) : (a + b)*t = (a * t) + (b * t).
Proof.
    induction t. rewrite mul_zero. rewrite mul_zero. rewrite mul_zero.
    rewrite add_zero. reflexivity.

    rewrite succ_dist. rewrite IHt. rewrite add_one.
    rewrite mul_add. rewrite mul_add. rewrite mul_one. rewrite mul_one.
    rewrite add_assoc. rewrite <-(add_assoc (b * t)(a)(b)).
    rewrite (commute (b*t)(a)). rewrite (add_assoc (a)(b*t)(b)).
    rewrite add_assoc. reflexivity.
Qed.
(*Great, now that we have all these results we can get to the one that would have helped you all along, and hilariously relies on none of the previous parts. On the other hand, it was good to have not used this result quite yet, since now we have a good appreciation for how things can be proven when commutivity is not neccesarily true.*)
Proposition mul_comm (m n : nat) : m * n = n * m.
Proof.
    induction n. rewrite mul_zero. rewrite zero_mul. reflexivity.

    rewrite succ_dist. rewrite succ_mul. rewrite IHn. reflexivity.
Qed.
(*To end, we will prove what could be considered a theorem that will be helpful for computation.
Consider, after all, when your instructors wave their hands and just write a * (b * c) = b * (a * c) without appealing to the axioms. This will not work here, and yet, it surely is our dream to have the computer learn to waive its hands as well. The compromise is struck by showing this computational trick is justifable. Let us do so now. *)
Proposition mul_left_comm (a b c : nat) : a * (b * c) = b * (a * c).
Proof.
    induction a. rewrite zero_mul. rewrite zero_mul. rewrite mul_zero.
    reflexivity.

    rewrite succ_mul. rewrite add_one. rewrite IHa. rewrite add_mul.
    rewrite one_mul. rewrite mul_add. reflexivity.
Qed.

End Multiplication_World.


Require Export Reals.
Open Scope R_scope.

(* 定义：实数构成的集合 *)

Definition R_Ensemble := R -> Prop.

(* 定义：实数x属于集合A *)

Definition In (x:R)(A:R_Ensemble) :Prop := A x.

Notation "x ∈ A" := (In x A) (at level 10).

(* 定义：区间 *)
(* 开区间 *)
Definition oo (a b:R) := fun x:R => a<b/\a<x<b.
Notation "( a , b )" := (oo a b).

(* 闭区间 *)
Definition cc (a b:R) := fun x:R => a<b/\a<=x<=b.
Notation "[ a , b ]" := (cc a b).

(* 半开半闭区间-左开右闭 *)
Definition oc (a b:R) := fun x:R => a<b/\a<x<=b.
Notation "( a , b ]" := (oc a b).

(* 半开半闭区间-左闭右开 *)
Definition co (a b:R) := fun x:R => a<b/\a<=x<b.
Notation "[ a , b )" := (co a b).

(* 函数在区间上一些基本性质的形式化描述 *)
(* 函数f在区间q上单调增 *)
Definition mon_increasing f (q:R_Ensemble) :=
  forall x y:R, x ∈ q /\ y ∈ q /\ y-x>0 -> f x <= f y.

(* 函数f在区间q上严格单调增 *)
Definition strict_mon_increasing f (q:R_Ensemble) :=
  forall x y:R, x ∈ q /\ y ∈ q /\ y-x>0 -> f x < f y.

(* 函数f在区间q上单调减 *)
Definition mon_decreasing f (q:R_Ensemble) :=
  forall x y:R, x ∈ q /\ y ∈ q /\ y-x>0 -> f x >= f y.

(* 函数f在区间q上严格单调减 *)
Definition strict_mon_decreasing f (q:R_Ensemble) :=
  forall x y:R, x ∈ q /\ y ∈ q /\ y-x>0 -> f x > f y.

(* 函数f在区间q上倒数无界 *)
Definition bounded_rec_f f (q:R_Ensemble) :=
  forall M:R, exists z:R, z ∈ q /\ M < Rabs(1/(f z)).

(* 函数f在区间q上正值单调不减 *)
Definition pos_inc f (q:R_Ensemble) :=
  (forall z:R, z ∈ q -> f z > 0) /\
  (forall z1 z2:R, z1 ∈ q -> z2 ∈ q -> z1<z2 -> f z1 <= f z2).

(* 函数f在区间q上正值单调不增 *)
Definition pos_dec f (q:R_Ensemble) :=
  (forall z:R, z ∈ q -> f z > 0) /\
  (forall z1 z2:R, z1 ∈ q -> z2 ∈ q -> z1<z2 -> f z2 >= f z1).

(* 一些组合函数、复合函数的形式化描述 *)

(* 设有函数f(x)，下面给出函数cf(x)的形式化描述 *)
Definition mult_real_f (c:R) f := fun x:R => (c * (f x)).

(* 设有函数f1(x)、f2(x)，下面给出函数f1(x)+f2(x)的形式化描述 *)
Definition plus_Fu f1 f2   := fun x:R => f1 x + f2 x.

(* 设有函数f(x)，实数c，下面给出函数f(cx)的形式化描述 *)
Definition Com_F_c (f:R->R) c x := f (c * x).

(* 设有函数f(x)，实数c、d，下面给出函数f(cx+d)的形式化描述 *)
Definition Com_F (f:R->R) (c d x:R) := f (c*x+d).

(* 排中律 *)
Axiom classic : forall P : Prop, P \/ ~P.

Theorem not_and_or : forall P Q : Prop, ~ (P /\ Q) -> ~ P \/ ~ Q.
Proof.
  intros.
  generalize(classic P); intro.
  generalize(classic Q); intro.
  destruct H0. destruct H1.
  assert(P/\Q). { split; auto. }
  contradiction.
  right; auto. left; auto.
Qed.


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

Module Insertion.
Section InsertionSort.

Variable T : eqType.
Variable leT : rel T.
Implicit Types x y z : T.
Implicit Types s t u : seq T.

(*| Insert an element `e` into a sorted list `s` |*)
Fixpoint insert e s : seq T :=
  if s is x :: s' then
    if leT e x then
      e :: s
    else
      x :: (insert e s')
  else [:: e].

(*| Sort input list `s` |*)
Fixpoint sort s : seq T :=
  if s is x :: s' then
    insert x (sort s')
  else
    [::].

(** * Exercise *)
Lemma sorted_cons x s :
  sorted leT (x :: s) -> sorted leT s.
Proof.
by move=> //= ; case: s=> //= e y /andP[].
Qed.

Hypothesis leT_total : total leT.
Lemma insert_sorted x s :
    sorted leT s ->
    sorted leT (insert x s).
Proof.
elim: s=> //= e s IHs.
case: ifP=> /= [->-> // | ].
move=> le_x_e_false path_e_s.
have:= leT_total x e.
rewrite le_x_e_false /=.
move=> le_e_x.
move: path_e_s=> {}/path_sorted/IHs.
case: s=> //= ; first by rewrite le_e_x.
Admitted.

(** * Exercise *)
Lemma sort_sorted s :
  sorted leT (sort s).
Proof.
elim: s=> //= x s IHs.
by rewrite insert_sorted.
Qed.

End InsertionSort.
End Insertion.

(** * Exercise: implement guarded interleave function *)

(* here is its unguarded version *)
Unset Guard Checking.
Fixpoint interleave_ns {T} (xs ys : seq T)
           {struct xs} : seq T :=
  if xs is (x :: xs')
  then x :: interleave_ns ys xs'
  else ys.
Set Guard Checking.

(** A simple unit test. *)
Check erefl : interleave_ns [:: 1; 3] [:: 2; 4] = [:: 1; 2; 3; 4].

Fixpoint interleave {T} (xs ys : seq T) : seq T :=
    match xs, ys with
    | [::], _ => ys
    | _, [::] => xs
    | x::xs', y::ys' => x :: y :: interleave xs' ys'
    end.
Check erefl : interleave [:: 1; 3] [:: 2; 4] = [:: 1; 2; 3; 4].

Lemma interleave_ns_eq_interleave {T} :
  (@interleave_ns T) =2 (@interleave T).
Proof. by elim=> // x xs IHs [] // y ys /= ; rewrite IHs.
Qed.

(** * Exercise: implement Ackermann's function

It's defined via the following expressions:

  A(0,   n)   = n + 1
  A(m+1, 0)   = A(m, 1)
  A(m+1, n+1) = A(m, A(m+1, n))
*)
Fixpoint acker m n :=
    let fix acker_m n :=
    match m, n with
    | O, _ => n + 1
    | S m', O => acker m' 1
    | S m', S n' => acker m' (acker_m n')
    end
    in acker_m n.
Check erefl : acker 0 0 = 1.
Check erefl : acker 0 1 = 2.
Check erefl : acker 1 0 = 2.
Check erefl : acker 1 1 = 3.
Check erefl : acker 3 2 = 29.
Check erefl : acker 4 0 = 13.

(** * Exercise: implement merge function via Program plugin *)
From Coq Require Import Program.
Program Fixpoint merge2 s t {measure (size s + size t)} : seq nat :=
    match s, t with
    | [::], _ => t
    | _, [::] => s
    | x :: s', y :: t' =>
        if (x <= y)%O
        then x :: merge2 s' t
        else y :: merge2 s t'
    end.
Next Obligation.
apply/ltP ; move=> //=; by rewrite ltn_add2l ltnSn.
Qed.
Compute merge2 [::] [::].
Compute merge2 [:: 1; 2; 3] [::].
Compute merge2 [:: 1; 2; 3] [:: 1; 2; 3].
Compute merge2 [::] [:: 1; 2; 3].
Compute merge2 [:: 1; 4; 6] [:: 1; 2; 3].