Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rmult.
Require Export XR_Rmult_0_l.
Require Export XR_Rmult_0_r.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> R0 -> r1 <> R0 /\ r2 <> R0.
Proof.
  intros x y.
  intro heq.
  unfold not in heq.
  split.
  {
    unfold not.
    intro heqx.
    subst x.
    apply heq.
    rewrite Rmult_0_l.
    reflexivity.
  }
  {
    unfold not.
    intro heqy.
    subst y.
    apply heq.
    rewrite Rmult_0_r.
    reflexivity.
  }
Qed.


Require Import CSet Util MoreList Take MoreInversion LengthEq NaturalRep ARange.

Set Implicit Arguments.

Lemma x_notin_range V `{NaturalRepresentationSucc V} (x:V) k n
  : x ∉ of_list (range succ k n)
    -> asNat x < asNat k \/ asNat k+n <= asNat x.
Proof.
  general induction n; simpl in *.
  - decide (asNat x < asNat k); omega.
  - decide (asNat x = asNat k);
      cset_tac'.
    + exfalso. eapply asNat_inj in e; eauto.
    + eapply IHn in H4; eauto. destruct H4.
      * nr. omega.
      * nr. omega.
Qed.

Lemma x_in_range V `{NaturalRepresentationSucc V} (x:V) k n
  : asNat x >= asNat k /\ asNat k+n > asNat x -> x ∈ of_list (range succ k n).
Proof.
  revert x k.
  induction n; intros; simpl in *.
  - exfalso; omega.
  - decide (asNat x = asNat k); subst; cset_tac'.
    * rewrite <- asNat_iff in n0. exfalso; eauto.
    * rewrite asNat_iff in n0; eauto.
      eapply IHn; eauto. nr. omega.
Qed.

Lemma in_range_x  V `{NaturalRepresentationSucc V} x k n
  : x ∈ of_list (range succ k n) -> asNat x >= asNat k /\ asNat k+n > asNat x.
Proof.
  general induction n; simpl in *; dcr.
  - cset_tac.
  - decide (x === k); subst; try omega;
      cset_tac'; nr; try omega.
    eapply IHn in H3; nr; omega.
    eapply IHn in H3; nr; omega.
Qed.

Lemma take_range  V `{NaturalRepresentationSucc V} k (n:V) d
  : Take.take k (range succ n d) = range succ n (min k d).
Proof.
  general induction k; simpl; eauto.
  repeat cases; eauto.
  simpl in *. f_equal; eauto.
Qed.

Lemma range_nodup V `{NaturalRepresentationSucc V} i d
  : NoDupA _eq (range succ i d).
Proof.
  general induction d; simpl; eauto using NoDupA.
  econstructor; eauto.
  intro.
  rewrite InA_in in H2.
  eapply in_range_x in H2. nr. omega.
Qed.

Ltac range_get_simpl :=
  match goal with
  | [H : get (range _ ?k ?d) ?n ?x |- _ ] =>
    eapply range_get in H; try (is_var x; subst x)
  end.

Smpl Add range_get_simpl : inv_get.


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

(** Contributed by Laurent Théry (INRIA);
    Adapted to Coq V8 by the Coq Development Team *)

Require Import Arith.
Require Import Ascii.
Declare ML Module "string_syntax_plugin".

(** *** Definition of strings *)

(** Implementation of string as list of ascii characters *)

Inductive string : Set :=
  | EmptyString : string
  | String : ascii -> string -> string.

Delimit Scope string_scope with string.
Bind Scope string_scope with string.
Open Local Scope string_scope.

(** Equality is decidable *)

Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
 decide equality; apply ascii_dec.
Defined.

(** *** Concatenation of strings *)

Reserved Notation "x ++ y" (right associativity, at level 60).

Fixpoint append (s1 s2 : string) : string :=
  match s1 with
  | EmptyString => s2
  | String c s1' => String c (s1' ++ s2)
  end

where "s1 ++ s2" := (append s1 s2) : string_scope.

(******************************)
(** Length                    *)
(******************************)

Fixpoint length (s : string) : nat :=
  match s with
  | EmptyString => 0
  | String c s' => S (length s')
  end.

(******************************)
(** Nth character of a string *)
(******************************)

Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
  match s with
  | EmptyString => None
  | String c s' => match n with
                   | O => Some c
                   | S n' => get n' s'
                   end
  end.

(** Two lists that are identical through get are syntactically equal *)

Theorem get_correct :
  forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2.
Proof.
intros s1; elim s1; simpl in |- *.
intros s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros a s1' Rec s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros H; generalize (H 0); simpl in |- *; intros H1; inversion H1.
case (Rec s).
intros H0; rewrite H0; auto.
intros n; exact (H (S n)).
intros H; injection H; intros H1 H2 n; case n; auto.
rewrite H2; trivial.
rewrite H1; auto.
Qed.

(** The first elements of [s1 ++ s2] are the ones of [s1] *)

Theorem append_correct1 :
 forall (s1 s2 : string) (n : nat),
 n < length s1 -> get n s1 = get n (s1 ++ s2).
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2 n H; inversion H.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
intros n0 H; apply Rec; auto.
apply lt_S_n; auto.
Qed.

(** The last elements of [s1 ++ s2] are the ones of [s2] *)

Theorem append_correct2 :
 forall (s1 s2 : string) (n : nat),
 get n s2 = get (n + length s1) (s1 ++ s2).
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2 n; rewrite plus_comm; simpl in |- *; auto.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
generalize (Rec s2 0); simpl in |- *; auto. intros.
rewrite <- Plus.plus_Snm_nSm; auto.
Qed.

(** *** Substrings *)

(** [substring n m s] returns the substring of [s] that starts
    at position [n] and of length [m];
    if this does not make sense it returns [""] *)

Fixpoint substring (n m : nat) (s : string) : string :=
  match n, m, s with
  | 0, 0, _ => EmptyString
  | 0, S m', EmptyString => s
  | 0, S m', String c s' => String c (substring 0 m' s')
  | S n', _, EmptyString => s
  | S n', _, String c s' => substring n' m s'
  end.

(** The substring is included in the initial string *)

Theorem substring_correct1 :
 forall (s : string) (n m p : nat),
 p < m -> get p (substring n m s) = get (p + n) s.
Proof.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros p H; inversion H.
intros m' p; case p; simpl in |- *; auto.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Lt.lt_S_n; auto.
intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto.
Qed.

(** The substring has at most [m] elements *)

Theorem substring_correct2 :
 forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None.
Proof.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros m' p; case p; simpl in |- *; auto.
intros H; inversion H.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Le.le_S_n; auto.
Qed.

(** *** Test functions *)

(** Test if [s1] is a prefix of [s2] *)

Fixpoint prefix (s1 s2 : string) {struct s2} : bool :=
  match s1 with
  | EmptyString => true
  | String a s1' =>
      match s2 with
      | EmptyString => false
      | String b s2' =>
          match ascii_dec a b with
          | left _ => prefix s1' s2'
          | right _ => false
          end
      end
  end.

(** If [s1] is a prefix of [s2], it is the [substring] of length
    [length s1] starting at position [O] of [s2] *)

Theorem prefix_correct :
 forall s1 s2 : string,
 prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1.
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2; case s2; simpl in |- *; split; auto.
intros a s1' Rec s2; case s2; simpl in |- *; auto.
split; intros; discriminate.
intros b s2'; case (ascii_dec a b); simpl in |- *; auto.
intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto.
rewrite e; rewrite H1; auto.
apply H2; injection H3; auto.
intros n; split; intros; try discriminate.
case n; injection H; auto.
Qed.

(** Test if, starting at position [n], [s1] occurs in [s2]; if
    so it returns the position *)

Fixpoint index (n : nat) (s1 s2 : string) : option nat :=
  match s2, n with
  | EmptyString, 0 =>
      match s1 with
      | EmptyString => Some 0
      | String a s1' => None
      end
  | EmptyString, S n' => None
  | String b s2', 0 =>
      if prefix s1 s2 then Some 0
      else
        match index 0 s1 s2' with
        | Some n => Some (S n)
        | None => None
        end
   | String b s2', S n' =>
      match index n' s1 s2' with
      | Some n => Some (S n)
      | None => None
      end
  end.

(* Dirty trick to avoid locally that prefix reduces itself *)
Opaque prefix.

(** If the result of [index] is [Some m], [s1] in [s2] at position [m] *)

Theorem index_correct1 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some m -> substring m (length s1) s2 = s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1; auto.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
case H0; simpl in |- *; auto.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1; apply H; injection H1; intros H2; injection H2; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H1; apply H; injection H1; intros H2; injection H2; auto.
intros; discriminate.
Qed.

(** If the result of [index] is [Some m],
    [s1] does not occur in [s2] before [m] *)

Theorem index_correct2 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some m ->
 forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1.
intros p H0 H2; inversion H2.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
intros p H2 H3; inversion H3.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1 p; try case p; simpl in |- *; auto.
intros H2 H3; red in |- *; intros H4; case H0.
intros H5 H6; absurd (false = true); auto with bool.
intros n0 H2 H3; apply H; auto.
injection H1; intros H4; injection H4; auto.
apply Le.le_O_n.
apply Lt.lt_S_n; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H0 p; case p; simpl in |- *; auto.
intros H1; inversion H1; auto.
intros n0 H1 H2; apply H; auto.
injection H0; intros H3; injection H3; auto.
apply Le.le_S_n; auto.
apply Lt.lt_S_n; auto.
intros; discriminate.
Qed.

(** If the result of [index] is [None], [s1] does not occur in [s2]
    after [n] *)

Theorem index_correct3 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = None ->
 s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
case m; intros; red in |- *; intros; discriminate.
intros n' m; case m; auto.
intros s1; case s1; simpl in |- *; auto.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros; discriminate.
case m; simpl in |- *; auto with bool.
case s1; simpl in |- *; auto.
intros a s H H0 H1 H2; red in |- *; intros H3; case H.
intros H4 H5; absurd (false = true); auto with bool.
case s1; simpl in |- *; auto.
intros a s n0 H H0 H1 H2;
 change (substring n0 (length (String a s)) s2' <> String a s) in |- *;
 apply (Rec 0); auto.
generalize H0; case (index 0 (String a s) s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_O_n.
intros n'; case m; simpl in |- *; auto.
intros H H0 H1; inversion H1.
intros n0 H H0 H1; apply (Rec n'); auto.
generalize H; case (index n' s1 s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_S_n; auto.
Qed.

(* Back to normal for prefix *)
Transparent prefix.

(** If we are searching for the [Empty] string and the answer is no
    this means that [n] is greater than the size of [s] *)

Theorem index_correct4 :
 forall (n : nat) (s : string),
 index n EmptyString s = None -> length s < n.
Proof.
intros n s; generalize n; clear n; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros; discriminate.
intros; apply Lt.lt_O_Sn.
intros a s' H n; case n; simpl in |- *; auto.
intros; discriminate.
intros n'; generalize (H n'); case (index n' EmptyString s'); simpl in |- *;
 auto.
intros; discriminate.
intros H0 H1; apply Lt.lt_n_S; auto.
Qed.

(** Same as [index] but with no optional type, we return [0] when it
    does not occur *)

Definition findex n s1 s2 :=
  match index n s1 s2 with
  | Some n => n
  | None => 0
  end.

(** *** Concrete syntax *)

(**
  The concrete syntax for strings in scope string_scope follows the
  Coq convention for strings: all ascii characters of code less than
  128 are litteral to the exception of the character `double quote'
  which must be doubled.

  Strings that involve ascii characters of code >= 128 which are not
  part of a valid utf8 sequence of characters are not representable
  using the Coq string notation (use explicitly the String constructor
  with the ascii codes of the characters).
*)

Example HelloWorld := "	""Hello world!""
".


Require Import msl.msl_standard.
Require Import msl.Coqlib2.
Set Implicit Arguments.

Inductive fold_rel (A: Type) (f: A -> A -> A -> Prop):  A -> list A -> A -> Prop :=
| fold_rel_nil: forall w, fold_rel f w nil w
| fold_rel_cons: forall a l w w1 w2,
            f w a w1 ->
            fold_rel f w1 l w2 ->
            fold_rel f w (a::l) w2.

Inductive list_forall2 {A B} (P: A -> B -> Prop): list A -> list B -> Prop :=
  | list_forall2_nil:
      list_forall2 P nil nil
  | list_forall2_cons:
      forall a1 al b1 bl,
      P a1 b1 ->
      list_forall2 P al bl ->
      list_forall2 P (a1 :: al) (b1 :: bl).

Fixpoint replace (A: Type) (l: list A) (n:nat) (new: A) {struct n} : option (list A) :=
  match (l, n) with
    | (nil, n) => None
    | (x :: xs, O) => Some (new :: xs)
    | (x :: xs, S n) =>
      match (replace xs n new) with
        |  None => None
        |  Some xs => Some (x :: xs)
      end
  end.

Definition list_join {A} {JA: Join A}: A -> list A -> A -> Prop :=
   fold_rel join.

Lemma list_join_assoc1 {A} {JA: Join A}{PA: Perm_alg A}:
 forall {a b cl d e},
   join a b d -> list_join d cl e ->
  exists f, list_join b cl f /\ join a f e.
Proof.
intros.
revert a b H.
induction H0; intros.
exists b. split; auto. constructor.
destruct (join_assoc H1 H) as [ba [? ?]].
destruct (IHfold_rel _ _ H3) as [f [? ?]]; clear IHfold_rel.
exists f; split; auto.
econstructor; eauto.
Qed.

Lemma list_join_assoc2 {A}  {JA: Join A}{PA: Perm_alg A}:
  forall {a b: A} {cl e f},
   list_join b cl f -> join a f e ->
   exists d,  join a b d /\ list_join d cl e.
Proof.
do 3 intro; revert a b; induction cl; intros; inv H.
exists e; split; auto; constructor.
destruct (IHcl _ _ _ _ H6 H0) as [d [? ?]].
destruct (join_assoc (join_comm H4) (join_comm H)) as [g [? ?]].
exists g; split; auto.
constructor 2 with d; auto.
Qed.

Lemma list_join_app {A} {JA: Join A}:
  forall {a: A} {bl c dl e},
   list_join a bl c -> list_join c dl e -> list_join a (bl++dl) e.
Proof.
intros a bl; revert a; induction bl; intros.
inv H.
simpl.
auto.
inv H.
rewrite <- app_comm_cons.
econstructor 2.
apply H4.
eapply IHbl.
apply H6.
auto.
Qed.

Lemma list_join_unapp {A}  {JA: Join A}:
  forall {a:A}  {bl dl e},
  list_join a (bl++dl) e -> exists c, list_join a bl c /\ list_join c dl e.
Proof.
intros a bl; revert a; induction bl; intros.
simpl in H. exists a; split; auto. constructor.
rewrite <- app_comm_cons in H.
inv H.
destruct (IHbl _ _ _ H5) as [c [? ?]]. clear IHbl.
exists c.
split; auto.
econstructor 2; eauto.
Qed.

Lemma list_join_1 {A} {JA: Join A}:
  forall a b c: A, join a b c = list_join a (b::nil) c.
Proof.
intros; apply prop_ext; split; intros.
econstructor 2; eauto.
constructor.
inv H.
inv H5.
auto.
Qed.

Definition age1_list {A} `{ageable A} := list_forall2 age.

Lemma age1_list_join {A} {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall l (phi phi' phi2: A),
        age phi phi' ->
        list_join phi l phi2 ->
        exists l', exists phi2', age1_list l l' /\ age phi2 phi2' /\ list_join phi' l' phi2'.
Proof.
induction l; intros; inv H0.
exists (@nil A).
exists phi'.
repeat split; auto; constructor.
rename w1 into phi1.
destruct (age1_join _ H4 H) as [a' [phi1' [? [? ?]]]].
spec IHl phi1 phi1' phi2 H2 H6.
destruct IHl as [l' [phi2' [? [? ?]]]].
exists (a' :: l').
exists phi2'.
repeat split; auto; econstructor 2; eauto.
Qed.

Lemma age1_list_join2 {A} {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall (l: list A) phi phi2 phi2',  age1 phi2 = Some phi2' -> list_join phi l phi2 ->
        exists l', exists phi',  age1 phi = Some phi' /\ age1_list l l' /\ list_join phi' l' phi2'.
Proof.
induction l; intros; inv H0.
exists (@nil A).
exists phi2'.
repeat split; auto; constructor.
rename w1 into phi1.
destruct (IHl phi1 phi2 phi2' H H6) as [l' [phi1' [? [? ?]]]].
destruct (age1_join2 _ H4 H0) as [phi' [a' [? [? ?]]]].
exists (a'::l'). exists phi'.
repeat split; auto; econstructor 2; eauto.
Qed.

Lemma list_join_split_nth {A}{JA: Join A}{PA: Perm_alg A}:
 forall n (l: list A) phin phi phia phib phi2,
  nth_error l n = Some phin -> list_join phi l phi2 -> join phib phia phin ->
           exists phic, exists l',
                 replace l n phib = Some l' /\ join phi phia phic /\ list_join phic l' phi2.
Proof.
induction n; intros.
inv H.
destruct l.
discriminate.
inv H3.
inv H0.
simpl.
destruct (join_assoc H1 (join_comm H4))
      as [f [? ?]].
exists f; exists (phib::l).
repeat split; auto.
econstructor 2; eauto.
simpl in H.
destruct l.
inv H.
inv H0.
destruct (IHn _ _ _ _ _ _ H H7 H1) as [phic [l' [? [? ?]]]].
simpl. rewrite H0.
destruct (join_assoc (join_comm H5) H2) as [f [? ?]].
exists f; exists (a::l'); repeat split; auto.
econstructor 2; eauto.
Qed.

Lemma list_join_join_nth {A} {JA: Join A}{PA: Perm_alg A}:
 forall n (l: list A) phin phi phia phib phi2,
  nth_error l n = Some phin -> list_join phi l phi2 -> join phi2 phia phib ->
           exists phic, exists l',
                 join phin phia phic /\ replace l n phic = Some l' /\ list_join phi l' phib.
Proof.
induction n; intros.
inv H.
destruct l; try discriminate.
inv H0.
inv H3.
simpl.
destruct (list_join_assoc2 H7 (join_comm H1)) as [f [? ?]].
destruct (join_assoc H5 (join_comm H)) as [g [? ?]].
exists g; exists (g::l); repeat split; auto.
econstructor 2; eauto.
destruct l; simpl in H.
inv H.
inv H0.
simpl.
destruct (IHn _ _ _ _ _ _ H H7 H1) as [phic  [l' [? [? ?]]]].
exists phic. rewrite H2. exists (a::l').
repeat split; auto.
econstructor 2; eauto.
Qed.

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

Lemma list_join_comparable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall (phi1: A) l phi2, list_join phi1 l phi2 -> comparable phi1 phi2.
Proof.
  intros; revert phi1 phi2 H; induction l; simpl; intros; inv H.
  apply comparable_refl.
  rename w1 into phi0.
  apply comparable_trans with phi0.
  apply join_comparable with a; auto.
  auto.
Qed.

Lemma join_comparable'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi2 phi3.
Proof. intros; apply join_comparable with phi1; apply join_comm; auto. Qed.

Lemma join_comparable2'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi2 phi1.
Proof. intros; apply comparable_sym; eapply join_comparable2; eauto. Qed.

Lemma list_join_comparable'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall (phi1: A) l phi2, list_join phi1 l phi2 -> comparable phi2 phi1.
Proof. intros; apply comparable_sym; eapply list_join_comparable; eauto. Qed.

Lemma join_comparable''  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi3 phi2.
Proof. intros; apply comparable_sym; eapply join_comparable'; eauto. Qed.

Lemma join_comparable'''  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi3 phi1.
Proof. intros; apply comparable_sym; eapply join_comparable; eauto. Qed.

Lemma joins_comparable  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2: A, joins phi1 phi2 -> comparable phi1 phi2.
Proof.
  unfold joins; intros.
  destruct H as [phi3 ?].
  eapply join_comparable2; eauto.
Qed.

Lemma joins_comparable2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
     forall phi1 phi2: A, joins phi2 phi1 -> comparable phi1 phi2.
Proof.
unfold joins; intros.
destruct H as [phi3 ?].
apply comparable_sym.
eapply join_comparable2; eauto.
Qed.

Lemma join_sub_comparable  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2: A, join_sub phi1 phi2 -> comparable phi1 phi2.
Proof.
unfold joins; intros.
destruct H as [phi3 ?].
eapply join_comparable; eauto.
Qed.

Lemma join_sub_comparable2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
     forall phi1 phi2: A, join_sub phi2 phi1 -> comparable phi1 phi2.
Proof.
unfold joins; intros.
destruct H as [phi3 ?].
apply comparable_sym.
eapply join_comparable; eauto.
Qed.

Lemma eq_comparable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
   forall phi1 phi2: A, phi1=phi2 -> comparable phi1 phi2.
Proof.
intros; subst; apply comparable_refl.
Qed.

Lemma eq_comparable2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
   forall phi1 phi2: A, phi2=phi1 -> comparable phi1 phi2.
Proof.
intros; subst; apply comparable_refl.
Qed.

Lemma ageN_join {A}  {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (w1 w2 w3 w1': A),
   join w1 w2 w3 ->
      ageN n w1 = Some w1' ->
      exists w2', exists w3',
        ageN n w2 = Some w2' /\ ageN n w3 = Some w3' /\ join w1' w2' w3'.
Proof.
unfold ageN in *.
induction n; intros; simpl in *.
exists w2; exists w3; repeat split; auto.
inv H0; auto.
case_eq (age1 w1); intros; rewrite H1 in H0; try discriminate.
destruct (age1_join _ H H1) as [w2' [w3' [? [? ?]]]].
destruct (IHn _ _ _ _ H2 H0) as [w2'' [w3'' [? [? ?]]]].
clear IHn.
exists w2''; exists w3''. rewrite H3; rewrite H4.
repeat split; auto.
Qed.

Lemma ageN_join2 {A}  {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (w1 w2 w3 w3': A),
   join w1 w2 w3 ->
      ageN n w3 = Some w3' ->
      exists w1', exists w2',
        ageN n w1 = Some w1' /\ ageN n w2 = Some w2' /\ join w1' w2' w3'.
Proof.
unfold ageN in *.
induction n; intros; simpl in *.
exists w1; exists w2; repeat split; auto.
inv H0; auto.
case_eq (age1 w3); intros; rewrite H1 in H0; try discriminate.
destruct (age1_join2 _ H H1) as [w1' [w2' [? [? ?]]]].
destruct (IHn _ _ _ _ H2 H0) as [w1'' [w2'' [? [? ?]]]].
clear IHn.
exists w1''; exists w2''. rewrite H3; rewrite H4.
repeat split; auto.
Qed.

Lemma ageN_comparable {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (w1 w2 w1' w2': A),
        ageN n w1 = Some w1' -> ageN n w2 = Some w2' -> comparable w1 w2 -> comparable w1' w2'.
Proof.
unfold ageN in *.
induction n; intros; simpl in *.
inv H; inv H0; auto.
revert H H0; case_eq (age1 w1); case_eq (age1 w2); intros; try discriminate.
eapply IHn; eauto.
eapply age_comparable; eauto.
Qed.

Lemma join_unage  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall (phi3 phi1' phi2' phi3': A),
    age1 phi3 = Some phi3' ->
    join phi1' phi2' phi3' ->
    exists phi1, exists phi2, join phi1 phi2 phi3 /\
      age1 phi1 = Some phi1' /\ age1 phi2 = Some phi2'.
Proof.
  intros.
  apply (unage_join2 _ H0 H).
Qed.

Lemma join_unage'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
    forall phi1 phi1' phi2' phi3' : A,
      age1 phi1 = Some phi1' ->
      join phi1' phi2' phi3' ->
      exists phi2, exists phi3, join phi1 phi2 phi3 /\
        age1 phi2 = Some phi2' /\ age1 phi3 = Some phi3'.
Proof.
   intros. apply (unage_join _ H0 H).
Qed.

Lemma unageN'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (phi1 phi1' phi2' phi3' : A),
    ageN n phi1 = Some phi1' ->
    join phi1' phi2' phi3' ->
    exists phi2, exists phi3, join phi1 phi2 phi3 /\
      ageN n phi2 = Some phi2' /\ ageN n phi3 = Some phi3'.
Proof.
induction n; intros.
inv H. exists phi2'; exists phi3'; split; auto.
 unfold ageN in H. simpl in H.
 revert H; case_eq (age1 phi1); intros.
  spec IHn a phi1' phi2' phi3' H1; spec IHn H0.
  destruct IHn as [phi2 [phi3 [? [? ?]]]].
  destruct (join_unage' _ _ _ H H2) as [phi4 [phi5 [? [? ?]]]].
  exists phi4; exists phi5. split; auto.
 split; unfold ageN; simpl. rewrite H6; auto. rewrite H7; auto.
 inv H1.
Qed.

Hint Resolve @join_comparable @join_comparable'  @join_comparable'' @join_comparable'''
      @join_comparable2 @join_comparable2'  @list_join_comparable @list_join_comparable'
      @joins_comparable  @joins_comparable2  @join_sub_comparable  @join_sub_comparable2
      @eq_comparable  @eq_comparable2
  : comparable.

Hint Immediate @comparable_refl  @comparable_sym  : comparable.

Ltac Comp1 phi1 phi2 :=
   solve [ eauto 3 with comparable typeclass_instances |
  match goal with
  | H: comparable phi1 ?phi |- _ => Comp2 H phi1 phi phi2
  | H: comparable ?phi phi1 |- _ => Comp2 H phi1 phi phi2
  | H: join phi1 ?phia ?phib |- _ =>  Comp3 H phi1 phia phib phi2
  | H: join ?phia phi1 ?phib |- _ =>   Comp3 H phi1 phia phib phi2
  | H: join ?phia ?phib phi1 |- _ =>   Comp3 H phi1 phia phib phi2
  | H: joins phi1 ?phi |- _ =>  Comp2 H phi1 phi phi2
  | H: joins ?phi phi1 |- _ =>  Comp2 H phi1 phi phi2
  | H: join_sub phi1 ?phi |- _ => Comp2 H phi1 phi phi2
  | H: join_sub ?phi phi1 |- _ => Comp2 H phi1 phi phi2
  | H: list_join phi1 _ ?phi |- _ =>  Comp2 H phi1 phi phi2
  | H: list_join ?phi _ phi1 |- _ =>  Comp2 H phi1 phi phi2
  | H: phi1 = ?phi  |- _ => Comp2 H phi1 phi phi2
  | H: ?phi = phi1  |- _ => Comp2 H phi1 phi phi2
 end]
  with Comp2 H phi1 phi phi2 :=
            solve [apply comparable_trans with phi;
                         [eauto 3 with comparable  typeclass_instances |clear H; Comp1 phi phi2]
                   | clear H; Comp1 phi1 phi2]
  with Comp3 H phi1 phia phib phi2 :=
           solve [apply comparable_trans with phia;
                          [eauto 3 with comparable typeclass_instances |clear H; Comp1 phia phi2]
                  |apply comparable_trans with phib;
                          [eauto 3 with comparable  typeclass_instances | clear H; Comp1 phib phi2]
                   | clear H; Comp1 phi1 phi2].

Ltac Comp := match goal with
                | |- comparable ?phi1 ?phi2 => Comp1 phi1 phi2
                | |-  level ?phi1 = level ?phi2 => apply comparable_fashionR; Comp1 phi1 phi2
(*                | |- level _ = level _ => rewrite comparable_level; Comp *)
                end.

Definition not_any_younger {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A} (phi phi': A)  : Prop :=
     exists phi1, necR phi phi1 /\ comparable phi1 phi'.

Lemma comparable_not_any_younger {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A} :
    forall phi phi' : A , comparable phi phi' -> not_any_younger phi phi'.
Proof.
  intros.
  exists phi; split; auto; apply rt_refl.
Qed.

Lemma necR_not_any_younger {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall phi phi' : A, necR phi phi' -> not_any_younger phi phi'.
Proof. intros; exists phi'; split; auto. apply comparable_refl. Qed.

Lemma not_any_younger_refl {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
 forall phi : A, not_any_younger phi phi.
Proof. intros; exists phi; split; auto. apply comparable_refl. Qed.

Lemma not_any_younger_trans {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall phi1 phi2 phi3, not_any_younger phi1 phi2 -> not_any_younger phi2 phi3 ->
            not_any_younger phi1 phi3.
Proof.
intros.
destruct H as [phi1' [? ?]].
destruct H0 as [phi2' [? ?]].
generalize (comparable_common_unit H1); intros [e1 [? ?]].
generalize (nec_join2 H4 H0); intros [a [b [? [? _]]]].
generalize (nec_join H3 H6); intros [u [v [? [? _]]]].
exists u.
split.
econstructor 3; eauto.
Comp.
Qed.

Lemma not_any_younger_None {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall phi phi', age1 phi = None -> not_any_younger phi phi' -> age1 phi' = None.
Proof.
intros.
destruct H0 as [phi1 [? ?]].
revert phi' H1.
induction H0; intros.
unfold age in H0.
inversion2 H H0.
generalize (comparable_common_unit H1); intros [e1 [? ?]].
case_eq (age1 phi'); [intros w ? | intro]; auto.
elimtype False.
generalize (age1_join2 _ H2 H3); intros [a [b [? [? ?]]]].
generalize (age1_join _ H0 H5); intros [c [d [? [? ?]]]].
unfold age in H8; inversion2 H H8.
assert (x=y).
clear - H0_ H.
induction H0_.
 unfold age in *.
inversion2 H H0.
auto.
rewrite <- IHH0_2; auto.
rewrite <- IHH0_1; auto.
subst y.
auto.
Qed.

Lemma nec_join3 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}: forall {x x' y' z' : A},
       join x' y' z' ->
       necR x x' ->
       exists y,
         exists z,
           join x y z /\ necR y y' /\ necR z z'.
Proof.
intros.
revert y' z' H.
induction H0; intros.
destruct (unage_join _ H0 H) as [y0 [z0 [? [? ?]]]].
exists y0; exists z0; split; auto.
split; constructor 1; auto.
exists y'; exists z'.
split; auto.
rename z into x'.
rename y into x1.
destruct (IHclos_refl_trans2 _ _ H) as [x'' [y'' [? [? ?]]]].
destruct (IHclos_refl_trans1 _ _ H0) as [x0 [y0 [? [? ?]]]].
exists x0; exists y0.
split; auto.
split; econstructor 3; eauto.
Qed.


Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import ZArith Lia.
Require Import compcert.lib.Integers.          (* byte *)
Require Import Coq.Numbers.Natural.Peano.NPeano.

Require Import Coq.Strings.Ascii.
Require Import Coq.Program.Tactics.
Require Import sha.XorCorrespondence. (* Blist *)
Require Import sha.Bruteforce.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.

Definition Blist := list bool.
Open Scope Z_scope.

Inductive InBlocks {A : Type} (n : nat) : list A -> Prop :=
  | InBlocks_nil : InBlocks n []
  | InBlocks_block : forall (front back full : list A),
                   length front = n ->
                   full = front ++ back ->
                   InBlocks n back ->
                   InBlocks n full.

Lemma InBlocks_len : forall {A : Type} (l : list A) (n : nat),
                       PeanoNat.Nat.divide (n) (length l) -> InBlocks n l.
Proof.
  intros A l n div.
  destruct div.
  revert A l n H.
  induction x; intros; simpl in *.
  - destruct l; simpl in *. constructor. inversion H.
  - destruct (list_splitLength _ _ _ H) as [l1 [l2 [L [L1 L2]]]]. clear H; subst.
    apply IHx in L2. clear IHx.
    apply (InBlocks_block _ l1 l2); trivial.
Qed.

(* ----- Inductive *)

Inductive bytes_bits_lists : Blist -> list byte -> Prop :=
  | eq_empty : bytes_bits_lists nil nil
  | eq_cons : forall (bits : Blist) (bytes : list byte)
                     (b0 b1 b2 b3 b4 b5 b6 b7 : bool) (b : byte),
                bytes_bits_lists bits bytes ->
                convertByteBits [b0; b1; b2; b3; b4; b5; b6; b7] b ->
                bytes_bits_lists (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: bits)
                                 (b :: bytes).

(* ----- Computational *)

(* TODO: assumes Z is positive and in range, does not use Z.positive *)

Definition div_mod (num : Z) (denom : Z) : bool * Z :=
  (Z.gtb (num / denom) 0, num mod denom).

Definition byteToBits (byte : byte) : Blist :=
  let (b7, rem7) := div_mod (Byte.unsigned byte) 128 in
  let (b6, rem6) := div_mod rem7 64 in
  let (b5, rem5) := div_mod rem6 32 in
  let (b4, rem4) := div_mod rem5 16 in
  let (b3, rem3) := div_mod rem4 8 in
  let (b2, rem2) := div_mod rem3 4 in
  let (b1, rem1) := div_mod rem2 2 in
  let (b0, rem0) := div_mod rem1 1 in
  [b0; b1; b2; b3; b4; b5; b6; b7].

Fixpoint bytesToBits (bytes : list byte) : Blist :=
  match bytes with
    | [] => []
    | byte :: xs => byteToBits byte ++ bytesToBits xs
  end.

Definition bitsToByte (bits : Blist) : byte :=
  Byte.repr
  match bits with
    | b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: nil =>
      (1 * (asZ b0) + 2 * (asZ b1) + 4 * (asZ b2) + 8 * (asZ b3)
      + 16 * (asZ b4) + 32 * (asZ b5) + 64 * (asZ b6) + 128 * (asZ b7))
    | _ => -1                  (* should not happen *)
  end.

Fixpoint bitsToBytes (bits : Blist) : list byte :=
  match bits with
    | b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: xs =>
      bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7] :: bitsToBytes xs
    | _ => []
  end.

(*
Definition isbyteZ i := (0 <= i < 256)%Z.

Lemma bitsToByte_isbyteZ b0 b1 b2 b3 b4 b5 b6 b7:
      isbyteZ (bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7]).
Proof. simpl. unfold asZ, isbyteZ.
  destruct b0; destruct b1; destruct b2; destruct b3;
  destruct b4; destruct b5; destruct b6; destruct b7; simpl; lia.
Qed.
*)

(* -------------------- Various theorems and lemmas *)

Lemma byteToBits_length bt: length (byteToBits bt) = 8%nat.
Proof. reflexivity. Qed.

Lemma bytes_bits_length : forall (bits : Blist) (bytes : list byte),
  bytes_bits_lists bits bytes -> length bits = (length bytes * 8)%nat.
Proof.
  intros bits bytes corr.
  induction corr.
  - reflexivity.
  - simpl. repeat f_equal. apply IHcorr.
Qed.

Lemma bytesToBits_app : forall (l1 l2 : list byte),
                          bytesToBits (l1 ++ l2) = bytesToBits l1 ++ bytesToBits l2.
Proof.
  induction l1; intros.
  * reflexivity.
  *
    simpl. rewrite -> IHl1. reflexivity.
Qed.

Lemma bytesToBits_len : forall (l : list byte),
                          length (bytesToBits l) = (length l * 8)%nat.
Proof.
  induction l; intros; try reflexivity.
  -
    simpl.
    rewrite -> IHl.
    reflexivity.
Qed.

(* Prove by brute force (test all Z in range) *)
Theorem byte_bit_byte_id : forall (b : byte),
                                bitsToByte (byteToBits b) = b.
Proof.
  intros.
  rewrite <- (Byte.repr_unsigned b) at 2.
  unfold  byteToBits.
  pose proof (Byte.unsigned_range b).
  set (x := Byte.unsigned b)  in *. clearbody x.
  change Byte.modulus with 256 in H.
  unfold bitsToByte. f_equal.
  do_range H reflexivity.
Qed.

Theorem bits_byte_bits_id : forall (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
                              [b0; b1; b2; b3; b4; b5; b6; b7] =
                              byteToBits (bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7]).
Proof.
  intros.
  destruct b0; destruct b1; destruct b2; destruct b3;
  destruct b4; destruct b5; destruct b6; destruct b7;
  reflexivity.
Qed.

Theorem bytes_bits_bytes_id : forall (bytes : list byte),
                                bitsToBytes (bytesToBits bytes) = bytes.
Proof.
  intros bytes.
  induction bytes as [ | byte bytes].
  - reflexivity.
  -
    unfold bytesToBits.
    fold bytesToBits.
    unfold byteToBits.
    unfold bitsToBytes.
    Opaque bitsToByte. Opaque bitsToBytes. Opaque bytesToBits.
    simpl.
    Transparent bitsToBytes. fold bitsToBytes.
    rewrite -> IHbytes.

    Transparent bitsToByte.
    unfold bitsToByte. f_equal.
    apply byte_bit_byte_id.
Qed.

(* ------------------ Theorems relating inductive and computational definitions *)

Theorem bytes_bits_def_eq : forall (bytes : list byte),
                              bytes_bits_lists (bytesToBits bytes) bytes.
Proof.
  intros bytes.
  induction bytes as [ | byte bytes ].
  -
    simpl. apply eq_empty.
  -
    Transparent bytesToBits.
    apply eq_cons.

    *
      apply IHbytes.
    *
      unfold convertByteBits.
      do 8 eexists.
      split.
      +
        reflexivity.
      +
        pose proof (Byte.unsigned_range byte). change Byte.modulus with 256 in H.
        set (b := Byte.unsigned byte) in *. clearbody b.
        do_range H reflexivity.
Qed.

Theorem bytes_bits_comp_ind : forall (bits : Blist) (bytes : list byte),
                               bits = bytesToBits bytes ->
                               bytes_bits_lists bits bytes.
Proof.
  intros bits bytes corr.
  rewrite -> corr.
  apply bytes_bits_def_eq.
Qed.

Theorem bytes_bits_ind_comp : forall (bits : Blist) (bytes : list byte),
                                 bytes_bits_lists bits bytes ->
                                 bytes = bitsToBytes bits.
Proof.
  intros bits bytes corr.
  induction corr.
  - reflexivity.
  - rewrite -> IHcorr; clear IHcorr corr.
    unfold bitsToBytes.
      fold bitsToBytes.
      f_equal. unfold convertByteBits in H.
        destruct H as [b8 [b9 [b10 [b11 [b12 [b13 [b14 [b15 [B BT]]]]]]]]].
        inversion B; clear B. subst.
        rewrite <- (Byte.repr_unsigned b). rewrite BT.
        reflexivity.
Qed.

Theorem bits_bytes_ind_comp : forall (bits : Blist) (bytes : list byte),
                                 bytes_bits_lists bits bytes ->
                                 bits = bytesToBits bytes.
Proof.
  intros bits bytes corr.
  induction corr.
  - reflexivity.
  -
    unfold convertByteBits in H.
    destruct_exists.
    destruct H7.
    rewrite <- (Byte.repr_unsigned b). rewrite H8. clear H8.
    inversion H7.
    subst.
    clear H7.
    unfold bytesToBits.
    fold bytesToBits.
    assert (list_8 : forall {A : Type} (e0 e1 e2 e3 e4 e5 e6 e7 : A) (l : list A),
                       e0 :: e1 :: e2 :: e3 :: e4 :: e5 :: e6 :: e7 :: l =
                       [e0; e1; e2; e3; e4; e5; e6; e7] ++ l).
    reflexivity.
    rewrite -> list_8.
    f_equal.
    apply bits_byte_bits_id.
Qed.

(* ----------------------------- *)
(* Relating bits to bytes *)

Lemma bitsToBytes_app : forall (l m : Blist),
                          InBlocks 8 l ->
                          bitsToBytes (l ++ m) = bitsToBytes l ++ bitsToBytes m.
Proof.
  intros l m len_l. revert m.
  induction len_l.
  * intros. reflexivity.
  *
    intros m.
    rewrite -> H0.
    rewrite <- app_assoc.
    destruct front as [ | x0 [| x1 [ | x2 [ | x3 [ | x4 [ | x5 [ | x6 [ | x7 ]]]]]]]];
      inversion H.
    unfold bitsToBytes.
    Opaque bitsToByte.
    simpl.
    fold bitsToBytes.
    apply list_nil in H2.
    rewrite -> H2.
    simpl.
    rewrite -> IHlen_l.
    reflexivity.
Qed.

Lemma bitsToBytes_len_gen : forall (l : Blist) (n : nat),
                          length l = (n * 8)%nat ->
                          length (bitsToBytes l) = n.
Proof.
  intros l n len.
  assert (blocks : InBlocks 8 l).
    apply InBlocks_len. rewrite -> len. exists n. reflexivity.
  revert n len.
  induction blocks.
  * intros. simpl in *. lia.
  *
    intros n len.
    rewrite -> H0.
    rewrite -> bitsToBytes_app.
    rewrite -> app_length.
    rewrite -> H0 in len.
    rewrite -> app_length in len.
    rewrite -> H in len.

    destruct n as [ | n'].
    (* strange that destruct works here but not after [rewrite -> IHblocks] *)
    - simpl in *.
      inversion len.
    -
      destruct front as [ | x0 [| x1 [ | x2 [ | x3 [ | x4 [ | x5 [ | x6 [ | x7 ]]]]]]]];
      inversion H.

      simpl.
      apply list_nil in H2.
      rewrite -> H2. simpl.
      assert (minus : forall (n m : nat), n = m -> (n - 8)%nat = (m - 8)%nat).
        intros. lia.
      apply minus in len.
      simpl in len.
      assert (min_zero : forall (n : nat), (n - 0)%nat = n). intros. lia.
      repeat rewrite -> min_zero in len.
      clear H2 minus min_zero.
      specialize (IHblocks n').
      rewrite -> IHblocks.
      reflexivity.
      apply len.
      -
        apply InBlocks_len.
        rewrite -> H. unfold PeanoNat.Nat.divide.
        exists 1%nat. reflexivity.
Qed.

Lemma bitsToBytes_len : forall (l : Blist),
                          length l = 512%nat ->
                          Zlength (bitsToBytes l) = 64%Z.
Proof.
  intros l len.
  rewrite -> Zlength_correct.
  pose proof bitsToBytes_len_gen as len_gen.
  specialize (len_gen l 64%nat).
  rewrite -> len_gen.
  - reflexivity.
  - apply len.
Qed.

Lemma bits_bytes_bits_id : forall (l : Blist),
                             InBlocks 8 l ->
                             bytesToBits (bitsToBytes l) = l.
Proof.
  intros l len.
  induction len.
  - reflexivity.
  -
    rewrite -> H0.
    destruct front as [ | x0 [| x1 [ | x2 [ | x3 [ | x4 [ | x5 [ | x6 [ | x7 ]]]]]]]];
      inversion H.
    simpl.
    apply list_nil in H2. rewrite -> H2. simpl.
    rewrite -> IHlen.

    destruct x0; destruct x1; destruct x2; destruct x3;
    destruct x4; destruct x5; destruct x6; destruct x7; reflexivity.
Qed.

Lemma bytes_bits_lists_append:
  forall (l1 : Blist) (l2 : list byte) (m1 : Blist) (m2 : list byte),
    bytes_bits_lists l1 l2
    -> bytes_bits_lists m1 m2
    -> bytes_bits_lists (l1 ++ m1) (l2 ++ m2).
Proof.
  intros l1 l2 m1 m2.
  intros fst_eq snd_eq.
  generalize dependent m1. generalize dependent m2.
  induction fst_eq; intros.
  - repeat rewrite app_nil_l.
    apply snd_eq.
  - simpl.
    apply eq_cons.
    + apply IHfst_eq.
      apply snd_eq.
    + apply H.
Qed.

Lemma bytesToBits_nil_inv l: nil = bytesToBits l -> l = nil.
Proof. destruct l; trivial. simpl; intros. discriminate. Qed.

Lemma bytesToBits_cons b l:
      bytesToBits (b::l) = byteToBits b ++ bytesToBits l.
Proof. reflexivity. Qed.

Lemma byteToBits_injective: forall a b,
      byteToBits a = byteToBits b ->
      a = b.
Proof. intros.
assert (bitsToByte (byteToBits a) = bitsToByte (byteToBits b)).
  rewrite H; trivial.
clear H.
rewrite ?byte_bit_byte_id in H0. trivial.
Qed.

Lemma bytesToBits_injective: forall b1 b2, bytesToBits b1 = bytesToBits b2 ->
       b1=b2.
Proof. induction b1.
  intros; destruct b2; trivial. discriminate.
  destruct b2. discriminate.
  do 2 rewrite bytesToBits_cons.
  intros. destruct (app_inj1 _ _ _ _ H). reflexivity.
  rewrite (IHb1 _ H1).
  rewrite (byteToBits_injective _ _ H0). trivial.
Qed.

Lemma bitsToBytes_injective8 b1 b2 (B: bitsToBytes b1 = bitsToBytes b2)
       (L1: PeanoNat.Nat.divide 8 (length b1))
       (L2: PeanoNat.Nat.divide 8 (length b2)): b1 = b2.
Proof. intros.
  assert (bytesToBits (bitsToBytes b1) = bytesToBits (bitsToBytes b2)).
    rewrite B; trivial.
  rewrite bits_bytes_bits_id in H.
    rewrite bits_bytes_bits_id in H. trivial.
    apply InBlocks_len; assumption.
  apply InBlocks_len; assumption.
Qed.

Lemma bitsToByte_cons: forall bits h t, (h::t) = bitsToBytes bits ->
      exists b0, exists b1, exists b2, exists b3,
      exists b4, exists b5, exists b6, exists b7, exists xs,
      bits = b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: xs /\
      h = bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7] /\
      t = bitsToBytes xs.
Proof. intros.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits; inv H.
  eexists; eexists; eexists; eexists; eexists; eexists; eexists; eexists; eexists.
  split. reflexivity.
  split; reflexivity.
Qed.

Definition intsToBits (l : list Int.int) : list bool :=
  bytesToBits (intlist_to_bytelist l).

Definition bitsToInts (l : Blist) : list Int.int :=
  bytelist_to_intlist (bitsToBytes l).


Require Export NamelessUTLC.Functor.

Inductive term : Set := var (n: nat) :> term | abs (t: term) | app (fn: term) (arg: term).

Hint Constructors term.

Bind Scope term_scope with term.
Delimit Scope term_scope with term.
Notation "[ 'fun' e ]" := (abs e)
  (at level 0) : term_scope.
Notation "fn @ arg" :=
  (app fn arg)
    (at level 50, arg at next level, left associativity) : term_scope.
Global Open Scope term_scope.

Fixpoint eqt (t1 t2: term) : bool :=
  match t1, t2 with
  | var n1, var n2 => n1 == n2
  | abs t1, abs t2 => eqt t1 t2
  | app fn1 arg1, app fn2 arg2 => eqt fn1 fn2 && eqt arg1 arg2
  | _, _ => false
  end.

Theorem eqtP : Equality.axiom eqt.
Proof. move=> t1 t2. apply: introP.
  - elim: t1 t2 => //=.
    + move=> n. case=> // ?. by move/eqP.
    + move=> ? IH. case=> // ?. by move/IH.
    + move=> ? IHf ? IHa. case=> // ? ?. by move/andP=> [/(IHf _)-> /(IHa _)->].
  - elim: t1 t2 => //=.
    + move=> n. case=> // ?. by move/eqP.
    + move=> ? IH. case=> // ?. by move/IH.
    + move=> ? IHf ? IHa. case=> // ? ?. move/nandP. by case=> [/IHf | /IHa].
Qed.

Definition term_eqMixin := EqMixin eqtP.
Canonical term_eqType := Eval hnf in EqType term term_eqMixin.

Definition bound (t: term) : nat :=
  @term_rec (fun _ => nat)
            (fun n => n.+1)
            (fun _ => predn)
            (fun _ n _ m => maxn n m)
            t.

Inductive bounded (n: nat) : term -> Prop :=
| BoundedVar k (lt: k < n) : bounded n k
| BoundedAbs t (t_bounded: bounded n.+1 t) : bounded n [fun t]
| BoundedApp t1 (t1_bounded: bounded n t1) t2 (t2_bounded: bounded n t2) : bounded n (t1 @ t2).

Hint Constructors bounded.

Lemma invert_bounded n t (H: bounded n t)
  : match t return Prop with
    | var k => k < n
    | abs t => bounded n.+1 t
    | app fn arg => bounded n fn /\ bounded n arg
    end.
Proof. case: t H => *; match goal with
                 | [ H: bounded _ _ |- _ ] => by inversion H
                 end. Qed.

Lemma boundedS : forall t n, bounded n t -> bounded n.+1 t.
Proof. elim; move=> *; match goal with
                 | [H: bounded _ _ |- _] => move: H; by invert
                 end.
Qed.

Hint Resolve boundedS.

Lemma bounded_leq : forall t n, bounded n t -> forall m, n <= m -> bounded m t.
Proof. elim.
  - move=> ? ? /invert_bounded-? ? ?. constructor. by apply: leq_trans; eauto.
  - move=> ? IH ? /invert_bounded-? ? ?. constructor. by apply: IH; eauto.
  - move=> ? IHf ? IHa ? /invert_bounded-[? ?] ? ?. constructor.
    + by apply: IHf; eauto.
    + by apply: IHa; eauto.
Qed.

Hint Resolve bounded_leq.

Lemma maxn_leq_andb n m p : maxn n m <= p = (n <= p) && (m <= p).
Proof. case n_leq_m: (n <= m); move: (n_leq_m).
  * move/maxn_idPl. rewrite maxnC => ->. case m_leq_p: (m <= p).
    -- by move: (leq_trans n_leq_m m_leq_p).
    -- by rewrite andbF.
  * move/negbT. rewrite -ltnNge. move/ltnW/maxn_idPr. rewrite maxnC=> ->.
    case n_leq_p: (n <= p) => //.
    move/negbT: n_leq_m n_leq_p. rewrite -ltnNge.
    move/ltnW=> m_leq_n n_leq_p. by move: (leq_trans m_leq_n n_leq_p).
Qed.

Theorem boundP : forall t n, reflect (forall m, n <= m -> bounded m t) (bound t <= n).
Proof. elim=> /=.
  - move=> n1 n2. apply: introP.
    + constructor. by apply: leq_trans; eauto.
    + rewrite -leqNgt => H. move/(_ n2 (leqnn n2))/invert_bounded.
      rewrite ltn_neqAle. move/andP=> [neq H']. move/andP/anti_leq: (conj H H').
      by move/eqP: neq.
  - move=> t IH n.
    have leq_sub1_add1: forall n m, (n.-1 <= m) = (n <= m.+1) by elim.
    rewrite {}leq_sub1_add1. apply: introP.
    + move=> Hbound m Hm.
      constructor. apply: IH.
      * exact: Hbound.
      * by rewrite ltnS.
    + move/(elimN (IH n.+1))=> {IH} contra. move/(_ n (leqnn _))/invert_bounded => H.
      apply: contra => m lt. by apply: bounded_leq; eauto.
  - move=> f IHf a IHa n.
    rewrite maxn_leq_andb.
    apply: introP.
    + move/andP=> [bf_leq ba_leq] m leq. move/(fun x => leq_trans x leq): bf_leq => ?.
      move/(fun x => leq_trans x leq): ba_leq => {leq} ?.
        by constructor; [apply: IHf | apply: IHa]; eauto.
    + move/nandP=> [/IHf-nbf | /IHa-nba] /(_ n (leqnn _))/invert_bounded-[? ?];
                    [apply: nbf | apply: nba] => ? ?; by apply: bounded_leq; eauto.
Qed.

Lemma boundEqP : forall t n, bound t == n -> forall m, n <= m -> bounded m t.
Proof. move=> t n. rewrite eqn_leq. move/andP=> [H _]. by move/boundP: H. Qed.

Definition shift_over (d: nat) : term -> nat -> term :=
  @term_rec (fun _ => nat -> term)
            (fun n c => if n < c then n else n + d)
            (fun _ rec c => [fun rec c.+1])
            (fun _ rec_f _ rec_a c => rec_f c @ rec_a c).

Definition shift (d: nat) : term -> term := shift_over d ^~ 0.

Lemma bound_shift_over {n t} : bounded n t -> forall {c d}, bounded (n + d) (shift_over d t c).
Proof. elim=> //= {n t}.
  move=> ? k ? c *. constructor. case: (k < c).
  - by apply: ltn_addr.
  - by rewrite ltn_add2r.
Qed.

Theorem bound_shift {n t d} : bounded n t -> bounded (n + d) (shift d t).
Proof. move=> *. by apply: bound_shift_over. Qed.

Definition substitute (substitution: term) (variable: nat) (t: term) : term :=
  @term_rec (fun _ => nat -> term -> term)
           (fun n v s => if n == v then s else n)
           (fun _ rec v s => [fun rec v.+1 (shift 1 s)])
           (fun _ rec_fn _ rec_arg v s => rec_fn v s @ rec_arg v s)
           t variable substitution.

Theorem bound_substitute {n t}
  : bounded n t -> forall s, bounded n s -> forall v, bounded n (substitute s v t).
Proof. elim=> //= {n t}.
  - move=> ? k ? ? ? v. by case: (k == v).
  - move=> ? ? ? IH ? bs ?. constructor.
    move/bound_shift: bs. move/(_ 1). rewrite addn1. by move/IH.
Qed.


Require Import compcert.lib.Integers.
Require Import Recdef.
Require Import Bvector.
Require Import List. Import ListNotations.
Require Import Arith.
Require Import compcert.lib.Coqlib.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.
Require Import sha.XorCorrespondence.
Require Import sha.ByteBitRelations.
Import List.

Definition concat {A : Type} (l : list (list A)) : list A :=
  flat_map id l.

Lemma concat_length {A}: forall L (l:list A), In l L -> (length (concat L) >= length l)%nat.
Proof.  unfold concat. induction L; simpl; intros. contradiction.
  rewrite app_length.
  destruct H; subst. unfold id. omega.
  specialize (IHL _ H). omega.
Qed.

Lemma concat_InBlocks b: forall l (F: Forall (fun x : list bool => length x = b) l),
      InBlocks b (concat l).
induction l; simpl; intros. constructor.
econstructor. 2: reflexivity.
 apply Forall_inv in F; trivial.
 apply IHl. apply Forall_tl in F; trivial.
Qed.

Lemma concat_app {A} (l1 l2:list A): l1 ++ l2 = l1 ++ concat (l2 :: nil).
Proof.
  unfold concat. simpl.
  rewrite -> app_nil_r. reflexivity.
Qed.

(* Replacing splitVector *)
Definition splitList {A : Type} (n : nat) (l : list A) : (list A * list A) :=
  (firstn n l, skipn n l).

Lemma split_append_id : forall {A : Type} (len : nat) (l1 l2 : list A),
                               length l1 = len -> length l2 = len ->
                               splitList len (l1 ++ l2) = (l1, l2).
Proof.
  induction len; intros l1 l2 len1 len2.
  - apply list_nil in len1; apply list_nil in len2.
    subst. reflexivity.
  - unfold splitList.
    rewrite -> firstn_exact. rewrite -> skipn_exact.
    * reflexivity. * assumption. * assumption.
Qed.

(* Replacing BVxor *)
Definition BLxor (xs : Blist) (ys : Blist) :=
  map (fun p => xorb (fst p) (snd p)) (combine xs ys).

Lemma BLxor_length: forall n l1 l2
      (len1: length l1 = n) (len2: length l2 = n), length (BLxor l1 l2) = n.
Proof.
  induction n as [ | n']; intros.
  - apply list_nil in len1. apply list_nil in len2.
    subst. reflexivity.
  - destruct l1; destruct l2; inversion len1; inversion len2.
    simpl.
    rewrite -> map_length.
    rewrite -> combine_length.
    rewrite H0. rewrite H1. simpl.
    f_equal.
    apply min_l.
    omega.
Qed.

Theorem xor_eq : forall (n : nat) (v1 v2 : Bvector.Bvector n),
                   BLxor (Vector.to_list v1) (Vector.to_list v2) =
                   Vector.to_list (Bvector.BVxor n v1 v2).
Proof.
  eapply Vector.rect2.
  reflexivity.
  intros. simpl. rewrite (VectorToList_cons _ _ (xorb a b)).
   rewrite <- H. clear H. unfold BLxor.
   rewrite VectorToList_combine. reflexivity.
Qed.

Lemma inner_general_mapByte : forall (ip : Blist) (IP_list : list byte) (k : Blist) (K : list byte),
                            bytes_bits_lists ip IP_list ->
                            bytes_bits_lists k K ->
     bytes_bits_lists (BLxor k ip)
                          (map (fun p0 : byte * byte => Byte.xor (fst p0) (snd p0))
                                (combine K IP_list)).
Proof.
  intros ip IP_list k K ip_eq k_eq.
  unfold BLxor. simpl.
  generalize dependent IP_list. generalize dependent ip.
  induction k_eq.
  - simpl; intros. constructor.
  - intros. inv ip_eq.
    + constructor.
    + simpl. constructor; auto.
        unfold Byte.xor.
        apply xor_correspondence; auto.
Qed.

Function hash_blocks_bits (b:nat) (B:(0<b)%nat) (hash_block_bit : Blist -> Blist -> Blist) (r: Blist)
         (msg: Blist) {measure length msg} : Blist :=
  match msg with
  | nil => r
  | _ => hash_blocks_bits b B hash_block_bit (hash_block_bit r (firstn b msg)) (skipn b msg)
  end.
Proof. intros.
 destruct (lt_dec (length msg) b).
 rewrite skipn_short. simpl; omega. rewrite <- teq; omega.
 rewrite skipn_length; rewrite <- teq; omega.
Defined.

Lemma add_blocksize_length l n: 0<=n ->
      BinInt.Z.add n (Zcomplements.Zlength l) = Zcomplements.Zlength ((Coqlib.list_repeat (Z.to_nat n) true) ++ l).
Proof. intros. do 2 rewrite Zlength_correct.
  rewrite app_length, length_list_repeat, Nat2Z.inj_add, Z2Nat.id; trivial.
Qed.

Lemma hash_blocks_bits_len c b (B:(0<b)%nat) h
          (HH: forall x y, length x = c -> length y = b -> length (h x y)  = c)
          r l: length r = c ->
      InBlocks b l ->
      length (hash_blocks_bits b B h r l) = c.
Proof.
  apply hash_blocks_bits_ind.
  intros. trivial.
  intros. destruct _x. contradiction. subst msg; clear y.
  inv H1.
  apply H; clear H. rewrite HH. trivial. trivial.
    rewrite H3, firstn_exact; trivial.
    rewrite H3, skipn_exact; trivial.
Qed.


Section EqDec.

  Variable A:Type.

  Variable eq_dec: forall (x y:A), { x = y } + { x <> y }.

  Definition eq_dec_to_bool x y := if eq_dec x y then true else false.

  Lemma eq_dec_inv_true:
    forall x y,
    eq_dec_to_bool x y = true -> x = y.
  Proof.
    intros.
    unfold eq_dec_to_bool in *.
    destruct (eq_dec x y); auto; try inversion H.
  Qed.

  Lemma eq_dec_inv_false:
    forall x y,
    eq_dec_to_bool x y = false -> x <> y.
  Proof.
    intros.
    unfold eq_dec_to_bool in *.
    destruct (eq_dec x y); auto; try inversion H.
  Qed.

  Lemma eq_dec_rw:
    forall x y,
    { eq_dec_to_bool x y = true /\ x = y } +
    { eq_dec_to_bool x y = false /\ x <> y }.
  Proof.
    intros.
    unfold eq_dec_to_bool.
    destruct (eq_dec x y).
    - left; intuition.
    - right; intuition.
  Qed.

  Lemma eq_dec_refl:
    forall x,
    eq_dec_to_bool x x = true.
  Proof.
    intros.
    destruct eq_dec_rw with (x:=x) (y:=x) as [(?,?)|(?,?)].
    - trivial.
    - contradiction H0.
      trivial.
  Qed.

End EqDec.


(** * Types: Type Systems *)

(** Our next major topic is _type systems_ -- static program
    analyses that classify expressions according to the "shapes" of
    their results.  We'll begin with a typed version of the simplest
    imaginable language, to introduce the basic ideas of types and
    typing rules and the fundamental theorems about type systems:
    _type preservation_ and _progress_.  In chapter [Stlc] we'll move
    on to the _simply typed lambda-calculus_, which lives at the core
    of every modern functional programming language (including
    Coq!). *)
Add LoadPath "~/Desktop/CS386L-Programming-Language/plf".
Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Arith.Arith.
Require Import Maps.
Require Import Imp.
Require Import Smallstep.

Hint Constructors multi.

(* ################################################################# *)
(** * Typed Arithmetic Expressions *)

(** To motivate the discussion of type systems, let's begin as
    usual with a tiny toy language.  We want it to have the potential
    for programs to go wrong because of runtime type errors, so we
    need something a tiny bit more complex than the language of
    constants and addition that we used in chapter [Smallstep]: a
    single kind of data (e.g., numbers) is too simple, but just two
    kinds (numbers and booleans) gives us enough material to tell an
    interesting story.

    The language definition is completely routine. *)

(* ================================================================= *)
(** ** Syntax *)

(** Here is the syntax, informally:

    t ::= true
        | false
        | if t then t else t
        | 0
        | succ t
        | pred t
        | iszero t

    And here it is formally: *)

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tzero : tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tiszero : tm -> tm.

(** _Values_ are [true], [false], and numeric values... *)

Inductive bvalue : tm -> Prop :=
  | bv_true : bvalue ttrue
  | bv_false : bvalue tfalse.

Inductive nvalue : tm -> Prop :=
  | nv_zero : nvalue tzero
  | nv_succ : forall t, nvalue t -> nvalue (tsucc t).

Definition value (t:tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue.
Hint Unfold value.
Hint Unfold update.

(* ================================================================= *)
(** ** Operational Semantics *)

(** Here is the single-step relation, first informally... *)
(**

                    ------------------------------                  (ST_IfTrue)
                    if true then t1 else t2 ==> t1

                   -------------------------------                 (ST_IfFalse)
                   if false then t1 else t2 ==> t2

                              t1 ==> t1'
            ------------------------------------------------            (ST_If)
            if t1 then t2 else t3 ==> if t1' then t2 else t3

                              t1 ==> t1'
                         --------------------                         (ST_Succ)
                         succ t1 ==> succ t1'

                             ------------                         (ST_PredZero)
                             pred 0 ==> 0

                           numeric value v1
                        ---------------------                     (ST_PredSucc)
                        pred (succ v1) ==> v1

                              t1 ==> t1'
                         --------------------                         (ST_Pred)
                         pred t1 ==> pred t1'

                          -----------------                     (ST_IszeroZero)
                          iszero 0 ==> true

                           numeric value v1
                      --------------------------                (ST_IszeroSucc)
                      iszero (succ v1) ==> false

                              t1 ==> t1'
                       ------------------------                     (ST_Iszero)
                       iszero t1 ==> iszero t1'
*)

(** ... and then formally: *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)
  | ST_Succ : forall t1 t1',
      t1 ==> t1' ->
      (tsucc t1) ==> (tsucc t1')
  | ST_PredZero :
      (tpred tzero) ==> tzero
  | ST_PredSucc : forall t1,
      nvalue t1 ->
      (tpred (tsucc t1)) ==> t1
  | ST_Pred : forall t1 t1',
      t1 ==> t1' ->
      (tpred t1) ==> (tpred t1')
  | ST_IszeroZero :
      (tiszero tzero) ==> ttrue
  | ST_IszeroSucc : forall t1,
       nvalue t1 ->
      (tiszero (tsucc t1)) ==> tfalse
  | ST_Iszero : forall t1 t1',
      t1 ==> t1' ->
      (tiszero t1) ==> (tiszero t1')

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

(** Notice that the [step] relation doesn't care about whether
    expressions make global sense -- it just checks that the operation
    in the _next_ reduction step is being applied to the right kinds
    of operands.  For example, the term [succ true] (i.e.,
    [tsucc ttrue] in the formal syntax) cannot take a step, but the
    almost as obviously nonsensical term

       succ (if true then true else true)

    can take a step (once, before becoming stuck). *)

(* ================================================================= *)
(** ** Normal Forms and Values *)

(** The first interesting thing to notice about this [step] relation
    is that the strong progress theorem from the [Smallstep] chapter
    fails here.  That is, there are terms that are normal forms (they
    can't take a step) but not values (because we have not included
    them in our definition of possible "results of reduction").  Such
    terms are _stuck_. *)

Notation step_normal_form := (normal_form step).

Definition stuck (t:tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck.

(** **** Exercise: 2 stars (some_term_is_stuck)  *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  exists (tsucc ttrue).
  unfold stuck,step_normal_form.
  split; intros H.
  - destruct H. inversion H;subst. inversion H1.
  - inversion H;subst.
    + inversion H0;subst.
    + inversion H0;subst. inversion H2.
Qed.
(** [] *)

(** However, although values and normal forms are _not_ the same in this
    language, the set of values is included in the set of normal
    forms.  This is important because it shows we did not accidentally
    define things so that some value could still take a step. *)

(** **** Exercise: 3 stars (value_is_nf)  *)

Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.

  unfold step_normal_form, not. intros.
  inversion H.
  + inversion H0. inversion H1;subst;inversion H2.
  + induction H1.
    - destruct H0. inversion H0.
    - apply IHnvalue. inversion H1;subst.
      right. assumption. right. assumption. destruct H0.
      inversion H0;subst. exists t1'. assumption.

Qed.

(** (Hint: You will reach a point in this proof where you need to
    use an induction to reason about a term that is known to be a
    numeric value.  This induction can be performed either over the
    term itself or over the evidence that it is a numeric value.  The
    proof goes through in either case, but you will find that one way
    is quite a bit shorter than the other.  For the sake of the
    exercise, try to complete the proof both ways.) *)
(** [] *)

(** **** Exercise: 3 stars, optional (step_deterministic)  *)
(** Use [value_is_nf] to show that the [step] relation is also
    deterministic. *)

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Typing *)

(** The next critical observation is that, although this
    language has stuck terms, they are always nonsensical, mixing
    booleans and numbers in a way that we don't even _want_ to have a
    meaning.  We can easily exclude such ill-typed terms by defining a
    _typing relation_ that relates terms to the types (either numeric
    or boolean) of their final results.  *)

Inductive ty : Type :=
  | TBool : ty
  | TNat : ty.

(** In informal notation, the typing relation is often written
    [|- t \in T] and pronounced "[t] has type [T]."  The [|-] symbol
    is called a "turnstile."  Below, we're going to see richer typing
    relations where one or more additional "context" arguments are
    written to the left of the turnstile.  For the moment, the context
    is always empty. *)
(**
                           ----------------                            (T_True)
                           |- true \in Bool

                          -----------------                           (T_False)
                          |- false \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------                (T_If)
                    |- if t1 then t2 else t3 \in T

                             ------------                              (T_Zero)
                             |- 0 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Succ)
                          |- succ t1 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Pred)
                          |- pred t1 \in Nat

                            |- t1 \in Nat
                        ---------------------                        (T_IsZero)
                        |- iszero t1 \in Bool
*)

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_True :
       |- ttrue \in TBool
  | T_False :
       |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T,
       |- t1 \in TBool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- tif t1 t2 t3 \in T
  | T_Zero :
       |- tzero \in TNat
  | T_Succ : forall t1,
       |- t1 \in TNat ->
       |- tsucc t1 \in TNat
  | T_Pred : forall t1,
       |- t1 \in TNat ->
       |- tpred t1 \in TNat
  | T_Iszero : forall t1,
       |- t1 \in TNat ->
       |- tiszero t1 \in TBool

where "'|-' t '\in' T" := (has_type t T).

Hint Constructors has_type.

Example has_type_1 :
  |- tif tfalse tzero (tsucc tzero) \in TNat.
Proof.
  apply T_If.
    - apply T_False.
    - apply T_Zero.
    - apply T_Succ.
       + apply T_Zero.
Qed.

(** (Since we've included all the constructors of the typing relation
    in the hint database, the [auto] tactic can actually find this
    proof automatically.) *)

(** It's important to realize that the typing relation is a
    _conservative_ (or _static_) approximation: it does not consider
    what happens when the term is reduced -- in particular, it does
    not calculate the type of its normal form. *)

Example has_type_not :
  ~ (|- tif tfalse tzero ttrue \in TBool).
Proof.
  intros Contra. solve_by_inverts 2.  Qed.

(** **** Exercise: 1 star, optional (succ_hastype_nat__hastype_nat)  *)
Example succ_hastype_nat__hastype_nat : forall t,
  |- tsucc t \in TNat ->
  |- t \in TNat.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Canonical forms *)

(** The following two lemmas capture the fundamental property that the
    definitions of boolean and numeric values agree with the typing
    relation. *)

Lemma bool_canonical : forall t,
  |- t \in TBool -> value t -> bvalue t.
Proof.
  intros t HT HV.
  inversion HV; auto.
  induction H; inversion HT; auto.
Qed.

Lemma nat_canonical : forall t,
  |- t \in TNat -> value t -> nvalue t.
Proof.
  intros t HT HV.
  inversion HV.
  inversion H; subst; inversion HT.
  auto.
Qed.

(* ================================================================= *)
(** ** Progress *)

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are not stuck -- or conversely, if a
    term is well typed, then either it is a value or it can take at
    least one step.  We call this _progress_. *)

(** **** Exercise: 3 stars (finish_progress)  *)
Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t ==> t'.

(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the parts we've given of the informal proof in the
    following exercise before starting -- this will save you a lot of
    time.) *)
Proof with auto.
  intros t T HT.
  induction HT...
  (* The cases that were obviously values, like T_True and
     T_False, were eliminated immediately by auto *)
  - (* T_If *)
    right. inversion IHHT1; clear IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    inversion H; subst; clear H.
      exists t2...
      exists t3...
    + (* t1 can take a step *)
      inversion H as [t1' H1].
      exists (tif t1' t2 t3)...
  - inversion HT;subst.
    + destruct IHHT.
      * left. right. apply nv_succ. apply nat_canonical in H2; assumption.
      * right. destruct H2. exists (tsucc x). apply ST_Succ. assumption.
    + left. right. constructor. constructor.
    + destruct IHHT.
      * left. right. constructor. apply nat_canonical in HT;assumption.
      * right. destruct H0. exists (tsucc x). constructor. assumption.
    + destruct IHHT.
      * left. right. constructor. apply nat_canonical in HT;assumption.
      * right. destruct H0. exists (tsucc x). constructor. assumption.
  - right. inversion IHHT; clear IHHT;inversion H.
    solve_by_inverts 2.
    + inversion H0. exists tzero. constructor. exists t. constructor. assumption.
    + exists (tpred x). constructor. apply H0.
  - right;inversion IHHT;clear IHHT.
    + inversion H. solve_by_inverts 2. inversion H0.
      exists (ttrue). constructor. exists (tfalse). constructor. apply H1.
    + destruct H. exists (tiszero x). constructor. apply H.
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_progress_informal)  *)
(** Complete the corresponding informal proof: *)

(** _Theorem_: If [|- t \in T], then either [t] is a value or else
    [t ==> t'] for some [t']. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].  By the IH, either [t1] is a value or else [t1] can step
        to some [t1'].

            - If [t1] is a value, then by the canonical forms lemmas
              and the fact that [|- t1 \in Bool] we have that [t1]
              is a [bvalue] -- i.e., it is either [true] or [false].
              If [t1 = true], then [t] steps to [t2] by [ST_IfTrue],
              while if [t1 = false], then [t] steps to [t3] by
              [ST_IfFalse].  Either way, [t] can step, which is what
              we wanted to show.

            - If [t1] itself can take a step, then, by [ST_If], so can
              [t].

      - (* FILL IN HERE *)
 *)
(** [] *)

(** This theorem is more interesting than the strong progress theorem
    that we saw in the [Smallstep] chapter, where _all_ normal forms
    were values.  Here a term can be stuck, but only if it is ill
    typed. *)

(* ================================================================= *)
(** ** Type Preservation *)

(** The second critical property of typing is that, when a well-typed
    term takes a step, the result is also a well-typed term. *)

(** **** Exercise: 2 stars (finish_preservation)  *)
Theorem preservation : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.

(** Complete the formal proof of the [preservation] property.  (Again,
    make sure you understand the informal proof fragment in the
    following exercise first.) *)

Proof with auto.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try solve_by_invert.
    - (* T_If *) inversion HE; subst; clear HE.
      + (* ST_IFTrue *) assumption.
      + (* ST_IfFalse *) assumption.
      + (* ST_If *) apply T_If; try assumption.
        apply IHHT1; assumption.
    - inversion HE;subst;clear HE.
      apply T_Succ. apply IHHT. assumption.
    - inversion HE;subst;clear HE.
      + constructor.
      + inversion HT;subst. apply H1.
      + constructor. apply IHHT. assumption.
    - inversion HE;subst;clear HE.
      + constructor.
      + constructor.
      + constructor. apply IHHT. assumption.
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_preservation_informal)  *)
(** Complete the following informal proof: *)

(** _Theorem_: If [|- t \in T] and [t ==> t'], then [|- t' \in T]. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].

        Inspecting the rules for the small-step reduction relation and
        remembering that [t] has the form [if ...], we see that the
        only ones that could have been used to prove [t ==> t'] are
        [ST_IfTrue], [ST_IfFalse], or [ST_If].

           - If the last rule was [ST_IfTrue], then [t' = t2].  But we
             know that [|- t2 \in T], so we are done.

           - If the last rule was [ST_IfFalse], then [t' = t3].  But we
             know that [|- t3 \in T], so we are done.

           - If the last rule was [ST_If], then [t' = if t1' then t2
             else t3], where [t1 ==> t1'].  We know [|- t1 \in Bool] so,
             by the IH, [|- t1' \in Bool].  The [T_If] rule then gives us
             [|- if t1' then t2 else t3 \in T], as required.

      - (* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 3 stars (preservation_alternate_proof)  *)
(** Now prove the same property again by induction on the
    _evaluation_ derivation instead of on the typing derivation.
    Begin by carefully reading and thinking about the first few
    lines of the above proofs to make sure you understand what
    each one is doing.  The set-up for this proof is similar, but
    not exactly the same. *)

Theorem preservation' : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.
Proof with eauto.
  intros.
  generalize dependent T.
  induction H0;intros;
  try (inversion H;subst;constructor;try assumption);
  try (inversion H;subst;assumption);
  try (apply IHstep;assumption).
  - inversion H0;subst. inversion H2. assumption.
  - inversion H0;subst. constructor.
Qed.
(** [] *)

(** The preservation theorem is often called _subject reduction_,
    because it tells us what happens when the "subject" of the typing
    relation is reduced.  This terminology comes from thinking of
    typing statements as sentences, where the term is the subject and
    the type is the predicate. *)

(* ================================================================= *)
(** ** Type Soundness *)

(** Putting progress and preservation together, we see that a
    well-typed term can never reach a stuck state.  *)

Definition multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Corollary soundness : forall t t' T,
  |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP.  apply (preservation x y T HT H).
  unfold stuck. split; auto.   Qed.

(* ################################################################# *)
(** * Aside: the [normalize] Tactic *)

(** When experimenting with definitions of programming languages
    in Coq, we often want to see what a particular concrete term steps
    to -- i.e., we want to find proofs for goals of the form [t ==>*
    t'], where [t] is a completely concrete term and [t'] is unknown.
    These proofs are quite tedious to do by hand.  Consider, for
    example, reducing an arithmetic expression using the small-step
    relation [astep]. *)

Module NormalizePlayground.
Import Smallstep.

Example step_example1 :
  (P (C 3) (P (C 3) (C 4)))
  ==>* (C 10).
Proof.
  apply multi_step with (P (C 3) (C 7)).
    apply ST_Plus2.
      apply v_const.
      apply ST_PlusConstConst.
  apply multi_step with (C 10).
    apply ST_PlusConstConst.
  apply multi_refl.
Qed.

(** The proof repeatedly applies [multi_step] until the term reaches a
    normal form.  Fortunately The sub-proofs for the intermediate
    steps are simple enough that [auto], with appropriate hints, can
    solve them. *)

Hint Constructors step value.
Example step_example1' :
  (P (C 3) (P (C 3) (C 4)))
  ==>* (C 10).
Proof.
  eapply multi_step. auto. simpl.
  eapply multi_step. auto. simpl.
  apply multi_refl.
Qed.

(** The following custom [Tactic Notation] definition captures this
    pattern.  In addition, before each step, we print out the current
    goal, so that we can follow how the term is being reduced. *)

Tactic Notation "print_goal" :=
  match goal with |- ?x => idtac x end.

Tactic Notation "normalize" :=
  repeat (print_goal; eapply multi_step ;
            [ (eauto 10; fail) | (instantiate; simpl)]);
  apply multi_refl.

Example step_example1'' :
  (P (C 3) (P (C 3) (C 4)))
  ==>* (C 10).
Proof.
  normalize.
  (* The [print_goal] in the [normalize] tactic shows
     a trace of how the expression reduced...
         (P (C 3) (P (C 3) (C 4)) ==>* C 10)
         (P (C 3) (C 7) ==>* C 10)
         (C 10 ==>* C 10)
  *)
Qed.

(** The [normalize] tactic also provides a simple way to calculate the
    normal form of a term, by starting with a goal with an existentially
    bound variable. *)

Example step_example1''' : exists e',
  (P (C 3) (P (C 3) (C 4)))
  ==>* e'.
Proof.
  eapply ex_intro. normalize.
(* This time, the trace is:
       (P (C 3) (P (C 3) (C 4)) ==>* ?e')
       (P (C 3) (C 7) ==>* ?e')
       (C 10 ==>* ?e')
   where ?e' is the variable ``guessed'' by eapply. *)
Qed.

(** **** Exercise: 1 star (normalize_ex)  *)
Theorem normalize_ex : exists e',
  (P (C 3) (P (C 2) (C 1)))
  ==>* e'.
Proof.
  eapply ex_intro. normalize.
Qed.
(** [] *)

(** **** Exercise: 1 star, optional (normalize_ex')  *)
(** For comparison, prove it using [apply] instead of [eapply]. *)

Theorem normalize_ex' : exists e',
  (P (C 3) (P (C 2) (C 1)))
  ==>* e'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

End NormalizePlayground.

Tactic Notation "print_goal" :=
  match goal with |- ?x => idtac x end.
Tactic Notation "normalize" :=
  repeat (print_goal; eapply multi_step ;
            [ (eauto 10; fail) | (instantiate; simpl)]);
  apply multi_refl.

(* ================================================================= *)
(** ** Additional Exercises *)

(** **** Exercise: 2 stars, recommended (subject_expansion)  *)
(** Having seen the subject reduction property, one might
    wonder whether the opposity property -- subject _expansion_ --
    also holds.  That is, is it always the case that, if [t ==> t']
    and [|- t' \in T], then [|- t \in T]?  If so, prove it.  If
    not, give a counter-example.  (You do not need to prove your
    counter-example in Coq, but feel free to do so.)

   t=(tif ttrue t' tzero) ==> t'
   but (tif ttrue t' tzero) is neither NAT nor BOOL

    (* FILL IN HERE *)
*)

(** [] *)

(** **** Exercise: 2 stars (variation1)  *)
(** Suppose, that we add this new rule to the typing relation:

      | T_SuccBool : forall t,
           |- t \in TBool ->
           |- tsucc t \in TBool

   Which of the following properties remain true in the presence of
   this rule?  For each one, write either "remains true" or
   else "becomes false." If a property becomes false, give a
   counterexample.
      - Determinism of [step]

      - Progress

      - Preservation

    [] *)

(** **** Exercise: 2 stars (variation2)  *)
(** Suppose, instead, that we add this new rule to the [step] relation:

      | ST_Funny1 : forall t2 t3,
           (tif ttrue t2 t3) ==> t3

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

    [] *)

(** **** Exercise: 2 stars, optional (variation3)  *)
(** Suppose instead that we add this rule:

      | ST_Funny2 : forall t1 t2 t2' t3,
           t2 ==> t2' ->
           (tif t1 t2 t3) ==> (tif t1 t2' t3)

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

    [] *)

(** **** Exercise: 2 stars, optional (variation4)  *)
(** Suppose instead that we add this rule:

      | ST_Funny3 :
          (tpred tfalse) ==> (tpred (tpred tfalse))

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

    [] *)

(** **** Exercise: 2 stars, optional (variation5)  *)
(** Suppose instead that we add this rule:

      | T_Funny4 :
            |- tzero \in TBool

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

    [] *)

(** **** Exercise: 2 stars, optional (variation6)  *)
(** Suppose instead that we add this rule:

      | T_Funny5 :
            |- tpred tzero \in TBool

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

    [] *)

(** **** Exercise: 3 stars, optional (more_variations)  *)
(** Make up some exercises of your own along the same lines as
    the ones above.  Try to find ways of selectively breaking
    properties -- i.e., ways of changing the definitions that
    break just one of the properties and leave the others alone.
*)
(** [] *)

(** **** Exercise: 1 star (remove_predzero)  *)
(** The reduction rule [ST_PredZero] is a bit counter-intuitive: we
    might feel that it makes more sense for the predecessor of zero to
    be undefined, rather than being defined to be zero.  Can we
    achieve this simply by removing the rule from the definition of
    [step]?  Would doing so create any problems elsewhere?

(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 4 stars, advanced (prog_pres_bigstep)  *)
(** Suppose our evaluation relation is defined in the big-step style.
    State appropriate analogs of the progress and preservation
    properties. (You do not need to prove them.)

    Can you see any limitations of either of your properties?
    Do they allow for nonterminating commands?
    Why might we prefer the small-step semantics for stating
    preservation and progress?

(* FILL IN HERE *)
*)
(** [] *)

(** $Date: 2017-11-21 11:43:02 -0600 (Tue, 21 Nov 2017) $ *)


Require Import Coq.Program.Program.
Require Import datatypes.
Require Import Coq.Lists.List.
Require Import eqchain.

Definition fmap {F : PolyF} {μF A B : Type}
           {ia1 : F_initial_algebra F A μF}
           {ia2 : F_initial_algebra F B μF}
           (f : A -> B)
  := ⦇ in_ ∘ F❲ f ❳[id] ⦈.

Section data_functor.

  Variable (F : PolyF) (μF : Type) (A B C : Type)
           (ia1 : F_initial_algebra F A μF)
           (ia2 : F_initial_algebra F B μF)
           (ia3 : F_initial_algebra F C μF)
           (ia : F_initial_algebra F A μF).

  Theorem map_map_fusion :
    forall (f : A -> B) (g : B -> C),
      (fmap g) ∘ (fmap f) = fmap (g ∘ f).
  Proof.
    intros; unfold fmap.
    assert ( (fmap g) ∘ in_ ∘ F❲f❳[id] = in_ ∘ F❲g ∘ f❳[id] ∘ F❲id❳[fmap g] ) as H0.
    {
      unfold fmap.
      Left
      = ( ⦇in_ ∘ F❲g❳[id]⦈ ∘ in_ ∘ F❲f❳[id] ).
      = ( in_ ∘ (F❲g❳[id] ∘ F❲id❳[⦇in_ ∘ F❲g❳[id]⦈]) ∘ F❲f❳[id] )  { by cata_cancel }.
      = ( in_ ∘ (F❲g❳[⦇in_ ∘ F❲g❳[id]⦈] ∘ F❲f❳[id]) )  { by fmap_functor_dist }.
      = ( in_ ∘ (F❲g ∘ f❳[⦇in_ ∘ F❲g❳[id]⦈]) )  { by fmap_functor_dist }.
      = ( in_ ∘ (F❲g ∘ f❳[id] ∘ F❲id❳[⦇in_ ∘ F❲g❳[id]⦈]) )  { by fmap_functor_dist }.
      = Right.
    }
    unfold fmap in H0.
    Left
    = ( ⦇ in_ ∘ F❲g❳[id] ⦈ ∘ ⦇ in_ ∘ F❲f❳[id] ⦈ ).
    = ( ⦇in_ ∘ F ❲g ∘ f❳[id] ⦈ )  { apply cata_fusion }.
    = Right.
  Qed.

End data_functor.

Definition list_cata (A X : Type) (f : unit + (A * X) -> X) : (list A) -> X :=
  fix cata (la : list A)
    := match la with
       | nil       => f (inl tt)
       | cons a xs => f (inr (a, (cata xs)))
       end.

Definition list_in (A : Type) (ual : unit + (A * (list A))) : list A :=
  match ual with
  | inl tt => nil
  | inr al => let (a,l) := al in cons a l
  end.

Instance list_ia (A : Type)
  : F_initial_algebra (Sum one (Prod arg1 arg2)) A (list A) :=
  {
    cata := list_cata A;
    in_  := list_in A
  }.
Proof.
  intros. split.
  - intros H; extensionality l; induction l.
    + specialize (equal_f H (inl tt)) as H0.
      cbv in H0; cbv; easy.
    + specialize (equal_f H (inr (a, l))) as H0.
      cbv in H0; cbv. rewrite H0. rewrite IHl. easy.
  - intros H; extensionality l. induction l.
    + rewrite H; induction a; specialize (equal_f H []) as H0. easy.
    + rewrite H. induction b; specialize (equal_f H (cons a b)) as H0.
      easy.
Defined.

Eval cbv in (fmap (plus 10) [1 ; 2 ; 3 ; 4 ; 5]).


Set Loose Hint Behavior "Strict".

(* Adapted from http://poleiro.info/posts/2013-04-03-parse-errors-as-type-errors.html,
   https://github.com/arthuraa/poleiro/blob/master/theories/ForceOption.v
   to produce N instead of nat *)

Require Export Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.NArith.NArith.

Local Open Scope char_scope.

Local Open Scope N_scope.

Definition binDigitToN (c : ascii) : option N :=
  match c with
    | "0" => Some 0
    | "1" => Some 1
    | _   => None
  end.

Open Scope string_scope.

Fixpoint readBinNAux (s : string) (acc : N) : option N :=
  match s with
    | "" => Some acc
    | String c s' =>
      match binDigitToN c with
        | Some n => readBinNAux s' (2 * acc + n)
        | None => None
      end
  end.

Definition readBinN (s : string) : option N := readBinNAux s 0.

Goal readBinN "11111111" = Some 255.
Proof. reflexivity. Qed.

Definition forceOption A Err (o : option A) (err : Err) : match o with
                                                            | Some _ => A
                                                            | None => Err
                                                          end :=
  match o with
    | Some a => a
    | None => err
  end.

Inductive parseError := ParseError.

Definition bin (s : string) := forceOption N parseError (readBinN s) ParseError.

Goal bin"11111111" = 255.
Proof. reflexivity. Qed.

Goal bin"1011" = 11.
Proof. reflexivity. Qed.

Goal bin"1O" = ParseError.
Proof. reflexivity. Qed.


From CertiCoq.Plugin Require Import CertiCoq.

Require Import Arith PArith List String Ascii.
Require Import ExtLib.Data.String.

Import ListNotations.

(* Example 1: printing axioms *)

Axiom (print_nat : nat -> unit).
Axiom (print_str : string -> unit).
Axiom (new_line : unit -> unit).

Definition print_list (l : list nat) : unit :=
  let aux :=
      fix aux l :=
        match l with
        | [] => tt
        | [x] => print_nat x
        | x :: l =>
          let _ := print_nat x in
          let _ := print_str ";" in
          aux l
        end in
  let _ := print_str "[" in
  let _ := aux l in
  let _ := print_str "]" in new_line tt.

Definition print_lst := print_list [1;2;3;4;5].

CertiCoq Compile print_lst
Extract Constants [ print_nat => "print_gallina_nat", print_str => "print_gallina_string", new_line => "print_new_line" ]
Include [ "print.h" ].

(* Example 2: int 63 *)

Axiom (int63 : Type).
Axiom (add_int63 : int63 -> int63 -> int63).
Axiom (minus : int63 -> int63 -> int63).
Axiom (mul : int63 -> int63 -> int63).
Axiom (print_int63 : int63 -> unit).

Axiom (zero_int63 : int63).
Axiom (one_int63 : int63).

Fixpoint fib_aux (n : nat) (prev0 prev1 : int63) :=
  match n with
  | 0 => prev0
  | 1 => prev1
  | S n => fib_aux n prev1 (add_int63 prev0 prev1)
  end.

Definition fib (n : nat) := fib_aux n zero_int63 one_int63.

Definition fibn : unit :=
  let _ := print_int63 (fib 11) in
  new_line tt.

CertiCoq Compile fibn
Extract Constants [ add_int63 => "add_int63", zero_int63 => "zero_int63", one_int63 => "one_int63", print_int63 => "print_int63", new_line => "print_new_line" ]
Include [ "int63.h" ].

(* Example 3: list_sum with int63 -- add_int63 is first class *)

Definition list_sum_int63 :=
  let n := List.fold_left add_int63 (List.repeat one_int63 100) zero_int63 in
  let _ := print_int63 n in new_line tt.

CertiCoq Compile list_sum_int63
Extract Constants [ add_int63 => "add_int63", zero_int63 => "zero_int63", one_int63 => "one_int63", print_int63 => "print_int63", new_line => "print_new_line" ]
Include [ "int63.h" ].

(* "Dummy" example with tinfo (tifno is not used by the C function) *)

Definition list_sum_int63_tinfo :=
  let n := List.fold_left add_int63 (List.repeat one_int63 100) zero_int63 in
  let _ := print_int63 n in new_line tt.

CertiCoq Compile list_sum_int63_tinfo
Extract Constants [ add_int63 => "add_int63" with tinfo, zero_int63 => "zero_int63", one_int63 => "one_int63", print_int63 => "print_int63" with tinfo, new_line => "print_new_line" ]
Include [ "int63_tinfo.h" ].


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d : day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).

Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday :
  (next_weekday (next_weekday saturday)) = tuesday.
Proof. simpl. reflexivity. Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_Nil: forall (l: lst), append l Nil = l.
Proof.
  induction l.
  { simpl. f_equal. assumption. }
  { simpl. reflexivity. }
Qed.

Theorem append_assoc:
  forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
  induction l1; induction l2; induction l3; try (simpl; reflexivity).
  - simpl. rewrite <- IHl1. f_equal.
  - simpl. rewrite 2 append_Nil. reflexivity.
  - simpl. rewrite append_Nil.  reflexivity.
  - simpl. rewrite 2 append_Nil. reflexivity.
Qed.

Theorem append_rev_Cons:
  forall (l1 l2: lst) (x: natural),
    rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
  induction l1; induction l2; try (simpl; reflexivity).
  { intro. simpl. rewrite IHl1. simpl. lfind. Admitted.