(* Chapter 12 Simple imperative programs *)

Require Export SfLib.

(* Arithmetic and boolean expressions *)

(* syntax *)
Module AExp.
  Inductive aexp : Type :=
    | ANum : nat -> aexp
    | APlus : aexp -> aexp -> aexp
    | AMinus : aexp -> aexp -> aexp
    | AMult : aexp -> aexp -> aexp.

  Inductive bexp : Type :=
    | BTrue : bexp
    | BFalse : bexp
    | BEq : aexp -> aexp -> bexp
    | BLe : aexp -> aexp -> bexp
    | BNot : bexp -> bexp
    | BAnd : bexp -> bexp -> bexp.

  Fixpoint aeval (a:aexp) : nat :=
    match a with
      | ANum n       => n
      | APlus a1 a2  => (aeval a1) + (aeval a2)
      | AMinus a1 a2 => (aeval a1) - (aeval a2)
      | AMult a1 a2  => (aeval a1) * (aeval a2)
    end.

  Example test_aeval1: aeval (APlus (ANum 2) (ANum 2)) = 4.
  Proof. reflexivity. Qed.

  Fixpoint beval (b:bexp) : bool :=
    match b with
      | BTrue      => true
      | BFalse     => false
      | BEq a1 a2  => beq_nat (aeval a1) (aeval a2)
      | BLe a1 a2  => ble_nat (aeval a1) (aeval a2)
      | BNot b1    => negb (beval b1)
      | BAnd b1 b2 => andb (beval b1) (beval b2)
    end.

  (* optimisation *)
  Fixpoint optimize_0plus (a:aexp) : aexp :=
    match a with
      | ANum n            => ANum n
      | APlus (ANum 0) e2 => optimize_0plus e2
      | APlus e1 e2       => APlus (optimize_0plus e1) (optimize_0plus e2)
      | AMinus e1 e2      => AMinus (optimize_0plus e1) (optimize_0plus e2)
      | AMult e1 e2       => AMult (optimize_0plus e1) (optimize_0plus e2)
    end.

  Example test_optimize_0plus:
    optimize_0plus (APlus (ANum 2)
                          (APlus (ANum 0)
                                 (APlus (ANum 0) (ANum 1)))) = APlus (ANum 2) (ANum 1).
  Proof. reflexivity. Qed.

  Theorem optimize_0plus_sound: forall a,
    aeval (optimize_0plus a) = aeval a.
  Proof.
    intros. induction a.
    Case "ANum". reflexivity.
    Case "APlus". destruct a1.
      SCase "ANum". destruct n.
        SSCase "0". simpl. apply IHa2.
        SSCase "S". simpl. rewrite IHa2. reflexivity.
      SCase "APlus". simpl in *. rewrite IHa1. rewrite IHa2. reflexivity.
      SCase "AMinus". simpl in *. rewrite IHa1. rewrite IHa2. reflexivity.
      SCase "AMult". simpl in *. rewrite IHa1. rewrite IHa2. reflexivity.
    Case "AMinus". simpl in *. rewrite IHa1. rewrite IHa2. reflexivity.
    Case "AMult". simpl in *. rewrite IHa1. rewrite IHa2. reflexivity.
  Qed.

  Theorem optimize_0plus_sound''': forall a,
    aeval (optimize_0plus a) = aeval a.
  Proof.
    intros.
    induction a.

    reflexivity.

    destruct a1.
    try (destruct n; simpl; rewrite IHa2; reflexivity).

    try (simpl in *; rewrite IHa1; rewrite IHa2; reflexivity).
    try (simpl in * ; rewrite IHa1 ; rewrite IHa2 ; reflexivity).
    try (simpl in * ; rewrite IHa1 ; rewrite IHa2 ; reflexivity).
    try (simpl in * ; rewrite IHa1 ; rewrite IHa2 ; reflexivity).
    try (simpl in * ; rewrite IHa1 ; rewrite IHa2 ; reflexivity).
Qed.

(* Coq automation *)

(* [repeat] tactical *)
Theorem ev100 : ev 100.
Proof.
  repeat (apply ev_SS). apply ev_0.
Qed.

Theorem ev100' : ev 100.
Proof.
  repeat (apply ev_0). (* does nothing *)
  repeat apply ev_SS. apply ev_0.
Qed.

(* need to watch out for tactics that always succeed in combination with repeat.
   coq's term language terminates, but the tactic language might not...
*)

(* [try] tactical *)
Theorem silly1 : forall ae, aeval ae = aeval ae.
Proof. try reflexivity. Qed.

Theorem silly2 : forall (P:Prop), P -> P.
Proof.
  intros.
  try reflexivity. (* plain [reflexivity] would fail here *)
  apply H.
Qed.

(* using [try] in a manual situation like above is silly, but [try] is handy
   when doing automated proofs in combination with [;] tactical
*)

(* [;] tactical (simple form) *)

(* T ; T'
   Perform tactic T then perform T' on each subgoal generated by T *)
Lemma foo : forall n, ble_nat 0 n = true.
Proof.
  intros. destruct n. simpl. reflexivity. simpl. reflexivity.
Qed.

Lemma foo' : forall n, ble_nat 0 n = true.
Proof.
  intros.
  destruct n;    (* destruct current goal *)
    simpl;       (* simpl each resulting subgoal *)
    reflexivity. (* refl on each of those subgoals *)
Qed.

(* Use try and ; together *)
Theorem optimize_0plus_sound' : forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros.
  induction a;
    try (simpl in *; rewrite IHa1; rewrite IHa2; reflexivity).
  Case "ANum". reflexivity.
  Case "APlus".
    destruct a1;
      try (simpl in *; rewrite IHa1; rewrite IHa2; reflexivity).
    SCase "ANum".
      destruct n; simpl; rewrite IHa2; reflexivity.
Qed.

Theorem optimize_0plus_sound'' : forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros.
  induction a;
    try reflexivity;
    try (simpl in *; rewrite IHa1; rewrite IHa2; reflexivity).
  (* why has coq changed the order of how things are treated?

     it's the [ T ; try T' ] idiom
     T' is attempted on all subgoals. if it succeeds, that subgoal is proven and
     so only the unsolved subgoals remain
  *)

  Case "APlus".
    destruct a1; try (simpl in *; rewrite IHa1; rewrite IHa2; reflexivity).
    SCase "ANum".
      destruct n; simpl; rewrite IHa2; reflexivity.
Qed.

(* [;] tactical (general form)

   T ; T' is shorthand for T ; [T' | T' | T' ... | T']

   T ; [T1 | T2 | T3 | ... | Tn] first performs T, then performs Ti on the ith
   subgoal generated by T
*)

(* Definining new tactic notations *)
Tactic Notation "simpl_and_try" tactic(c) := simpl ; try c.

(* Bulletproofing case analyses *)
Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ANum"
  | Case_aux c "APlus"
  | Case_aux c "AMinus"
  | Case_aux c "AMult"
  ].

Theorem optimize_0plus_sound'''': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros.
  aexp_cases (induction a) Case;
    try reflexivity;
    try (simpl in *; rewrite IHa1; rewrite IHa2; reflexivity).
    Case "APlus".
      aexp_cases (destruct a1) SCase;
        try (simpl in *; rewrite IHa1; rewrite IHa2; reflexivity).
        SCase "ANum".
          destruct n; simpl; rewrite IHa2; reflexivity.
Qed.

(* Exercise: *** *)
Fixpoint optimize_0plus_b (b:bexp) : bexp :=
  match b with
    | BTrue  => BTrue
    | BFalse => BFalse
    | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
    | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
    | BNot e => BNot (optimize_0plus_b e)
    | BAnd e1 e2 => BAnd (optimize_0plus_b e1) (optimize_0plus_b e2)
  end.

Tactic Notation "bexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "BTrue"
  | Case_aux c "BFalse"
  | Case_aux c "BEq"
  | Case_aux c "BLe"
  | Case_aux c "BNot"
  | Case_aux c "BAnd"
  ].

Theorem optimize_0plus_b_sound: forall b,
  beval (optimize_0plus_b b) = beval b.
Proof.
  intros.
  bexp_cases (induction b) Case;
    try reflexivity;
    try (simpl; rewrite IHb; reflexivity);
    try (simpl; rewrite IHb1, IHb2; reflexivity).
    Case "BEq".
      simpl. repeat rewrite optimize_0plus_sound''''. reflexivity.
    Case "BLe".
      simpl. repeat rewrite optimize_0plus_sound''''. reflexivity.
Qed. (* not very pretty, but meh *)

(* Exercise: **** *)
(* Design exercise: come up with a more sophisticated optimizer and
   prove it correct *)

(* the [omega] tactic *)
Example silly_presburger_ex: forall m n o p,
  m + n <= n + o /\ o + 3 = p + 3 ->
  m <= p.
Proof.
  intros. omega.
Qed.

(* a few more handy tactics *)

(* clear H: delete hypothesis H from the context *)
(* subst x: find assumption x = e or e = x in the context,
            replace x with e everywhere, clear assumption *)
(* subst: substitute all assumptions of the form x = e *)
(* rename H into J: rename hypothesis H to J in the context *)
(* assumption: look for a hypothesis in the context that
               matches the goal and apply it *)
(* contradiction: find H in the context that is logically
                  equivalent to False *)
(* constructor: try to find a constructor from an inductive
                definition that can solve the goal *)

(* Evaluation as a relation *)
  Reserved Notation "e '||' n" (at level 50, left associativity).

  Inductive aevalR : aexp -> nat -> Prop :=
    | E_ANum : forall (n:nat), (ANum n) || n
    | E_APlus : forall (e1 e2 : aexp) (n1 n2 : nat),
                  e1 || n1 ->
                  e2 || n2 ->
                  (APlus e1 e2) || (n1 + n2)
    | E_AMinus : forall (e1 e2 : aexp) (n1 n2 : nat),
                   e1 || n1 ->
                   e2 || n2 ->
                   (AMinus e1 e2) || (n1 - n2)
    | E_AMult : forall (e1 e2 : aexp) (n1 n2 : nat),
                  e1 || n1 ->
                  e2 || n2 ->
                  (AMult e1 e2) || (n1 * n2)
  where "e '||' n" := (aevalR e n) : type_scope.

  Tactic Notation "aevalR_cases" tactic(first) ident(c) :=
    first;
    [ Case_aux c "E_ANum"
    | Case_aux c "E_APlus"
    | Case_aux c "E_AMinus"
    | Case_aux c "E_AMult"
    ].

(* equivalence of the definitions *)
Theorem aeval_iff_aevalR : forall a n,
  (a || n) <-> aeval a = n.
Proof.
  split.
  Case "->".
    intro H. aevalR_cases (induction H) SCase; simpl.
    SCase "E_ANum". reflexivity.
    SCase "E_APlus". rewrite IHaevalR1, IHaevalR2. reflexivity.
    SCase "E_AMinus". rewrite IHaevalR1, IHaevalR2. reflexivity.
    SCase "E_AMult". rewrite IHaevalR1, IHaevalR2. reflexivity.
  Case "<-".
    generalize dependent n. aexp_cases (induction a) SCase; simpl.
    SCase "ANum".
      intros. subst. apply E_ANum.
    SCase "APlus". intros. subst. apply E_APlus. apply IHa1. reflexivity. apply IHa2. reflexivity.
    SCase "AMinus". intros. subst. apply E_AMinus. apply IHa1. reflexivity. apply IHa2. reflexivity.
    SCase "AMult". intros. subst. apply E_AMult. apply IHa1. reflexivity. apply IHa2. reflexivity.
Qed.

(* this time using more tacticals *)
Theorem aeval_iff_aevalR' : forall a n,
  (a || n) <-> aeval a = n.
Proof.
  split.
  Case "->".
    intros H.
    induction H; subst; reflexivity.
  Case "<-".
    generalize dependent n.
    induction a;
      simpl; intros; subst; constructor;
      try apply IHa1; try apply IHa2; reflexivity.
Qed.

(* Exercise: *** *)
Reserved Notation " e '|||' b " (at level 50, left associativity).

Inductive bevalR : bexp -> bool -> Prop :=
  | E_BTrue : BTrue ||| true
  | E_BFalse : BFalse ||| false
  | E_BEq : forall (a1 a2 : aexp) (n1 n2 : nat),
              a1 || n1 ->
              a2 || n2 ->
              BEq a1 a2 ||| beq_nat n1 n2
  | E_BLe : forall (a1 a2 : aexp) (n1 n2 : nat),
              a1 || n1 ->
              a2 || n2 ->
              BLe a1 a2 ||| ble_nat n1 n2
  | E_BNot : forall (e:bexp) (b:bool),
               e ||| b  ->
               BNot e ||| negb b
  | E_BAnd : forall (e1 e2 : bexp) (b1 b2:bool),
               e1 ||| b1 ->
               e2 ||| b2 ->
               BAnd e1 e2 ||| andb b1 b2
  where "e '|||' b" := (bevalR e b) : type_scope.

Tactic Notation "bevalR_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_BTrue"
  | Case_aux c "E_BFalse"
  | Case_aux c "E_BEq"
  | Case_aux c "E_BLe"
  | Case_aux c "E_BNot"
  | Case_aux c "E_BAnd"
  ].

Theorem beval_iff_bevalR: forall e b,
  (e ||| b) <-> beval e = b.
Proof.
  split.
  Case "->".
    intros.
    induction H; try simpl; try subst; try reflexivity; try assumption;
    (* repeat section for: BEq and BLe *)
    repeat (replace (aeval a1) with n1; replace (aeval a2) with n2; try reflexivity; try symmetry; apply aeval_iff_aevalR; assumption).

  Case "<-".
    (* was stuck on E_BNot case.
       induction is on e, but [b] depends on [beval e]
       had to [generalize dependent b] in order for it to work *)
    generalize dependent b.
    bevalR_cases (induction e) SCase; intros;
      rewrite <- H; constructor;
      try apply aeval_iff_aevalR; (* for E_BEq and E_BLe *)
      try apply IHe;              (* for E_BNot *)
      try apply IHe1;             (* for E_BAnd *)
      try apply IHe2;             (* for E_BAnd *)
      reflexivity.
Qed.

End AExp.

(* Computational vs. relational definitions *)
Module aevalR_division.
  Inductive aexp : Type :=
    | ANum   : nat -> aexp
    | APlus  : aexp -> aexp -> aexp
    | AMinus : aexp -> aexp -> aexp
    | AMult  : aexp -> aexp -> aexp
    | ADiv   : aexp -> aexp -> aexp.

  (* functional definition of aeval: how would it handle division by 0? *)

  (* Not a problem in the relational definition *)
  Inductive aevalR : aexp -> nat -> Prop :=
    | E_ANum   : forall n : nat,
                   (ANum n) || n
    | E_APlus  : forall (a1 a2 : aexp) (n1 n2 : nat),
                   a1 || n1 ->
                   a2 || n2 ->
                   (APlus a1 a2) || (n1 + n2)
    | E_AMinus : forall (a1 a2 : aexp) (n1 n2 : nat),
                   a1 || n1 ->
                   a2 || n2 ->
                   (AMinus a1 a2) || (n1 - n2)
    | E_AMult  : forall (a1 a2 : aexp) (n1 n2 : nat),
                   a1 || n1 ->
                   a2 || n2 ->
                   (AMult a1 a2) || (n1 * n2)
    | E_ADiv   : forall (a1 a2 : aexp) (n1 n2 n3 : nat),
                   a1 || n1 ->
                   a2 || n2 ->
                   (mult n2 n3 = n1) ->
                   (ADiv a1 a2) || n3
  where "a '||' n" := (aevalR a n) : type_scope.
End aevalR_division.

(* Adding nondeterminism *)
Module aevalR_extended.
  Inductive aexp : Type :=
    | AAny : aexp (* what number comes out here? *)
    | ANum : nat -> aexp
    | APlus : aexp -> aexp -> aexp
    | AMinus : aexp -> aexp -> aexp
    | AMult : aexp -> aexp -> aexp.
  (* again, how would the aeval function handle AAny? *)

  (* not a problem for the relation *)
  Inductive aevalR : aexp -> nat -> Prop :=
    | E_Any    : forall n : nat,
                   AAny || n
    | E_ANum   : forall n : nat,
                   (ANum n) || n
    | E_APlus  : forall (a1 a2 : aexp) (n1 n2 : nat),
                   a1 || n1 ->
                   a2 || n2 ->
                   (APlus a1 a2) || (n1 + n2)
    | E_AMinus : forall (a1 a2 : aexp) (n1 n2 : nat),
                   a1 || n1 ->
                   a2 || n2 ->
                   (AMinus a1 a2) || (n1 - n2)
    | E_AMult  : forall (a1 a2 : aexp) (n1 n2 : nat),
                   a1 || n1 ->
                   a2 || n2 ->
                   (AMult a1 a2) || (n1 * n2)
  where "a '||' n" := (aevalR a n) : type_scope.
End aevalR_extended.

(* Expressions with variables *)
Module Id.
  Inductive id : Type :=
    Id : nat -> id.

  Theorem eq_id_dec: forall i1 i2 : id,
    {i1 = i2} + {i1 <> i2}.
  Proof.
    intros.
    destruct i1 as [n]. destruct i2 as [m].
    destruct (eq_nat_dec n m) as [eq | neq].
    Case "=".
      left. rewrite eq. reflexivity.
    Case "<>".
      right. intro. inversion H. apply neq, H1.
  Defined.

Lemma eq_id: forall (T:Type) x (p q : T),
  (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x).
  Case "=". reflexivity.
  Case "<>". apply ex_falso_quodlibet. apply n. reflexivity.
Qed.

(* Exercise: * optional *)
Lemma neq_id: forall (T:Type) x y (p q : T),
  x <> y -> (if eq_id_dec x y then p else q) = q.
Proof.
  intros.
  destruct (eq_id_dec x y).
  Case "=". apply ex_falso_quodlibet, H, e.
  Case "<>". reflexivity.
Qed.

End Id.

(* State *)
Definition state := id -> nat.

Definition empty_state : state :=
  fun _ => 0.

Definition update (st:state) (x:id) (n:nat) : state :=
  fun x' => if eq_id_dec x x' then n else st x'.

(* Exercise: * *)
Theorem update_eq : forall n x st,
  (update st x n) x = n.
Proof.
  intros. unfold update.
  destruct (eq_id_dec x x); try apply ex_falso_quodlibet, n0; reflexivity.
Qed.

(* Exercise: * *)
Theorem update_neq : forall x2 x1 n st,
  x2 <> x1 ->
  (update st x2 n) x1 = (st x1).
Proof.
  intros. unfold update.
  destruct (eq_id_dec x2 x1). contradiction. reflexivity.
Qed.

(* Exercise: * *)
Theorem update_example: forall n:nat,
  (update empty_state (Id 2) n) (Id 3) = 0.
Proof.
  intros. unfold update. reflexivity.
Qed.

(* Exercise: * *)
Theorem update_shadow: forall n1 n2 x1 x2 (st:state),
  (update (update st x2 n1) x2 n2) x1 = (update st x2 n2) x1.
Proof.
  intros. unfold update. destruct (eq_id_dec x2 x1) eqn:H; reflexivity.
Qed.

(* Exercise: ** *)
Theorem update_same: forall n1 x1 x2 (st:state),
  st x1 = n1 ->
  (update st x1 n1) x2 = st x2.
Proof.
  intros. unfold update.
  destruct (eq_id_dec x1 x2) eqn:eq;
  subst; reflexivity.
Qed.

(* Exercise: *** *)
Theorem update_permute: forall n1 n2 x1 x2 x3 st,
  x2 <> x1 ->
  (update (update st x2 n1) x1 n2) x3 = (update (update st x1 n2) x2 n1) x3.
Proof.
  intros. unfold update.
  destruct (eq_id_dec x1 x3) eqn:x13. destruct (eq_id_dec x2 x3) eqn:x23.
  subst. contradiction H. reflexivity. reflexivity. reflexivity.
Qed.

(* Syntax *)
Inductive aexp : Type :=
| ANum : nat -> aexp
| AId : id -> aexp
| APlus : aexp -> aexp -> aexp
| AMinus : aexp -> aexp -> aexp
| AMult : aexp -> aexp -> aexp.

Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ANum"
  | Case_aux c "AId"
  | Case_aux c "APlus"
  | Case_aux c "AMinus"
  | Case_aux c "AMult"
  ].

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Tactic Notation "bexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "BTrue"
  | Case_aux c "BFalse"
  | Case_aux c "BEq"
  | Case_aux c "BLe"
  | Case_aux c "BNot"
  | Case_aux c "BAnd"
  ].

(* Evaluation *)
Fixpoint aeval (st:state) (a:aexp) : nat :=
  match a with
    | ANum n => n
    | AId x => st x
    | APlus a1 a2 => (aeval st a1) + (aeval st a2)
    | AMinus a1 a2 => (aeval st a1) - (aeval st a2)
    | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
    | BTrue      => true
    | BFalse     => false
    | BEq a1 a2  => beq_nat (aeval st a1) (aeval st a2)
    | BLe a1 a2  => ble_nat (aeval st a1) (aeval st a2)
    | BNot b1    => negb (beval st b1)
    | BAnd b1 b2 => andb (beval st b1) (beval st b2)
  end.

Example aexp1:
  aeval (update empty_state X 5)
        (APlus (ANum 3) (AMult (AId X) (ANum 2)))
  = 13.
Proof. reflexivity. Qed.

Example bexp1:
  beval (update empty_state X 5)
        (BAnd BTrue (BNot (BLe (AId X) (ANum 4))))
  = true.
Proof. reflexivity. Qed.

(* Commands *)

(*
   informally, our commands have the following BNF grammar

   c ::= SKIP
       | x ::= a
       | c ;; c
       | WHILE b DO c END
       | IFB b THEN c ELSE c FI
*)

(*
   factorial in Imp:

   Z ::= X;;
   Y ::= 1;;
   WHILE not (Z = 0) DO
     Y ::= Y * Z;;
     Z ::= Z - 1
   END
*)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP"
  | Case_aux c "::="
  | Case_aux c ";;"
  | Case_aux c "IFB"
  | Case_aux c "WHILE"
  ].

Notation "'SKIP'" := CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c 'THEN' a 'ELSE' b 'FI'" :=
  (CIf c a b) (at level 80, right associativity).

Definition fact_in_coq : com :=
  Z ::= AId X;;
  Y ::= ANum 1;;
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    Y ::= AMult (AId Y) (AId Z);;
    Z ::= AMinus (AId Z) (ANum 1)
  END.

(* Examples *)
Definition plus2 : com :=
  X ::= (APlus (AId X) (ANum 2)).

Definition XtimesYinZ : com :=
  Z ::= (AMult (AId X) (AId Y)).

Definition subtract_slowly_body : com :=
  Z ::= AMinus (AId Z) (ANum 1) ;;
  X ::= AMinus (AId X) (ANum 1).

(* loops *)
Definition subtract_slowly : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    subtract_slowly_body
  END.

Definition subtract_3_from_5_slowly : com :=
  X ::= ANum 3 ;;
  Z ::= ANum 5 ;;
  subtract_slowly.

(* infinite loop *)
Definition loop : com :=
  WHILE BTrue DO
    SKIP
  END.

(* Evaluation *)
Fixpoint ceval_fun_no_while (st:state) (c:com) : state :=
  match c with
    | SKIP => st
    | x ::= a1 => update st x (aeval st a1)
    | c1 ;; c2 => let st' := ceval_fun_no_while st c1
                  in  ceval_fun_no_while st' c2
    | IFB c THEN a ELSE b FI => if   (beval st c)
                                then ceval_fun_no_while st a
                                else ceval_fun_no_while st b
    | WHILE b DO c END => st (* bogus *)
  end.

(* Evaluation as a relation *)
Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st, SKIP / st || st
  | E_Ass : forall st a n x,
              aeval st a = n ->
              (x ::= a) / st || (update st x n)
  | E_Seq : forall c1 c2 st st' st'',
              c1 / st || st' ->
              c2 / st' || st'' ->
              (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' c a b,
                 beval st c = true ->
                 a / st || st' ->
                 (IFB c THEN a ELSE b FI) / st || st'
  | E_IfFalse : forall st st' c a b,
                  beval st c = false ->
                  b / st || st' ->
                  (IFB c THEN a ELSE b FI) / st || st'
  | E_WhileEnd : forall b st c,
                   beval st b = false ->
                   (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
                    beval st b = true ->
                    c / st || st' ->
                    (WHILE b DO c END) / st' || st'' ->
                    (WHILE b DO c END) / st || st''
  where "c '/' st '||' st'" := (ceval c st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip"
  | Case_aux c "E_Ass"
  | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue"
  | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd"
  | Case_aux c "E_WhileLoop"
  ].

Example ceval_example1:
  (X::=ANum 2 ;;
   IFB BLe (AId X) (ANum 1)
     THEN Y ::= ANum 3
     ELSE Z ::= ANum 4
   FI)
  / empty_state || (update (update empty_state X 2) Z 4).
Proof.
  apply E_Seq with (update empty_state X 2).
  Case "::=". apply E_Ass. reflexivity.
  Case "if".
    apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

(* Exercise: ** *)
Example ceval_example2:
  (X ::= ANum 0;;
   Y ::= ANum 1;;
   Z ::= ANum 2)
  / empty_state || (update (update (update empty_state X 0) Y 1) Z 2).
Proof.
  try apply E_Seq with (update empty_state X 0);
  try apply E_Seq with (update (update empty_state X 0) Y 1);
  apply E_Ass;
  reflexivity.
Qed.

(* Exercise: *** advanced *)
Definition pup_to_n : com :=
  (Y ::= ANum 0;;
   WHILE BNot (BEq (ANum 0) (AId X)) DO
     Y ::= APlus (AId Y) (AId X);;
     X ::= AMinus (AId X) (ANum 1)
   END).

Theorem pup_to_2_ceval:
  pup_to_n /
  (update empty_state X 2) ||
  update (update (update (update (update (update empty_state X 2) Y 0) Y 2) X 1) Y 3) X 0.
Proof.
  apply E_Seq with (update (update empty_state X 2) Y 0).
  (* Y 0 *) apply E_Ass. reflexivity.

  (* while conditional *)
  apply E_WhileLoop with (update (update (update (update empty_state X 2) Y 0) Y 2) X 1).
  reflexivity.
  (* while body *) apply E_Seq with (update (update (update empty_state X 2) Y 0) Y 2).
  (* Y = *) apply E_Ass. reflexivity.
  (* X = *) apply E_Ass. reflexivity.

  (* while conditional *)
  apply E_WhileLoop with (update (update (update (update (update (update empty_state X 2) Y 0) Y 2) X 1) Y 3) X 0). reflexivity.
  (* while body *) apply E_Seq with (update (update (update (update (update empty_state X 2) Y 0) Y 2) X 1) Y 3).
  (* Y ::= *) apply E_Ass. reflexivity.
  (* X ::= *) apply E_Ass. reflexivity.

  apply E_WhileEnd. reflexivity.
Qed.

Theorem ceval_deterministic: forall c st st1 st2,
  c / st || st1 ->
  c / st || st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2. generalize dependent st2. ceval_cases (induction E1) Case; intros st2 E2; inversion E2; subst.
  Case "E_Skip".
    reflexivity.
  Case "E_Ass".
    reflexivity.
  Case "E_Seq".
    assert (st' = st'0) as eq1.
    apply IHE1_1; assumption. subst. apply IHE1_2. assumption.
  Case "E_IfTrue".
    apply IHE1. assumption. rewrite H in H5. inversion H5.
  Case "E_IfFalse".
    rewrite H in H5. inversion H5. apply IHE1. assumption.
  Case "E_WhileEnd".
    reflexivity. rewrite H in H2. inversion H2.
  Case "E_WhileLoop".
    rewrite H in H4. inversion H4.
    assert (st' = st'0) as eq1. apply IHE1_1; assumption.
    subst st'0. apply IHE1_2. assumption.
Qed.

(* Reasoning about Imp programs *)
Theorem plus2_spec: forall st n st',
  st X = n ->
  plus2 / st || st' ->
  st' X = n + 2.
Proof.
  intros st n st' hx heval.
  inversion heval. subst. apply update_eq.
Qed.

(* Exercise: *** *)
(* prove a specification of XtimesYinZ *)
Theorem XtimesYinZ_spec: forall st n st',
  st X = n ->
  XtimesYinZ / st || st' ->
  st' X = n.
Proof.
  intros st n st' xn ev. generalize dependent n.
  induction ev; intros; try assumption.
  subst.
Admitted.

(* Exercise: *** *)
Theorem loop_never_stops: forall st st',
  ~ (loop / st || st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE BTrue DO SKIP END) as loopdef eqn:eqld.
  ceval_cases(induction contra) Case; inversion eqld.
  Case "E_WhileEnd". subst. inversion H.
  Case "E_WhileLoop". apply IHcontra2. subst. reflexivity.
Qed.

(* Exercise: *** *)
Fixpoint no_whiles (c:com) : bool :=
  match c with
    | SKIP => true
    | _ ::= _ => true
    | c1 ;; c2 => andb (no_whiles c1) (no_whiles c2)
    | IFB _ THEN a ELSE b FI => andb (no_whiles a) (no_whiles b)
    | WHILE _ DO _ END => false
  end.

Inductive no_whilesR: com -> Prop :=
  | n_skip : no_whilesR SKIP
  | n_asgn : forall x a, no_whilesR (x ::= a)
  | n_seq  : forall a b, no_whilesR a -> no_whilesR b -> no_whilesR (a ;; b)
  | n_if   : forall c a b, no_whilesR a -> no_whilesR b -> no_whilesR (IFB c THEN a ELSE b FI).

Theorem no_whiles_eqv: forall c,
  no_whiles c = true <-> no_whilesR c.
Proof.
  intro c. split.
  Case "->".
    induction c; intros; try constructor.
    SCase "::=".
      simpl in H.
      apply IHc1. apply andb_true_elim1 in H. assumption.
      apply IHc2. apply andb_true_elim2 in H. assumption.
    SCase "IF".
      simpl in H.
      apply IHc1. apply andb_true_elim1 in H. assumption.
      apply IHc2. apply andb_true_elim2 in H. assumption.
    SCase "WHILE".
      inversion H.

  Case "<-".
    induction c; intros; simpl; try rewrite IHc1, IHc2; try reflexivity;
    repeat (try inversion H; try assumption).
Qed.

(* Exercise: **** *)
(* state and prove a theorem that says 'if there are no while loops in an imp
   program, then it always terminates' *)

(* Additional exercises *)

(* Exercise: *** stack compiler *)
Inductive sinstr : Type :=
| SPush : nat -> sinstr
| SLoad : id -> sinstr
| SPlus : sinstr
| SMinus : sinstr
| SMult : sinstr.

Fixpoint s_execute (st:state) (stack:list nat) (prog:list sinstr) : list nat :=
  match prog with
    | nil => stack
    | ins :: inss => match ins, stack with
                       | SPush n, _              => s_execute st (n :: stack) inss
                       | SLoad i, _              => s_execute st (st i :: stack) inss
                       | SPlus, (a :: (b :: c))  => s_execute st ((a + b) :: c) inss
                       | SMinus, (a :: (b :: c)) => s_execute st ((b - a) :: c) inss
                       | SMult, (a :: (b :: c))  => s_execute st ((a * b) :: c) inss
                       | _, _                    => stack
                     end
  end.

Example s_execute1: s_execute empty_state []
  [SPush 5; SPush 3; SPush 1; SMinus] = [2;5].
Proof. reflexivity. Qed.

Example s_execute2: s_execute (update empty_state X 3) [3;4]
  [SPush 4; SLoad X; SMult; SPlus] = [15;4].
Proof. reflexivity. Qed.

Fixpoint s_compile (e:aexp) : list sinstr :=
  match e with
    | ANum n     => [SPush n]
    | AId i      => [SLoad i]
    | APlus n m  => s_compile n ++ s_compile m ++ [SPlus]
    | AMinus n m => s_compile n ++ s_compile m ++ [SMinus]
    | AMult n m  => s_compile n ++ s_compile m ++ [SMult]
  end.

Example s_compile1: s_compile
  (AMinus (AId X) (AMult (ANum 2) (AId Y))) = [SLoad X; SPush 2; SLoad Y; SMult; SMinus].
Proof. reflexivity. Qed.

(* Exercise: *** advanced *)
Theorem s_compile_correct: forall (st:state) (e:aexp),
  s_execute st [] (s_compile e) = [aeval st e].
Proof.
  intros.
  induction e; simpl; try reflexivity.
Admitted.

(* Exercise: ***** advanced *)
Module BreakImp.
  Inductive com : Type :=
    | CSkip : com
    | CBreak : com
    | CAss : id -> aexp -> com
    | CSeq : com -> com -> com
    | CIf  : bexp -> com -> com -> com
    | CWhile : bexp -> com -> com.

  Tactic Notation "com_cases" tactic(first) ident(c) :=
    first;
    [ Case_aux c "SKIP"
    | Case_aux c "BREAK"
    | Case_aux c "::="
    | Case_aux c ";"
    | Case_aux c "IFB"
    | Case_aux c "WHILE"
    ].

  Notation "'SKIP'"    := CSkip.
  Notation "'BREAK'"   := CBreak.
  Notation "x '::=' a" := (CAss x a) (at level 60).
  Notation "c1 ; c2"   := (CSeq c1 c2) (at level 80, right associativity).
  Notation "'WHILE' b 'DO' c 'END'" :=
    (CWhile b c) (at level 80, right associativity).
  Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
    (CIf c1 c2 c3) (at level 80, right associativity).

  (* BREAK should exit the inner most loop only, if it is called outside
     a loop, the program terminates.
  *)

  Inductive status : Type :=
    | SContinue : status
    | SBreak : status.

  Reserved Notation "c '/' st '||' s '/' st'" (at level 40, st, s at level 39).
End BreakImp.


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

Require Import Arith Setoid.

Set Implicit Arguments.

(*
Inductive bt :=
  | leaf : bt
  | node : bt -> bt -> bt.

Check bt_rect.
Check bt_ind.
*)

Section list.

  Variable X : Type.

  Implicit Type l : list X.

  Infix "::" := cons.
  Infix "++" := (@app _).
  Notation "⌊ l ⌋" := (length l) (at level 1, format "⌊ l ⌋").

  Print list.

  Print Implicit nil.
  Check nil.
  Check @nil _.

  Print app.

  Arguments app {A}.
  Check app.

  Arguments app [A].
  Check app.

  Print app.

  Fact app_nil_head l : nil++l = l.
  Proof. reflexivity. Qed.

  Fact app_cons_head x l m : (x::l) ++ m = x::(l++m).
  Proof. reflexivity. Qed.

  Fact app_assoc l m p : (l++m)++p = l++m++p.
  Proof.
    induction l as [ | x l IHl ].
    + simpl. trivial.
    + simpl.
      f_equal.
      trivial.
    (* induction l; simpl; f_equal; trivial. *)
  Qed.

  Fact app_nil_end l : l++nil = l.
  Proof.
  (*  induction l; simpl; f_equal; trivial. *)
    induction l as [ | x l IHl ].
    + simpl. trivial.
    + simpl.
      f_equal.
      trivial.
  Qed.

  Print length.

  Fact app_length l m : ⌊l++m⌋ = ⌊l⌋+⌊m⌋.
  Proof.
  (*  induction l; simpl; f_equal; trivial. *)
    induction l as [ | x l IHl ].
    + simpl.
      trivial.
    + simpl.
      f_equal.
      trivial.
  Qed.

  Section map.

    Variable (Y : Type) (f : X -> Y).

    Fixpoint map l :=
      match l with
        | nil  => nil
        | x::l => f x::map l
      end.

    Fact map_length l : ⌊map l⌋ = ⌊l⌋.
    Proof.
      induction l; simpl; f_equal; trivial.
    Qed.

    Fact map_app l m : map (l++m) = map l ++ map m.
    Proof.
      induction l; simpl; f_equal; trivial.
    Qed.

  End map.

  Check map.

  Fixpoint rev l :=
    match l with
      | nil  => nil
      | x::l => rev l ++ x :: nil
    end.

  Fixpoint rev_app a l :=
    match l with
      | nil  => a
      | x::l => rev_app (x::a) l
    end.

  Print rev_app.

  Fact rev_rev_app_eq a l : rev_app a l = rev l ++ a.
  Proof.
    revert a.
    induction l as [ | x l IHl ]; intros a; simpl.
    + trivial.
    + rewrite app_assoc; simpl.
      apply IHl.
  Qed.

  Fact rev_app_equiv l : rev_app nil l = rev l.
  Proof. rewrite rev_rev_app_eq, app_nil_end; trivial. Qed.

  Reserved Notation "x ∈ l" (at level 70, no associativity).

  Fixpoint In x l :=
    match l with
      | nil  => False
      | y::l => x = y \/ x ∈ l
    end
  where "x ∈ l" := (In x l).

  Fact in_app_iff x l m : x ∈ l++m <-> x ∈ l \/ x ∈ m.
  Proof.
(*    Print list.
    Check list_rect.
    Check list_ind. *)
    induction l as [ | y l IHl ]; simpl.
    + tauto.
    + rewrite IHl.
      tauto.
  (*  induction l as [ | ? ? IHl ]; simpl; [ | rewrite IHl ]; tauto. *)
  Qed.

(*
End list.

Eval compute in In 2 (2::3::4::nil). *)

  Definition incl l m := forall x, x ∈ l -> x ∈ m.

  Infix "⊆" := incl (at level 70, no associativity).

  Fact incl_refl l : l ⊆ l.
  Proof.
    unfold incl. auto.
  Qed.

  Fact incl_trans l m p : l ⊆ m -> m ⊆ p -> l ⊆ p.
  Proof.
    unfold incl.
  (*  intros H1 H2 x H3.
    apply H2, H1, H3. *)
    firstorder.
  Qed.

  Hint Resolve incl_refl : core.

  Fact incl_app_l l m : l ⊆ l++m.
  Proof.
(*    red.
    intros x Hx.
    apply in_app_iff.
    left; trivial. *)
    intro.
    Check in_app_iff. (* rewrite with <-> instead of = *)
    rewrite in_app_iff.
    tauto.
  Qed.

  Fact incl_app_r l m : m ⊆ l++m.
  Proof.
    intro; rewrite in_app_iff; tauto.
  Qed.

  Fact sg_incl x m : x::nil ⊆ m <-> x ∈ m.
  Proof.
    unfold incl; split.
    + intros H.
      apply H.
      simpl.
      auto.
    + intros H y; simpl.
      intros D.
      destruct D as [ E | A ].
      * rewrite E.
        trivial.
      * destruct A.
      (* intros ? ? [ -> | [] ]; trivial. *)
  Qed.

  Hint Resolve incl_app_l incl_app_r : core.

  Fact app_incl_left l r m : l++r ⊆ m <-> l ⊆ m /\ r ⊆ m.
  Proof.
    split.
    + intros H.
      split.
      * Check incl_trans.
     (*   apply incl_trans with (l++r). *)
        apply incl_trans with (2 := H).
        trivial.
      * apply incl_trans with (2 := H); trivial.
    + intros [ H1 H2 ] x.
      rewrite in_app_iff.
      intros [ H | H ]; revert H.
      * auto.
      * auto.
  Qed.

  Fact cons_incl_left x l m : x::l ⊆ m <-> x ∈ m /\ l ⊆ m.
  Proof.
    rewrite <- sg_incl, <- app_incl_left.
    simpl; tauto.
  Qed.

  Fact incl_cons_r x l : l ⊆ x::l.
  Proof.
    unfold incl; simpl; auto.
  Qed.

  Fact incl_nil_l l : nil ⊆ l.
  Proof.
    (* unfold incl.
    simpl. *)
    intros _ [].
  Qed.

  Hint Resolve incl_nil_l incl_cons_r : core.

  Fact incl_nil_r l : l ⊆ nil <-> l = nil.
  Proof.
    split.
    + unfold incl.
      simpl.
      intros H.
      destruct l as [ | x l ].
      * trivial.
      * destruct H with x.
        simpl; auto.
    + intros ->. (* equiv intros E; rewrite -> E *)
      auto. (* apply incl_refl. *)
  Qed.

  Fact incl_app_comm l m : l++m ⊆ m++l.
  Proof.
    intro.
    rewrite !in_app_iff.
    tauto.
  Qed.

  (* Alternative inductive definitions of In/∈ and incl/⊆ *)

  Reserved Notation "x ∈' y" (at level 70, no associativity).

  Inductive ind_In : X -> list X -> Prop :=
    | in_ind_In0 : forall x l, x ∈' x::l
    | in_ind_In1 : forall x y l, x ∈' l -> x ∈' y::l
  where "x ∈' l" := (ind_In x l).

  (**                         x ∈' l
          -------------   ---------------
            x ∈' x::l        x ∈' y::l     *)

  Fact ind_In_equiv x l : x ∈ l <-> x ∈' l.
  Proof.
    split.
    + induction l as [ | y l IHl ]; simpl.
      * intros [].
      * (* intros [ -> | ]; constructor; auto. *)
        intros [ E | H ].
        - rewrite E.
          constructor 1. (* apply in_ind_In0. *)
        - constructor 2.
          apply IHl, H.
    + intros H.
      induction H as [ x l | x y l H IH ].
      * simpl. auto.
      * simpl. auto.
  Qed.

  Reserved Notation "x ⊆' y" (at level 70, no associativity).

  Inductive ind_incl : list X -> list X -> Prop :=
    | in_ii0 : forall m, nil ⊆' m
    | in_ii1 : forall x l m, x ∈' m -> l ⊆' m -> x::l ⊆' m
  where "l ⊆' m" := (ind_incl l m).

  (**                             x ∈' m     l ⊆' m
            -------------      ------------------------
               nil ⊆' m                x::l ⊆' m    *)

  Fact ind_incl_equiv l m : l ⊆ m <-> l ⊆' m.
  Proof.
    split.
    + intros H.
      induction l as [ | x l IHl ].
      * constructor.
      * constructor.
        - apply ind_In_equiv.
          apply H.
          simpl; auto.
        - apply IHl.
          rewrite cons_incl_left in H.
          tauto.
    + intros H.
      induction H as [ m | x l m H1 H2 IH2 ].
      * auto.
      * rewrite cons_incl_left, ind_In_equiv.
        auto.
  Qed.

End list.


Set Warnings "-notation-overridden,-parsing".

From LF Require Export Induction.
From LF Require Export Poly.

(* The apply Tactic *)

Theorem silly1 : forall (n m o p : nat),
     n = m ->
     [n;o] = [n;p] ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  apply eq2.
Qed.

Theorem silly2 : forall (n m o p : nat),
     n = m ->
     (forall (q r : nat), q = r -> [q;o] = [r;p]) ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2.
  apply eq1.
Qed.

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     oddb 3 = true ->
     evenb 4 = true.
Proof.
intros cond res.
apply res.
Qed.

Theorem silly3_firsttry : forall (n : nat),
     true = (n =? 5) ->
     (S (S n)) =? 7 = true.
Proof.
  intros n H.
  symmetry.
  simpl.
  apply H.
Qed.

Theorem rev_exercise1 : forall(l l' : list nat),
  l = rev l' -> l' = rev l.
Proof.
intros l l' H.
rewrite -> H.
Search "rev".
symmetry.
apply rev_involutive.
Qed.

(* The apply with Tactic *)

Theorem trans_eq : forall (X:Type) (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2.
  rewrite -> eq1.
  rewrite -> eq2.
  reflexivity.
Qed.

Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
intros n m o p H H2.
rewrite H2.
apply H.
Qed.

(* The injection and discriminate Tactics *)

Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H1.
  assert (H2: n = pred (S n)). { reflexivity. }
  rewrite H2. rewrite H1. reflexivity.
Qed.

Theorem S_injective' :  forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H.
  injection H.
  intro.
  apply H0.
Qed.

Theorem injection_ex1 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros n m o H.
  injection H.
  intros Hmo Hno.
  rewrite Hmo.
  rewrite Hno.
  reflexivity.
Qed.

Theorem injection_ex2 : forall (n m : nat),
  [n] = [m] ->
  n = m.
Proof.
  intros n m H.
  injection H as Hnm. rewrite Hnm.
  reflexivity. Qed.

Example injection_ex3 : forall (X : Type) (x y z : X) (l j : list X),
  x :: y :: l = z :: j ->
  y :: l = x :: j ->
  x = y.
Proof.
  intros X x y z l j H1 H2.
  injection H2.
  intros H3 h4.
  rewrite h4.
  reflexivity.
Qed.

Theorem eqb_0_l : forall n,
   0 =? n = true -> n = 0.
Proof.
  intros n.
  destruct n as [| n'] eqn:E.
  - intros H. reflexivity.
  - simpl.
    intros contradiction.
    discriminate contradiction.
Qed.

Example discriminate_ex3 :
  forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    x = z.
Proof.
intros X x y z l H H1.
discriminate H1.
Qed.

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
  x = y -> f x = f y.
Proof. intros A B f x y eq. rewrite eq. reflexivity. Qed.

Theorem S_inj : forall (n m : nat) (b : bool),
     eqb (S n) (S m) = b  ->
     eqb n m = b.
Proof.
  intros n m b H. simpl in H. apply H.
Qed.

(* Using Tactics on Hypotheses *)

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
intros n.
induction n as [| n'].
- intros m H.
  simpl in H.
  destruct m.
  reflexivity.
  discriminate.
- Search "plus_n_Sm".
  intros m H. destruct m as [|m'].
    + discriminate H.
    + rewrite <- plus_n_Sm in H.
    rewrite <- plus_n_Sm in H.
    injection H.
    intro.
    apply IHn' in H0.
    rewrite -> H0.
    reflexivity.
Qed.

(* Varying the Induction Hypothesis *)

Theorem double_injective_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction n as [| n'].
  - (* n = O *) simpl. intros eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) discriminate eq.
  - (* n = S n' *) intros eq. destruct m as [| m'] eqn:E.
    + (* m = O *) discriminate eq.
    + (* m = S m' *) apply f_equal.
Abort.

Theorem double_injective: forall n m,
         double n = double m -> n = m.
Proof.
  intros n. induction n as [| n'].
  - simpl. intros m eq. destruct m as [| m'] eqn:E.
    + reflexivity.
    + discriminate eq.
  - intros m eq.
    destruct m as [| m'] eqn:E.
    + discriminate eq.
    + apply f_equal.
     apply IHn'.
     injection eq as goal.
     apply goal.
Qed.

Theorem eqb_true : forall n m,
    n =? m = true -> n = m.
Proof.
  intros n.
  induction n as [| n'].
  + intros m. destruct m as [| m'] eqn: E.
    - reflexivity.
    - intro. discriminate.
  + intros m eq.
    destruct m as [| m'] eqn: E.
    - discriminate.
    - apply IHn' in eq.
      rewrite eq.
      reflexivity.
Qed.

Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m.
  (* n and m are both in the context *)
  generalize dependent n.
  (* Now n is back in the goal and we can do induction on
     m and get a sufficiently general IH. *)
  induction m as [| m'].
  - (* m = O *) simpl. intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
    apply IHm'. injection eq as goal. apply goal.
Qed.

(* to be review *)
Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     nth_error l n = None.
Proof.
intros n X l.
  generalize dependent n.
 induction l as [| l'].
- reflexivity.
- intros n H.
    induction n as [| n'].
    + inversion H.
    + apply S_injective in H. apply IHl in H. apply H.
Qed.

(* Unfolding Definitions *)

Definition square n := n * n.

Lemma square_mult : forall n m, square (n * m) = square n * square m.
Proof.
  intros n m.
  simpl.
  unfold square.
    rewrite mult_assoc.
  assert (H : n * m * n = n * n * m).
    { rewrite mult_comm. apply mult_assoc. }
  rewrite H.
  rewrite mult_assoc.
  reflexivity.
Qed.

Definition foo (x: nat) := 5.

Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1.
Proof.
  intros m.
  simpl.
  reflexivity.
Qed.

Definition bar x :=
  match x with
  | O => 5
  | S _ => 5
  end.

Fact silly_fact_2_FAILED : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  simpl. (* Does nothing! *)
Abort.

Fact silly_fact_2' : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  unfold bar.
  destruct m  eqn:E.
  - simpl.
  reflexivity.
  - simpl.
    reflexivity.
Qed.

(* Using destruct on Compound Expressions *)

Definition sillyfun (n : nat) : bool :=
  if n =? 3 then false
  else if n =? 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
intros n.
unfold sillyfun.
destruct (n =? 3).
- reflexivity.
- destruct (n =? 5).
  + reflexivity.
  + reflexivity.
Qed.

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: t =>
      match split t with
      | (lx, ly) => (x :: lx, y :: ly)
      end
  end.

Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [| [x y] l'].

    intros l1 l2 eq. inversion eq. reflexivity.

    simpl. destruct (split l') as [l1' l2'].
    intros l1 l2 eq. inversion eq.
    simpl. apply f_equal. apply IHl'. reflexivity.  Qed.

Theorem combine_split' : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [| [x y] l'].
  - intros l1 l2 H.
    injection H.
    intros.
    rewrite <- H0.
    rewrite <- H1.
    reflexivity.
  - simpl.
    destruct (split l') as [x' y'] eqn: E.
    intros l1 l2 eq.
    injection eq.
    simpl.
    intros Hl2 Hl1.
    rewrite <- Hl1.
    rewrite <- Hl2.
    simpl; rewrite IHl'.
    + reflexivity.
    + reflexivity.
Qed.

Definition sillyfun1 (n : nat) : bool :=
  if n =? 3 then true
  else if n =? 5 then true
  else false.

Theorem sillyfun1_odd_FAILED : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n =? 3) eqn:Heqe3.
  apply eqb_true in Heqe3.
  rewrite -> Heqe3. reflexivity.
  destruct (n =? 5) eqn:Heqe5.
  apply eqb_true in Heqe5.
  rewrite -> Heqe5. reflexivity.
  discriminate eq.
Qed.

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
intros.
destruct (f b) eqn: HFB.
- destruct b eqn: HB.
  + rewrite HFB. apply HFB.
  + destruct (f true) eqn: HT.
    *  apply HT.
    * apply HFB.
- destruct b.
  + destruct (f false) eqn:HF.
    * apply HFB.
    * apply HF.
  + rewrite HFB; apply HFB.
Qed.

(* Additional Exercises *)
Theorem eqb_sym : forall (n m : nat),
  (n =? m) = (m =? n).
Proof.
intros n m.
destruct (m =? n) eqn: HNM.
apply eqb_true in HNM.
rewrite HNM.
Search "eqb_sym_informal".
symmetry.
apply eqb_nat_refl.
Abort.


Require Import CpdtTactics.

(** ** Source Language *)

Inductive binop : Set := Plus | Times.

Definition var := nat.

Inductive exp : Set :=
| Var : nat -> exp
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

Definition binopDenote (b : binop) : nat -> nat -> nat :=
  match b with
    | Plus => plus
    | Times => mult
  end.

Fixpoint expDenote (val : var -> nat) (e : exp) : nat :=
  match e with
    | Var v => val v
    | Const n => n
    | Binop b e1 e2 => (binopDenote b) (expDenote val e1) (expDenote val e2)
  end.

Definition val (n : nat) := n.

Eval simpl in expDenote val (Const 42).
(** [= 42 : nat] *)

Eval simpl in expDenote val (Binop Plus (Const 2) (Const 2)).
(** [= 4 : nat] *)

Eval simpl in expDenote val (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)).
(** [= 28 : nat] *)

Eval simpl in expDenote val (Binop Times (Binop Plus (Var 5) (Const 2)) (Const 7)).
(** [= 49 : nat] *)

Fixpoint cf (e : exp) : exp :=
  match e with
    | Binop b e1 e2 =>
        let e1' := cf e1 in
        let e2' := cf e2 in
        match e1', e2' with
        | Const c1, Const c2 => Const (binopDenote b c1 c2)
        | _, _ => Binop b e1' e2'
        end
    | e' => e'
  end.

Eval simpl in (cf (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7))).

Eval simpl in (cf (Binop Times (Binop Plus (Var 5) (Const 2)) (Const 7))).

Eval simpl in (cf (Binop Times (Binop Plus (Const 2) (Const 2)) (Var 7))).

Lemma cf_good : forall v e, expDenote v (cf e) = expDenote v e.
induction e; simpl.
+ trivial.
+ trivial.
+ destruct (cf e1); destruct (cf e2).
 crush.
(*
Hint Extern 1 (expDenote ?V (match ?E with Var _ => _ | Const _ => _ | Binop _ _ _ => _ end) = _) =>
 destruct E; crush.
induction e; crush.
*)

Qed.


(* (Deeply Embedded) Church Encoded Datatypes in Coq. *)

(** Our job for this lab: Demo church encoded datatypes using our
    formalization of the untyped lambda calculus.
    *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From Church Require Import LCNat.

(* Defining some helpful variable identifiers. *)
Definition c : string := "c".
Definition n : string := "n".
Definition l : string := "l".
Definition hd : string := "hd".
Definition tl : string := "tl".

(* Church Encodings: *)
(* We can actually encode booleans in the pure lambda calculus. We
   will define true and false as follows: *)

Definition true_church := <{\t, \f, t}>.
Definition false_church := <{\t, \f, f}>.

(* These terms encode booleans, in the sense that we can use these
   terms to mimic the behavior of conditionals in the pure lambda
   calculus. In particular, we can encode an if expression as follows:
   *)

Definition if_church := <{\x, \t, \f, x t f}>.
(* This term doesn't do much: it just applies the conditional to the
   two branches: if it is [true_church], it evaluates to the first
   expression, and [false_church] evaluates to the second. *)

Example if_true :
  <{if_church true_church (S tm_zero) tm_zero}> -->* <{S tm_zero}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

Example if_false :
  <{if_church false_church (S tm_zero) tm_zero}> -->* <{tm_zero}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* We can define boolean operations like and as well! *)
Definition and_church :=
  <{\x, \y, x y false_church}>.

Example if_and_false :
  <{if_church (and_church true_church false_church) (S tm_zero) tm_zero}> -->* <{tm_zero}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* We can encode pairs as terms using booleans: *)
Definition pair_church :=
  <{\f, \s, \x, x f s}>.

Definition fst_church :=
  <{\y, y true_church}>.

Definition snd_church :=
  <{\y, y false_church}>.

(* That is, [pair f s] is a function, that when applied to a boolean
   [x], applies [x] to [f] and [s]. By definition, this function
   returns [f] when [x] is [true_church] and [s] when [x] is
   [false_church]. The standard projection functions just supply the
   appropriate church-encoded boolean. *)

Example fst_pair :
  <{fst_church (pair_church (S tm_zero) tm_zero)}> -->* <{S tm_zero}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* Interestingly, we can encode numbers using a similar technique.
   The key difference is that we need to handle recursion more
   delicately.

   Informally, we can define church-encoded numbers as follows:

   C0 = \s, \z, z
   C1 = \s, \z, s z
   C2 = \s, \z, s (s z)
   C3 = \s, \z, s (s (s z))
 *)

(* That is, a number takes two functions: one for the successor case,
   and one for the zero case.  The key bit is that the function for
   what to do in the successor case takes an argument for the result
   of its predecessor. The 'number' simply recursively applies the
   successor function the appropriate number of times. *)

(* As examples, here are the church encoding of zero and three: *)

Definition zero_church :=
  <{\s, \z, z}>.

Definition three_church :=
  <{\s, \z, s (s (s z))}>.

(* To make it easier to read numbers, we can define a lambda
   expression that converts a church-encoded natural number to a
   representation using our calculi's built-in numbers.

   This conversion function takes a number and applies tm_succ for the
   recursive case, and tm_zero for the base case. *)
Definition toNat_church :=
  <{\n, n (\z, S z) tm_zero}>.

(* The chuch encoded numbers from above produce the expected primitive
   value. *)

Example zero_church_ex :
  <{toNat_church zero_church}> -->* <{tm_zero}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

Example three_church_ex :
  <{toNat_church three_church}> -->* <{S (S (S tm_zero)) }>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* We can define a generalized successor function, which takes a
   church number and yields another church number: *)
Definition succ_church :=
  <{\x, \s, \z, s (x s z)}>.

Definition one_church :=
  <{succ_church zero_church}>.

Definition two_church :=
  <{succ_church (succ_church zero_church)}>.

Example succ_church_ex_2 :
  <{toNat_church (succ_church zero_church)}> -->* <{S tm_zero }>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* We can also define addition on church encoded numerals: *)
Definition plus_church :=
  <{\x, \y, \s, \z, x s (y s z)}>.

Example plus_ex_1 :
  <{toNat_church (plus_church (succ_church zero_church) zero_church)}> -->* <{S tm_zero }>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* Testing if a number is zero is straightforward: *)
Definition is_zero_church :=
  <{\x, x (\y, false_church) true_church}>.
(* It returns true in the base (zero) case, and throws away the
   recursive result in the second case to simply return false.*)
Example is_zero_ex :
  <{is_zero_church (succ_church zero_church)}> -->* <{false_church}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* Finally, for good measure, here are the church encoding of nil and
   cons (for lists of natural numbers): *)

Definition nil_church :=
  <{\c, \n, n}>.

Definition cons_church :=
  <{\hd, \tl, \c, \n, c hd (tl c n)}>.

(* The list [1; 2]*)
Definition one_two_church :=
  <{cons_church one_church (cons_church two_church nil_church)}>.

(* IsNil for church-encoded lists:
   λl. l (λt f. t) (λt f. f)          *)

Definition isnil_church :=
  <{\l, l (\x, \y, false_church) true_church}>.

Example isnil_ex :
  <{ isnil_church nil_church }> -->* <{true_church}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

Example isnil_ex_2 :
  <{ isnil_church one_two_church }> -->* <{false_church}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* Length of a church-encoded list:
   λl. l (λhd n. λz s. s (n z s)) (λz. λs. z) *)

Definition length_church :=
  <{\l, l (\x, succ_church) zero_church }>.

Example length_ex :
  <{ toNat_church (length_church nil_church)}> -->* <{tm_zero}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

Example length_ex_2 :
  <{ toNat_church (length_church one_two_church)}> -->* <{S (S tm_zero)}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

Example length_ex_3 :
  <{ toNat_church (length_church (cons_church three_church one_two_church))}> -->* <{S (S (S tm_zero))}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* Summing the elements of a church-encoded list of numbers:
   λl. l (λz. λs. z) (λhd n. λz s. plus hd (n z s)) *)

Definition sum_church :=
  <{\l, l (\hd, \tl, plus_church hd tl) zero_church }>.

Example sum_ex :
  <{toNat_church (sum_church nil_church)}> -->* <{tm_zero}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

Example sum_ex_2 :
  <{ toNat_church (sum_church one_two_church)}> -->* <{S (S (S tm_zero))}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.

(* Surprisingly, the predecessor function is quite tricky to
   define. This is because Church encodings are destructive: they
   always "process" subdata by applying the recursive call. Thus, we
   can't access any of the recursive subdata of a constructor, only
   the 'result' of recursively processing that function. *)

Definition pred_church :=
  <{\x, fst_church (x (\y, pair_church (snd_church y)
                                       (succ_church (snd_church y)))
                      (pair_church zero_church zero_church)) }>.

(* The definition works by using [x] to apply [x] copies of a function
   that takes a pair [(c1, c2)] and produces a pair [(c2, 1 + c2)].
   applying this function x times to the pair [(0, 0)] results in the
   pair [(x - 1, x)]. Throwing away the second argument yields the
   predecessor of x.  *)

Example pred_ex :
  <{ toNat_church (pred_church three_church) }> -->* <{S (S tm_zero)}>.
Proof.
  normalize_lambda.
  apply multi_refl.
Qed.


Inductive Likes : Type := O | L : Likes -> Likes.

Fixpoint add x y :=
  match x with
  | O => y
  | L n => L (add n y)
  end.

Fixpoint mult x y :=
  match x with
  | O => O
  | L n => add y (mult n y)
  end.

Notation "x ⊕ y" := (add x y) (at level 50).
Notation "x ⊗ y" := (mult x y) (at level 40).

Fixpoint Σ N :=
  match N with
  | O => O
  | L n => N ⊕ (Σ n)
  end.

Lemma add_O_r x: x ⊕ O = x.
Proof.
  induction x.
  - reflexivity.
  - cbn. rewrite IHx. reflexivity.
Qed.

Lemma add_L_r x y : x ⊕ L y = (L x) ⊕ y.
Proof.
  induction x.
  - cbn. reflexivity.
  - cbn. rewrite IHx. reflexivity.
Qed.

Lemma add_comm x y : x ⊕ y = y ⊕ x.
Proof.
  induction x.
  - cbn. rewrite add_O_r. reflexivity.
  - cbn. rewrite IHx. rewrite add_L_r. reflexivity.
Qed.

Lemma add_asso x y z : (x ⊕ y) ⊕ z = x ⊕ (y ⊕ z).
Proof.
  induction x.
  - cbn. reflexivity.
  - cbn. rewrite IHx. reflexivity.
Qed.

Lemma mult_distr_l x y z : x ⊗ (y ⊕ z) = x ⊗ y ⊕ x ⊗ z.
Proof.
  induction x; cbn.
  - reflexivity.
  - rewrite IHx.
    rewrite <-add_asso, (add_asso y).
    rewrite (add_comm z).
    rewrite !add_asso.
    reflexivity.
Qed.

Lemma mult_O_r x : x ⊗ O = O.
Proof.
  induction x; cbn.
  - reflexivity.
  - apply IHx.
Qed.

Lemma mult_L_r x y : x ⊗ (L y) = x ⊕ x ⊗ y.
Proof.
  induction x; cbn.
  - reflexivity.
  - rewrite IHx.
    rewrite <- add_asso.
    rewrite (add_comm y x).
    rewrite add_asso.
    reflexivity.
Qed.

Lemma mult_comm x y : x ⊗ y = y ⊗ x.
Proof.
  induction x; cbn.
  - rewrite mult_O_r. reflexivity.
  - rewrite mult_L_r. rewrite IHx. reflexivity.
Qed.

Theorem Gauss_Sum N : (L (L O)) ⊗ Σ N = N ⊗ L N.
Proof.
  induction N.
  - cbn. reflexivity.
  - cbn [Σ].
    rewrite mult_distr_l.
    rewrite IHN.
    rewrite !(mult_comm _ (L N)).
    rewrite <- mult_distr_l.
    cbn [add].
    reflexivity.
Qed.


(**
Objectif de ce suppport de TD :
initiation aux relations ou prédicats définis inductivement,
pour préparer la définition des sémantiques relationnelles.
*)

(* Les exercices sont faciles, progressifs, et sont prévus
   pour une durée d'environ 1/2h).
*)

(* ------------------------------------------------------------ *)
(** * Relations ou prédicats définis inductivement *)

(** ** Prédicats à 1 argument sur un type énuméré  *)

(** Commençons par un prédicat très simple qui indique comment
    sélectionner quelques valeurs dans un type énuméré. *)

    Inductive coul : Set :=
    | violet : coul
    | indigo : coul
    | bleu : coul
    | vert : coul
    | jaune : coul
    | orange : coul
    | rouge : coul
    .

    (** Rappel : on ne peut PAS définir un autre type qui partage des
        constructeurs avec un type déjà défini. *)
    Fail Inductive coulfeu : Set :=
    | vert : coulfeu
    | orange : coulfeu
    | rouge : coulfeu
    .

    Definition ATTENTION_QUESTION_EN_COMMENTAIRE_1 : bool.
    (**
    Pourquoi interdire à un constructeur d'être dans des types inductifs différents ?
     *)
    (* Répondre ici
    Il pourait y avoir des problèmes lors des raisonnement inductifs
     *)
    Admitted.

    (** Mais on peut définir un prédicat sur coul qui est démontrable
        pour vert orange et rouge (et seulement pour ces derniers). *)

    Inductive estCoulfeu : coul -> Prop :=
    | Fver : estCoulfeu vert
    | Fora : estCoulfeu orange
    | Frou : estCoulfeu rouge
    .

    (** Par exemple on peut démontrer que vert satisfait ce prédicat. *)
    Example exemple_feu_vert : estCoulfeu vert.
    Proof.
      apply Fver.
    Qed.

    (** Certains feux de circulation ne présentent que les deux couleurs
        vert et rouge. *)

    Inductive feu2couls : coul -> Prop :=
    | F2ver : feu2couls vert
    | F2rou : feu2couls rouge
    .

    (** On veut démontrer que le second prédicat implique le premier. *)

    Lemma feu2couls_estCoulfeu : forall c, feu2couls c -> estCoulfeu c.
    Proof.
      intro c.
      (** On essaie d'abord un raisonnement par cas sur [c].*)
      destruct c.
      (** Beaucoup de cas inutiles (et qui requièrent une technique spéciale).
          Donc on essaye une meilleure stratégie. *)
      Undo 1.
      (** Introduction de l'hypothèse sur [c]. *)
      intro f2c.
      (** Il suffit de raisonner par cas sur les deux façons
          dont [f2c] peut être construite *)
      refine (match f2c with F2ver => _ | F2rou => _ end).
      clear.
      (** Même chose en utilisant la tactique destruct sur l'HYPOTHÈSE [f2c] *)
      Undo 2.
      destruct f2c as [ (*F2ver*) | (*F2rou*) ].
      - apply Fver.
      - refine Frou.
    Qed.

    (** Exercice *)

    (** Sur le modèle du prédicat estCoulfeu, définir un autre prédicat nommé boivr,
        qui sélectionne les couleurs bleu, orange, indigo, vert et rouge. *)

    (* Inductive boivr à compléter *)

    Inductive boivr : coul -> Prop :=
    | bBleu : boivr bleu
    | bOrange : boivr orange
    | bIndigo : boivr indigo
    | bVert  : boivr vert
    | bRouge : boivr rouge
    .

    (** Démontrer ensuite : *)

    Lemma estCoulfeu_boivr : forall c, estCoulfeu c -> boivr c.
    Proof.
      (** compléter *)
      intro c.
      intro ec.

      destruct ec as [ (*FVer*) | (*Fora*) | (*Frou*)].
      - apply bVert.
      - apply bOrange.
      - apply bRouge.
    Qed.

    (** ** Relations à 2 arguments sur un type énuméré *)

    (** Les relations inductives permettent de représenter des fonction partielles
        i.e., qui ne sont pas définies partout. Voici un exemple où coulsuiv
        est définie pour vert, orange et rouge, mais pas pour les autres couleurs
        prévues dans coul. *)

    Inductive coulsuiv : coul -> coul -> Prop :=
    | CSv : coulsuiv vert orange
    | CSo : coulsuiv orange rouge
    | CSr : coulsuiv rouge vert
    .

    (** Exercice (même technique qu'auparavant) *)

    Lemma coulsuiv_estCoulfeu : forall c1 c2, coulsuiv c1 c2 -> estCoulfeu c1.
    Proof.
      (** compléter *)
      intro c1.
      intro c2.
      intro cs.

      destruct cs as [ (*CSv*) | (*CSo*) | (*CSr*)].
      - apply Fver.
      - apply Fora.
      - apply Frou.
    Qed.

    (** ** Prédicat even sur nat *)

    (** De même que les types inductifs de données peuvent être récursifs,
        par exemple nat ou aexp, les prédicats inductifs peuvent être
        récursifs. C'est le cas de even, présenté au CM4. *)

    Inductive even : nat -> Prop :=
    | E0 : even 0
    | E2 : forall n, even n -> even (S (S n))
    .

    (** Exercice : démontrer que 6 est pair. *)

    Example ev10 : even 10.
    Proof.
      refine (E2 8 _).
      apply (E2 6).
      apply E2.
      apply E2.
      apply E2.
      apply E0.
    Qed.

    Print ev10.

    Definition ATTENTION_QUESTION_EN_COMMENTAIRE_2 : bool.
    (** Exercice :
        - quel est le type et la signification de E2 4 ?
        - quel est le type et la signification de E2 5 ?
    *)
    (* Répondre ici
    E2 4 : even 4
    E2 5 : even 5
     *)
    Admitted.

    (** Entiers atteignables en ajoutant des 2 ou des 7 en partant de 0. *)
    Inductive p2p7 : nat -> Prop :=
    | PP0 : p2p7 0
    | PP2 : forall n, p2p7 n -> p2p7 (2 + n)
    | PP7 : forall n, p2p7 n -> p2p7 (7 + n)
    .

    (** Exercice : démontrer de 3 façons que 11 est atteignable par p2p7. *)
    Example p2p7_11_methode1 : p2p7 11.
    Proof.
      apply PP7.
      apply PP2.
      apply PP2.
      apply PP0.
    Qed.

    Example p2p7_11_methode2 : p2p7 11.
    Proof.
      apply PP2.
      apply PP2.
      apply PP7.
      apply PP0.
    Qed.

    Example p2p7_11_methode23 : p2p7 11.
    Proof.
      refine (PP7 4 _).
      refine (PP2 2 _).
      refine (PP2 0 _).
      apply PP0.
    Qed.

    Print p2p7_11_methode2.

    (** Démontrer que tout entier pair satisfait p2p7. *)

    Theorem even_p2p7 : forall n, even n -> p2p7 n.
    Proof.
      intros n en.
      (** Comme il y a une infinité d'entiers pairs, une preuve par cas
          ne suffit pas. On procède par récurrence structurelle sur les
          façons de démontrer [even n], autrement les formes possibles
          d'arbres de preuve pour [en].
          On a deux cas, celui où [en] est [E0], et celui où [en]
          est de la forme [E2 n' en'], avec [en' : even n'] ;
          dans ce dernier cas, on a droit à une hypothèse de récurrence
          sur en', assurant que [n'] satisfait p2p7.
      *)
      induction en as [ (*E0*) | (*E2*) n' evn' Hrec_evn'].
      - apply PP0.
      - (** Facultatif : mise sous une forme clairement adaptée à p2p7 *)
        change (p2p7 (2 + n')).
        (** Utilisation du constructeur approprié de p2p7 *)
        apply PP2.
        (** Utilisation de l'hypothèse de récurrence *)
        apply Hrec_evn'.
    Qed.

    (** Il est instructif de démontrer le même théorème par une
        fonction récursive. *)

    Fixpoint fct_even_p2p7 n (en : even n) : p2p7 n :=
      match en with
      | E0 => PP0
      | E2 n' evn' => PP2 n' (fct_even_p2p7 n' evn')
      end.

    (** On peut transformer un arbre de preuve de [even 4]
        en un arbre de preuve de [p2p7 4] *)
    Compute fct_even_p2p7 4 (E2 2 (E2 0 E0)).

    (** La somme de deux entiers pairs est paire *)
    Lemma even_plus : forall n m, even n -> even m -> even (n + m).
    Proof.
      intros n m evn evm.
      induction evn as [ (*E0*) | (*E2*) n' evn' Hrec_evn'].
        - apply evm.
        - change (even (S (S (n' + m)))).
          apply E2.
          apply Hrec_evn'.
    Qed.

    (** Exercice facultatif :
        en donner une preuve sous forme de fonction. *)

    Fixpoint fct_even_plus n m (evn : even n) (evm : even m) : even (n + m).
      (** A compléter *)
    Admitted.

    (* Les multiples de 4 sont pairs *)
    Inductive mul4 : nat -> Prop :=
    | M4_0 : mul4 0
    | M4_4 : forall n, mul4 n -> mul4 (S (S (S (S n))))
    .

    Lemma mul4_even : forall n, mul4 n -> even n.
    Proof.
      intros n m4n.
      (** Terminer par récurrence structurelle sur [m4n] *)
    Admitted.


(**Pattern Matching**)
Inductive month:Set:= January|February|March|April|May|June|July|August|September|October|November|December.

Definition nbdays (m:month) :=
match m with
| April => 30
| June => 30
|September=> 30
|November=>30
|February=>28
| _ => 31
end.
Check nbdays.
Compute nbdays June.
Compute nbdays October.

Require Import Omega.
Require Import Arith.
Theorem monthcase: forall m: month, le 28 (nbdays m).
  intro. case ( m). simpl.  omega. simpl. omega. simpl. omega. simpl. omega. simpl. omega. simpl. omega. simpl. omega. simpl. omega. simpl. omega. simpl. omega. simpl. omega.  simpl. omega.
Qed. (*we could use some autoamation here**)
                                                                        (**Function that returns true in case a month is a winter month, false otherwise**)
Definition is_winter_month (m:month) :=
  match m with
|December => True
| January => True
|February => True
|_ => False
  end.
Compute is_winter_month July.
Compute is_winter_month February.
Inductive season:Set:= Winter|Spring|Summer|
                       Autumn.
Definition winter_season_month_match (s: season) (m:month) :=
  match s, m with
  | Winter, December => True
  | Winter, January => True
  | Winter, February => True
  |_ , _ => False
  end.

(**Pattern matching with recursive functions**)
Fixpoint plus (n m : nat) : nat :=
match n with
O => m
| S p => S (plus p m)
end.
Compute plus 4 8.

Fixpoint minus (n m : nat) : nat :=
match n, m with
S p, S q => minus p q
| _, _ => n
end.
Compute minus 11 9.
Definition e:= Set.
Inductive Gender:Set:= Fem|Masc|Neut.
Inductive Case:Set:= Nom|Acc.
Parameter he she it him her they I me we  you: e.
Definition  pronoun (g: Gender) (c:Case):=
  match g, c with
|Fem, Nom=> she
|Fem, Acc => her
|Masc, Nom=> he
|Masc, Acc=> him
|Neut, _=> it
  end.
Compute pronoun Neut Acc.

(** Some record examples. Defining Entity as a more structured type**)
Parameter human walk: e->Prop.
  Record Entity : Type := mkentity {x: e; z: human x}.
  Parameter John: Entity.
  Check walk (John.(x)).
  Theorem en: Entity-> exists x, human x.
    intro.      decompose record X. exists x0. assumption. Qed.
  Theorem WALK: walk (John.(x))-> exists x:e, walk x. intro. decompose record John. exists John.(x). assumption. Qed.

  Section SUB.
 Definition CN:=Set.
 Parameters Woman  Man Human Animal Object: CN. (**CNs as types**)
 Axiom wh: Woman  ->Human. Coercion wh: Woman >->Human.
 Axiom mh: Man ->Human. Coercion mh: Man >->Human.
  Axiom ha: Human -> Animal. Coercion ha: Human>->Animal.
  Axiom ao: Animal -> Object. Coercion ao: Animal >-> Object.

  Parameter drive: Human -> Prop.
  Parameter George  : Man.
  Parameter Mary: Woman.
  Check drive Mary.  (**work because of the subtyping**)
  Check and(drive George)(drive Mary).
  (** some reasoning **)
  Theorem MARY: drive Mary -> exists x: Woman, drive x.
  cbv.   intro. exists Mary. assumption. Qed.

Theorem MARY1:  drive Mary -> exists x: Human, drive x.
  cbv.   intro. exists Mary. assumption. Qed.  (**subtyping**)

(**Monotonicity on the first argument for free with subtyping**)
Theorem MONIN: exists x: Man, drive x -> exists x: Human, drive x.
exists George.  intro. exists George. assumption. Qed.
Theorem MONDEC: not (exists x: Human, drive x) -> not(exists x: Man, drive x).
cbv.   intros. apply H.   elim H0. intros. exists x0. assumption. Qed. (**bool in nat**)
Definition bool_in_nat (b:bool) := if b then 0 else 1.
Check bool_in_nat.
Coercion bool_in_nat : bool >-> nat.
Check (0 = true).
Set Printing Coercions.
Check (0 = true).

(**Co-induction**)
Set Implicit Arguments.
CoInductive LList (A:Set) : Set :=
LNil : LList A
| LCons : A -> LList A -> LList A.
Implicit Arguments LNil [A].
Print LList.
Require Import Streams.
Check Stream. Print Stream.

Check (LCons 1 (LCons 2 (LCons 3 LNil))).
Eval compute  in (LCons 1 (LCons 2 (LCons 3 LNil))).
(**Eval compute  in (Cons 1 (Cons 2 (Cons 3))).**) (**there is no Nil to provide the Stream nat argument**)
Definition next_month (m:month) :=
match m with
| January => February
| February => March
| March => April
| April => May
| May => June
| June => July
| July => August
| August => September
| September => October
| October => November
| November => December
| December => January
end.

Theorem next_august_then_july: forall m:month, next_month m = August -> m = July. intros m. case m. simpl. intros. discriminate H.  intros. discriminate H.  intros. discriminate H.  intros. discriminate H.  intros. discriminate H.  intros. discriminate H.  intros. reflexivity.   intros. discriminate H.  intros. discriminate H.  intros. discriminate H.  intros. discriminate H.  intros. discriminate H. Qed.

Lemma incorrect_equality_implies_anything: forall a, false = true -> a. intros. discriminate. Qed.


Inductive pFormula : Set :=
| Top  : pFormula
| Bot  : pFormula
| Conj : pFormula -> pFormula -> pFormula
.

Fixpoint pFormulaDenote (p:pFormula) : Prop :=
    match p with
    | Top           => True
    | Bot           => False
    | Conj p1 p2    => pFormulaDenote p1 /\ pFormulaDenote p2
    end.

(*  Def: An reflexive type is an inductive type which includes at
    least one constructor that takes as an argument a function
    returning the same type we are defining                        *)

Inductive Formula : Set :=
| Eq     : nat -> nat -> Formula
| And    : Formula -> Formula -> Formula
| Forall : (nat -> Formula) -> Formula     (* reflexive type ! *)
.

Definition forall_refl : Formula := Forall (fun x => Eq x x).

Fixpoint formulaDenote (p:Formula) : Prop :=
    match p with
    | Eq n m        => n = m
    | And p1 p2     => formulaDenote p1 /\ formulaDenote p2
    | Forall P      => forall (n:nat), formulaDenote (P n)
    end.

Fixpoint swapper (p:Formula) : Formula :=
    match p with
    | Eq n m        => Eq m n
    | And p1 p2     => And (swapper p2) (swapper p1)
    | Forall P      => Forall (fun n => swapper (P n))
    end.

Lemma swapper_preserves_truth : forall (p:Formula),
    formulaDenote p -> formulaDenote (swapper p).
Proof.
    induction p as [n m|p1 IH1 p2 IH2|P IH]; simpl.
    - intros. symmetry. assumption.
    - intros [H1 H2]. split.
        + apply IH2. assumption.
        + apply IH1. assumption.
    - intros H n. apply IH, H.
Qed.

(*
Check Formula_ind.
*)

(* Error: Non strictly positive occurrence of "Term"
Inductive Term : Set :=
| App : Term -> Term -> Term
| Lam : (Term -> Term) -> Term
.

If this definition was accepted by Coq, then we could define:

Definition uhoh (t:Term) : Term :=
    match t with
    | Abs f         => f t
    | _             => t
    end.

from which we would obtain:

uhoh (Abs uhoh) =
uhoh (Abs uhoh) = ...
*)


Require Import Frap.

(* Sum to and CPS *)
Fixpoint sum_to (n: nat): nat :=
  match n with
  | 0 => 0
  | S n' => n + sum_to n'
  end.

Theorem sum_to_thm : forall (n: nat),
  2 * sum_to n = n * (n+1).
Proof.
  induct n.
  + simplify; linear_arithmetic.
  + assert (2 * sum_to (S n) = 2 * (S n) + 2 * sum_to n) by (simplify; ring).
    rewrite H.
    rewrite IHn.
    clear H IHn.
    ring.
Qed.

Fixpoint sum_to_CPS (n: nat) (C: nat -> nat): nat :=
  match n with
  | 0 => C 0
  | S n' => sum_to_CPS n' (fun R => C (n + R))
  end.

Theorem CPS_correct: forall (n: nat) (f: nat -> nat),
  f (sum_to n) = sum_to_CPS n f.
Proof.
  induct n; simplify.
  + trivial.
  + apply IHn with (f := fun R: nat => f (S (n + R))).
Qed.

Theorem sum_to_thm2: forall (n: nat),
  2 * (sum_to_CPS n (fun R: nat => R)) = n * (n + 1).
Proof.
  simplify.
  pose CPS_correct.
  symmetry in e.
  rewrite e with (n := n) (f := fun R: nat => R).
  apply sum_to_thm.
Qed.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.lemma_NCorder.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_ABD_BCD.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_s_n_col_ncol.
Require Import ProofCheckingEuclid.lemma_s_ncol_n_col.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_s_ncol_ABD_col_ABC_ncol_ACD :
	forall A B D C,
	nCol A B D ->
	Col A B C ->
	neq A C ->
	nCol A C D.
Proof.
	intros A B D C.
	intros nCol_A_B_D.
	intros Col_A_B_C.
	intros neq_A_C.

	assert (~ Col A C D) as n_Col_A_C_D.
	{
		intros Col_A_C_D.

		pose proof (lemma_inequalitysymmetric _ _ neq_A_C) as neq_C_A.
		pose proof (lemma_collinearorder _ _ _ Col_A_B_C) as (_ & _ & Col_C_A_B & _ & _).
		pose proof (lemma_collinearorder _ _ _ Col_A_C_D) as (Col_C_A_D & _ & _ & _ & _).
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_C_A_B Col_C_A_D neq_C_A) as Col_A_B_D.

		contradict Col_A_B_D.
		pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_B_D) as n_Col_A_B_D.
		exact n_Col_A_B_D.
	}
	pose proof (lemma_s_n_col_ncol _ _ _ n_Col_A_C_D) as nCol_A_C_D.
	exact nCol_A_C_D.
Qed.

End Euclid.


Section Inf_List.
Require Import Arith.

CoInductive inf_list : Set :=
  | inf_cons : nat -> inf_list -> inf_list.

Definition head (l:inf_list) :=
  match l with
    | inf_cons n l' => n
  end.

Definition tail (l:inf_list) :=
  match l with
    | inf_cons n l' => l'
  end.

CoFixpoint ext (f : nat -> nat) (l : inf_list) : inf_list :=
  match l with
    | inf_cons n l' => inf_cons (f n) (ext f l')
  end.
(** Notice that this definition fits the pattern on page 9 of
    Jacobs:1997.  That is
        [head(ext f l) = f (head l)]
        [tail(ext f l) = ext f (tail l)].
    In fact the proof of this claim is trivial. *)
Lemma ext_fits_coind_pattern : forall f l,
  head (ext f l) = f (head l) /\
  tail (ext f l) = ext f (tail l).
Proof.
  auto.
  Restart.
  intros; destruct l; split; reflexivity.
Qed.
(** Our pattern above tells us that we can actually define
    [ext] interms of [head] and [tail]. *)
Reset ext.
CoFixpoint ext (f : nat -> nat) (l : inf_list) : inf_list :=
  inf_cons (f (head l)) (ext f (tail l)).

(** Next we define the definition of a co-inductive function called odd.
    It takes an infinite list and produces the infinite list containing
    the elements at odd positions in the input list *)
CoFixpoint odd (l : inf_list) : inf_list := inf_cons (head l) (tail (tail l)).
(** We can also define [even], but this is easy.  *)
Definition even (l: inf_list) : inf_list := odd (tail l).

(** The following co-inductive function merges two [inf_list]'s into a single
    [inf_list] in turn starting with the first. *)
CoFixpoint merge (l1 : inf_list) (l2 : inf_list) : inf_list :=
  inf_cons (head l1) (merge l2 (tail l1)).
(** This definition is equivalent to the following: *)
Reset merge.
CoFixpoint merge (l1 : inf_list) (l2 : inf_list) : inf_list :=
  inf_cons (head l1) (inf_cons (head l2) (merge (tail l1) (tail l2))).
(** Another example is to merge three [inf_list]'s in a round robin way. *)
CoFixpoint merge3 (l1 : inf_list) (l2 : inf_list) (l3 : inf_list) : inf_list :=
  inf_cons (head l1) (inf_cons (head l2) (inf_cons (head l3) (merge3 (tail l1) (tail l2) (tail l3)))).
(** The following is a more compact definition. *)
Reset merge3.
CoFixpoint merge3 (l1 : inf_list) (l2 : inf_list) (l3 : inf_list) : inf_list :=
  inf_cons (head l1) (merge3 l2 l3 (tail l1)).
(** Using this definition we can define the following merge function which takes two elements of the
   first [inf_list] for every one element in the second. This was proposed as an exercise in Jacobs:1997
   (page 10).  They give no indication of what order we choose the elements from the first list or
   weather or not they should repeat.  In the footnote they suggest using [merge3], but this results
   in repeats if we maintain the order of the first. Here is the first definition. *)
CoFixpoint merge_2_1 (l1 : inf_list) (l2 : inf_list) : inf_list := merge3 l1 (tail l1) l2.
Reset merge_2_1.
(** We can get around the repeats with this definition if we do not maintain the order of
    the first list. *)
CoFixpoint merge_2_1 (l1 : inf_list) (l2 : inf_list) : inf_list := merge3 l1 (tail (tail l1)) l2.
Reset merge_2_1.
(** The following definition maintains the order of the first list and does not repeat, but it does
    not have as elegant of a solution as the previous ones. *)
CoFixpoint merge_2_1 (l1 : inf_list) (l2 : inf_list) : inf_list :=
  inf_cons (head l1) (inf_cons (head (tail l1)) (inf_cons (head l2) (merge_2_1 (tail (tail l1)) (tail l2)))).
End Inf_List.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_equalanglesNC.
Require Import ProofCheckingEuclid.lemma_s_conga.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_equalanglessymmetric :
	forall A B C a b c,
	CongA A B C a b c ->
	CongA a b c A B C.
Proof.
	intros A B C a b c.
	intros CongA_ABC_abc.

	assert (CongA_ABC_abc2 := CongA_ABC_abc).
	destruct CongA_ABC_abc2 as (U & V & u & v & OnRay_BA_U & OnRay_BC_V & OnRay_ba_u & OnRay_bc_v & Cong_BU_bu & Cong_BV_bv & Cong_UV_uv & nCol_A_B_C).

	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_BU_bu) as Cong_bu_BU.
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_BV_bv) as Cong_bv_BV.
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_UV_uv) as Cong_uv_UV.

	pose proof (lemma_equalanglesNC _ _ _ _ _ _ CongA_ABC_abc) as nCol_a_b_c.

	pose proof (
		lemma_s_conga
		a b c A B C
		_ _ _ _
		OnRay_ba_u
		OnRay_bc_v
		OnRay_BA_U
		OnRay_BC_V
		Cong_bu_BU
		Cong_bv_BV
		Cong_uv_UV
		nCol_a_b_c
	) as CongA_abc_ABC.

	exact CongA_abc_ABC.
Qed.

End Euclid.


(* A generic one-time pad that can be reused in other proofs. Also included are specializations for bit vectors and finite cyclic groups. *)

Set Implicit Arguments.

Require Import FCF.

Definition D := evalDist.
Definition dist_iso := evalDist_iso.

Ltac r_ident_r :=
  symmetry;
  rewrite <- evalDist_right_ident;
  symmetry.

Ltac xorTac_once :=
  match goal with
    | [|- context[?x xor (?x xor ?x0)] ]=> rewrite <- BVxor_assoc; rewrite BVxor_same_id; rewrite BVxor_id_l
    | [|- context[(?x xor ?x0) xor ?x] ]=> rewrite <- BVxor_comm
  end.

Ltac xorTac := repeat xorTac_once;
              simpl; try reflexivity; try eapply in_getAllBvectors.

(*
(* Simple example used for illustration *)
Section OTP.
  Variable c : nat.
  Definition OTP (x : Bvector c) : Comp (Bvector c)
    := p <-$ {0, 1}^c; ret (BVxor c p x).

  Theorem OTP_eq_Rnd:
    forall (x y : Bvector c),
      D (OTP x) y == D ({0, 1}^c) y.

    intuition.
    unfold OTP.
    r_ident_r.
    eapply (dist_iso (BVxor c x) (BVxor c x));
      intuition; xorTac.
  Qed.

End OTP.
*)

(* The actual argument is more general (and more complex) *)
Section OTP.

  Variable T : Set.
  Hypothesis T_EqDec : EqDec T.
  Variable RndT : Comp T.
  Variable T_op : T -> T -> T.
  Hypothesis op_assoc : forall x y z, T_op (T_op x y) z = T_op x (T_op y z).
  Variable T_inverse : T -> T.
  Variable T_ident : T.
  Hypothesis inverse_l_ident : forall x, T_op (T_inverse x) x = T_ident.
  Hypothesis inverse_r_ident : forall x, T_op x (T_inverse x) = T_ident.
  Hypothesis ident_l : forall x, T_op T_ident x = x.
  Hypothesis ident_r : forall x, T_op x T_ident = x.
  Hypothesis RndT_uniform : forall x y, comp_spec (fun a b => a = x <-> b = y) RndT RndT.

  Theorem all_in_support :
    forall y, In y (getSupport RndT) ->
    forall x, In x (getSupport RndT).

    intuition.
    eapply getSupport_In_evalDist.
    intuition.
    eapply getSupport_In_evalDist.
    eapply H.
    rewrite <- H0.
    eapply comp_spec_impl_eq.
    trivial.

  Qed.

  Theorem OTP_inf_th_sec_l :
    forall (x : T),
      comp_spec eq RndT (r <-$ RndT; ret (T_op x r)).

    intros.

    eapply (@comp_spec_eq_trans_l _ _ _ _ RndT (x <-$ RndT; ret x)).
    eapply comp_spec_eq_symm.
    eapply comp_spec_right_ident.

    eapply comp_spec_seq.
    trivial.
    trivial.

    eapply comp_spec_symm.
    eapply (comp_spec_iso (T_op x) (T_op (T_inverse x))); intuition.
    rewrite <- op_assoc.
    rewrite inverse_r_ident.
    eauto.
    rewrite <- op_assoc.
    rewrite inverse_l_ident.
    eauto.

    eapply all_in_support; eauto.

    intuition.
    subst.
    eapply comp_spec_eq_refl.

  Qed.

  Theorem OTP_inf_th_sec_r :
    forall (x : T),
      comp_spec eq RndT (r <-$ RndT; ret (T_op r x)).

    intros.

    eapply (@comp_spec_eq_trans_l _ _ _ _ RndT (x <-$ RndT; ret x)).
    eapply comp_spec_eq_symm.
    eapply comp_spec_right_ident.

    eapply comp_spec_seq.
    trivial.
    trivial.

    eapply comp_spec_symm.
    eapply (comp_spec_iso (fun b => T_op b x) (fun b => T_op b (T_inverse x))); intuition.
    rewrite op_assoc.
    rewrite inverse_l_ident.
    eauto.
    rewrite op_assoc.
    rewrite inverse_r_ident.
    eauto.

    eapply all_in_support; eauto.

    intuition.
    subst.
    eapply comp_spec_eq_refl.

  Qed.

End OTP.

(* OTP for bitstrings with xor *)
Section xor_OTP.

  Variable n : nat.

  Theorem xor_OTP:
    forall (x : Bvector n),
      comp_spec eq (Rnd n) (r <-$ Rnd n; ret (BVxor n x r)).

    eapply OTP_inf_th_sec_l; intuition.
    eapply BVxor_assoc.
    eapply BVxor_same_id.
    eapply BVxor_same_id.
    eapply BVxor_id_l.

    eapply comp_spec_rnd.

  Qed.

  Theorem xor_OTP_eq:
    forall (x y : Bvector n),
       evalDist (r <-$ Rnd n; ret (BVxor n x r)) y ==
       evalDist (Rnd n) y.

    intuition.
    symmetry.
    eapply comp_spec_eq_impl_eq.
    eapply xor_OTP.

  Qed.

End xor_OTP.

(* OTP for cyclic groups *)
Require Import RndNat.
Require Import RndGrpElem.

Local Open Scope group_scope.

Section Group_OTP.

  Context`{FCG : FiniteCyclicGroup}.

  Hypothesis GroupElement_EqDec : EqDec GroupElement.

  Theorem group_OTP_l :
    forall (x : GroupElement),
      comp_spec eq (RndG) (r <-$ RndG; ret (groupOp x r)).

    eapply OTP_inf_th_sec_l; intuition.

    apply associativity.
    eapply left_inverse.
    eapply right_inverse.
    eapply left_identity.

    eapply RndGrpElem_spec.
  Qed.

  Theorem group_OTP_r :
    forall (x : GroupElement),
      comp_spec eq (RndG) (r <-$ RndG; ret (groupOp r x)).

    eapply OTP_inf_th_sec_r; intuition.

    apply associativity.
    eapply left_inverse.
    eapply right_inverse.
    eapply right_identity.
    eapply RndGrpElem_spec.
  Qed.

End Group_OTP.

Hint Resolve RndGrpElem_wf : wftac.


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.
From mathcomp.analysis Require Import sequences.

Open Scope ring_scope.

Module CustomSequences.
  (* This module was written before I knew about mathcomp-analysis,
       hence the [Definition Sequence]. *)

  Import GRing.Theory.

  Definition Sequence (K : fieldType) := nat -> K.
  Definition SequenceSum {K : fieldType} (s : Sequence K) (n : nat) := \sum_(0 <= i < n.+1) s i.

  Inductive GeometricSequence {K : fieldType} : Sequence K -> K -> Prop :=
  | geo_seq (s : Sequence K) (q : K) (H : forall (n : nat), s n * q = s n.+1) : GeometricSequence s q.

  Lemma sum_distrr {K : fieldType} (m n : nat) (s : Sequence K) (q : K) :
    q * (\sum_(m <= i < n) s i) = \sum_(m <= i < n) q * s i.
  Proof.
    by rewrite big_distrr.
  Qed.

  Lemma sum_extract_fst {K : fieldType} (s : Sequence K) (m n : nat) :
    (m <= n)%N -> \sum_(m <= i < n.+1) s i = s m + \sum_(m <= i < n) s i.+1.
  Proof.
    move => le_mn.
    by rewrite big_nat_recl.
  Qed.

  Lemma sum_extract_lst {K : fieldType} (s : Sequence K) (m n : nat) :
    (m <= n)%N -> \sum_(m <= i < n.+1) s i = \sum_(m <= i < n) s i + s n.
  Proof.
    move => le_mn.
    by rewrite big_nat_recr/=.
  Qed.

  Lemma geo_seq_n_term {K : fieldType} (s : Sequence K) (q : K) :
    GeometricSequence s q -> forall (n : nat), s n = s O * q ^+ n.
  Proof.
    move => geo_s.
    inversion geo_s.
    clear s0 q0 H0 H1.
    elim => [|n IHn].
    by rewrite mulrC mul1r.
    rewrite -H IHn.
    by rewrite -mulrA -exprSr.
  Qed.

  Lemma GeometricSequence_Sum {K : fieldType} (s : Sequence K) (q : K) :
    1 - q != 0 -> GeometricSequence s q -> forall n : nat, SequenceSum s n = s O * (1 - q ^+ n.+1) / (1 - q).
  Proof.
    move => neq_q1 geo_s n.
    inversion geo_s.
    clear s0 q0 H0 H1 geo_s.
    rewrite /SequenceSum.
    under eq_bigr => *.
    by rewrite (geo_seq_n_term s q)// over.
    rewrite -sum_distrr.
    set sum := (\sum_(_ <= i < _.+1) _).
    rewrite -(mulKf (F := K) (x := 1 - q) _ sum)//.
    have -> : (1 - q) * sum = 1 - q ^+ n.+1.
    {
      rewrite mulrBl.
      rewrite /sum {1}sum_extract_fst//
        sum_distrr sum_extract_lst//.
      under (eq_bigr (F1 := fun _ => _ * _)) do rewrite -exprS.
                                             by rewrite -exprS mul1r addrKA.
    }
    by rewrite (mulrC (_ ^-1)) mulrA.
  Qed.

End CustomSequences.


Require Import ssreflect ssrfun ssrbool.

(** specification *)

Module Type ProjectiveSpace.

  Parameter Point : Type.

  Parameter Line: Type.

  (* eventuellement FinType *)
  (* Check ([forall p1 : Point, forall p2:Point, p1==p2]). *)
  (* Search _ [exists _ : _,_]. *)
  (* Search _ pick. *)
  (* Check (forall p1 p2:Point, forall l:Line, ((a1_exists p1) p2)=l). *)
  Parameter eqP : Point -> Point -> bool.
  Parameter eqL : Line -> Line -> bool.

  Parameter incid_lp : Point -> Line -> bool.

  (* A1 : any two points lie on a unique Line *)

  Axiom a1_exists : forall A B : Point,
                          {l : Line| incid_lp A l && incid_lp B l}.

  Axiom uniqueness : forall (A B :Point)(l1 l2:Line),
      incid_lp A l1 -> incid_lp B l1  ->
      incid_lp A l2 -> incid_lp B l2 -> A = B \/ l1 = l2.

(* A2 : Pasch's axiom *)
  Definition dist_4p  (A B C D:Point) : bool :=
    (negb (eqP A B)) && (negb (eqP A C)) && (negb (eqP A D))
                     && (negb (eqP B C)) && (negb (eqP B D)) && (negb (eqP C D)).

  Axiom a2 : forall A B C D:Point, forall lAB lCD lAC lBD :Line,
  	dist_4p A B C D ->
	incid_lp A lAB && incid_lp B lAB ->
	incid_lp C lCD && incid_lp D lCD ->
	incid_lp A lAC && incid_lp C lAC ->
	incid_lp B lBD && incid_lp D lBD ->
	(exists I:Point, incid_lp I lAB && incid_lp I lCD) ->
        exists J:Point, incid_lp J lAC && incid_lp J lBD.

    (** A3 : dimension-related axioms *)
  Definition dist_3p  (A B C :Point) : bool := (negb (eqP A B)) && (negb (eqP A C)) && (negb (eqP B C)).

  Axiom a3_1 :
    forall l:Line,{A:Point & {B:Point & {C:Point |
                                         (dist_3p A B C) &&
                                         (incid_lp A l && incid_lp B l && incid_lp C l)}}}.

  (** there exists 2 lines which do not intersect *)
  Axiom a3_2 (* dim >= 3 *) :
    exists l1:Line, exists l2:Line,
      forall p:Point, ~(incid_lp p l1 && incid_lp p l2).

  Definition Intersect_In (l1 l2 :Line) (P:Point) := incid_lp P l1 && incid_lp P l2.

  Definition dist_3l (A B C :Line) : bool :=
    (negb (eqL A B)) && (negb (eqL A C)) && (negb (eqL B C)).

  Axiom a3_3 :  forall l1 l2 l3:Line,
      dist_3l l1 l2 l3 ->
      exists l4 :Line,  exists J1:Point, exists J2:Point, exists J3:Point,
	     Intersect_In l1 l4 J1 && Intersect_In l2 l4 J2 && Intersect_In l3 l4 J3.

End ProjectiveSpace.

(* Local Variables: *)
(* coq-prog-name: "/Users/magaud/.opam/4.06.0/bin/coqtop" *)
(* coq-load-path: ( ("." "Top") ) *)
(* suffixes: .v *)
(* End: *)


Require Import List Omega.
Import ListNotations.

Inductive bintree : Type :=
| leaf : bintree
| node : nat -> bintree -> bintree -> bintree.

Fixpoint lookup (n : nat) (t : bintree) : Prop :=
    match t with
    | leaf => False
    | node x l r => if eq_nat_dec x n
                    then True
                    else if le_lt_dec n x
                    then lookup n l
                    else lookup n r
    end.

Inductive valid : bintree -> Type :=
| val_leaf : valid leaf
| val_node : forall x l r, valid l -> valid r ->
                      (forall y, lookup y l -> y <= x)  ->
                      (forall y, lookup y r -> y > x) ->
                      valid (node x l r).

Fixpoint insert (x : nat) (t : bintree) : bintree :=
    match t with
    | leaf => node x leaf leaf
    | node y l r => if le_lt_dec x y
                    then node y (insert x l) r
                    else node y l (insert x r)
    end.

Fixpoint inorder (t : bintree) : list nat :=
    match t with
    | leaf => []
    | node x l r => inorder l ++ (x :: inorder r)
    end.

Fixpoint list_to_bin (xs : list nat) : bintree :=
    match xs with
    | [] => leaf
    | x :: xs' => insert x (list_to_bin xs')
    end.

Definition binsort (xs : list nat) : list nat := inorder (list_to_bin xs).

Example binsort_ex_01 : binsort [10;4;3;6;2;3;0;0;1] = [0;0;1;2;3;3;4;6;10].
Proof. reflexivity. Qed.

Inductive ordered : list nat -> Type :=
| o_nil  : ordered []
| o_sing : forall x, ordered [x]
| o_cons : forall x y xs, x <= y -> ordered (y :: xs) -> ordered (x :: y :: xs).

Lemma lookup_leaf_false (x : nat) : lookup x leaf -> False.
Proof.
  intros. inversion H.
Qed.

Lemma lookup_insert (t : bintree) (x y : nat) :
  lookup y (insert x t) -> y = x \/ lookup y t.
Proof.
  induction t; intros; simpl in *.
  - destruct (Nat.eq_dec x y).
    + left. symmetry. assumption.
    + right. destruct (le_lt_dec y x); assumption.
  - destruct (le_lt_dec x n); simpl in *; destruct (Nat.eq_dec n y);
        try (right; constructor); destruct (le_lt_dec y n).
    + apply (IHt1 H).
    + right. assumption.
    + right. assumption.
    + apply (IHt2 H).
  Qed.

Lemma insert_valid (x : nat) (t : bintree) : valid t -> valid (insert x t).
Proof.
  intros. generalize dependent x. induction t; intros; simpl in *.
  - constructor; intros; try constructor; contradiction (lookup_leaf_false y H0).
  - inversion H. subst. destruct (le_lt_dec x n).
    + apply (val_node _ _ _ (IHt1 H3 x) H4); intros.
      * destruct (lookup_insert t1 x y H0);
                [subst; assumption | apply (H5 _ H1)].
      * apply (H6 _ H0).
    + apply (val_node _ _ _ H3 (IHt2 H4 x) H5).
      intros. destruct (lookup_insert t2 x y H0).
      * subst. omega.
      * apply (H6 _ H1).
Qed.

Lemma list_to_bin_valid (xs : list nat) : valid (list_to_bin xs).
Proof.
    induction xs; simpl; [constructor |].
    apply (insert_valid _ _ IHxs).
Qed.

Lemma ordered_app (xs ys : list nat) (y : nat) :
  ordered xs -> ordered (y :: ys) -> (forall x, In x xs -> x <= y) ->
  ordered (xs ++ y :: ys).
Proof.
  induction xs; intros; simpl in *; [assumption |].
  inversion H; subst; simpl in *.
  - constructor.
    + apply H1. left. reflexivity.
    + assumption.
  - constructor.
    + assumption.
    + apply (IHxs H5 H0). intros. destruct H2; simpl in *.
      * subst. apply H1. right. left. reflexivity.
      * apply H1. right. right. assumption.
Qed.

Lemma ordered_cons (xs : list nat) :
  forall (x : nat), (forall z, In z xs -> x <= z) -> ordered xs -> ordered (x :: xs).
Proof.
  induction xs; intros; simpl in *; constructor.
  - apply H. left. reflexivity.
  - apply (IHxs a). intros.
    + inversion H0; subst. inversion H1.
      apply le_trans with (m := y). assumption.
      simpl in *. destruct H1.
      * omega.
      * more stuff

Lemma inorder_valid_ordered (t : bintree) : valid t -> ordered (inorder t).
Proof.
  intros H. induction H; [constructor |].
  simpl in *. apply (ordered_app _ _ _ IHvalid1).
  -

Theorem ordered_binsort (xs : list nat) : ordered (binsort xs).
Proof.
  unfold binsort. simpl. intros.
Theorem binsort_perm x (xs : list nat) : In x xs <-> In x (binsort xs).


Require Import Arith String.

(* This is a comment *)

Inductive exp : Set :=
  | Constant : nat -> exp
  | Plus : exp -> exp -> exp
  | Times : exp -> exp -> exp.

Fixpoint eval (e : exp) : nat :=
  match e with
    | Constant n => n
    | Plus e1 e2 => eval e1 + eval e2
    | Times e1 e2 => eval e1 + eval e2
  end.

Fixpoint commuter (e : exp) : exp :=
  match e with
   | Constant _ => e
   | Plus e1 e2 => Plus (commuter e2) (commuter e1)
   | Times e1 e2 => Times (commuter e2) (commuter e1)
  end.

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

Fixpoint add (n m : natural) : natural :=
  match n with
   | Zero => m
   | Succ n' => Succ (add n' m)
  end.

Theorem add_assoc : forall n m o,
  add (add n m) o = add n (add m o).
Proof.
  induction n.
  intros.
  simpl.
  reflexivity.

  intros.
  simpl.
  rewrite IHn.
  reflexivity.
Qed.

Lemma add_Zero : forall n,
  add n Zero = n.
Proof.
  induction n; simpl.
  reflexivity.

  rewrite IHn.
  reflexivity.
Qed.

Lemma add_Succ  : forall n m,
  add n (Succ m) = Succ (add n m).
Proof.
  induction n; simpl; intros.
  reflexivity.

  rewrite IHn.
  reflexivity.
Qed.

Theorem add_comm : forall n m,
  add n m = add m n.
Proof.
  induction n; intros; simpl.

  rewrite add_Zero.
  reflexivity.
  rewrite IHn.
  rewrite add_Succ.
  reflexivity.
Qed.

Theorem eval_commuter : forall e,
  eval (commuter e) = eval e.
Proof.
  induction e; simpl.
  reflexivity.
  rewrite IHe1, IHe2.
  ring.

  rewrite IHe1, IHe2.
  ring.
Qed.