(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
From Turing Require Import Lang.
From Turing Require Import Util.
Import LangNotations.
Import ListNotations.
Import Lang.Examples.
Open Scope lang_scope.
Open Scope char_scope.

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

(**

Show that any word that is in L4 is either empty or starts with "a".

 *)
Theorem ex1:
  forall w, L4 w -> w = [] \/ exists w', w = "a" :: w'.
Proof.
  simpl.
  intros N.
  intros O.
  induction O.
  unfold In, App in H.
  induction x.
  destruct H.
  destruct H.
  destruct H.
  destruct H0.
  inversion H0.
  inversion H1.
  - simpl.
    left.
    rewrite -> H.
    rewrite <- H3.
    rewrite <- H4.
    reflexivity.
  - simpl.
    right.
    destruct H.
    destruct H.
    destruct H.
    destruct H0.
    inversion H0.
    inversion H1.
    exists (w2 ++ w0 ++ w4).
    rewrite -> H.
    rewrite -> H5.
    rewrite -> H4.
    rewrite -> H10.
    simpl.
    reflexivity.
Qed.

(**

Show that the following word is accepted by the given language.

 *)
Theorem ex2:
  In ["a"; "b"; "b"; "a"] ("a" >> "b" * >> "a").
Proof.
  simpl.
  unfold In, Star, App.
  exists ["a" ; "b" ; "b"], ["a"].
  split.
  - simpl.
    reflexivity.
  - simpl.
    split.
    + simpl.
      exists ["a"], ["b" ; "b"].
      simpl.
      split.
      * simpl.
        reflexivity.
      * simpl.
        split.
        -- simpl.
           reflexivity.
        -- simpl.
           exists 2.
           apply pow_cons with (w1 := ["b"]) (w2 := ["b"]).
           ++ simpl.
              apply pow_cons with (w1 := ["b"]) (w2 := []).
              ** simpl.
                 apply pow_nil.
              ** simpl.
                 reflexivity.
              ** simpl.
                 reflexivity.
           ++ simpl.
              reflexivity.
           ++ simpl.
              reflexivity.
    + simpl.
      reflexivity.
Qed.

(**

Show that the following word is rejected by the given language.

 *)
Theorem ex3:
  ~ In ["b"; "b"] ("a" >> "b" * >> "a").
Proof.
  simpl.
  unfold not, In, Star, App.
  intros N.
  destruct N.
  destruct H.
  destruct H.
  destruct H0.
  destruct H0.
  destruct H0.
  destruct H0.
  destruct H2.
  destruct H3.
  unfold Char in H2, H1.
  subst.
  inversion H.
Qed.

(**

Show that the following language is empty.

 *)
Theorem ex4:
  "0" * >> {} == {}.
Proof.
  simpl.
  apply app_r_void_rw.
Qed.

(**

Rearrange the following terms. Hint use the distribution and absorption laws.

 *)
Theorem ex5:
  ("0" U Nil) >> ( "1" * ) == ( "0" >> "1" * ) U ( "1" * ).
Proof.
  simpl.
  unfold Equiv.
  intros N.
  split.
  - simpl.
    intros O.
    rewrite <- app_union_distr_l in O.
    rewrite app_l_nil_rw in O.
    apply O.
  - simpl.
    intros O.
    rewrite <- app_union_distr_l.
    rewrite app_l_nil_rw.
    apply O.
Qed.

(**

Show that the following langue only accepts two words.

 *)
Theorem ex6:
  ("0" >> "1" U "1" >> "0") == fun w => (w = ["0"; "1"] \/ w = ["1"; "0"]).
Proof.
  simpl.
  unfold Equiv.
  split.
  - simpl.
    unfold App, In, Union.
    intros N.
    destruct N.
    destruct H.
    destruct H.
    destruct H.
    destruct H0.
    unfold Char in H0.
    unfold Char in H1.
    + simpl.
      left.
      rewrite -> H.
      rewrite -> H0.
      rewrite -> H1.
      simpl.
      reflexivity.
    + simpl.
      destruct H.
      destruct H.
      destruct H.
      destruct H0.
      unfold Char in H0.
      unfold Char in H1.
      right.
      rewrite -> H.
      rewrite -> H0.
      rewrite -> H1.
      simpl.
      reflexivity.
  - simpl.
    unfold App, In, Union.
    intros N.
    destruct N.
    + left.
      exists ["0"].
      exists ["1"].
      split.
      ** simpl.
         rewrite -> H.
         reflexivity.
      ** simpl.
         unfold Char.
         split.
         --- simpl.
             reflexivity.
         --- simpl.
             reflexivity.
    + simpl.
      right.
      exists ["1"].
      exists ["0"].
      split.
      ** simpl.
         rewrite H.
         reflexivity.
      ** simpl.
         unfold Char.
         split.
         --- simpl.
             reflexivity.
         --- simpl.
             reflexivity.
Qed.

Theorem ex7:
  "b" >> ("a" U "b" U Nil) * >> Nil == "b" >> ("b" U "a") *.
Proof.
  simpl.
  split.
  - simpl.
    intros N.
    rewrite app_r_nil_rw in N.        (*opens last part*)
    rewrite union_sym_rw in N.        (*symmetric prop*)
    rewrite star_union_nil_rw in N.
    rewrite union_sym_rw.
    apply N.
  - simpl.
    intros N.
    rewrite app_r_nil_rw.
    rewrite union_sym_rw.
    rewrite star_union_nil_rw.
    rewrite union_sym_rw in N.
    apply N.
Qed.

Theorem ex8:
  (("b" >> ("a" U {}) ) U (Nil >> {} >> "c")* ) * == ("b" >> "a") *.
Proof.
  simpl.
  split.
  - simpl.
    intros N.
    rewrite union_r_void_rw in N.     (*open 2nd part*)
    rewrite app_r_void_rw in N.       (*open Nil part*)
    rewrite app_l_void_rw in N.       (*open last part*)
    rewrite star_void_rw in N.        (*open last part*)
    rewrite union_sym_rw in N.        (*symmetric prop*)
    rewrite star_union_nil_rw in N.
    apply N.
  - simpl.
    intros N.
    rewrite union_r_void_rw.
    rewrite app_r_void_rw.
    rewrite app_l_void_rw.
    rewrite star_void_rw.
    rewrite union_sym_rw.
    rewrite star_union_nil_rw.
    apply N.
Qed.


CoInductive LList (A:Set) : Set :=
 | LNil : LList A
 | LCons : A -> LList A -> LList A.

CoFixpoint repeat (A:Set) (x:A) : LList A :=
  LCons _ x (repeat A x).

CoFixpoint Lappend (A:Set) (l1 l2: LList A) : LList A :=
  match l1 with
    | LNil => l2
    | LCons x l1' => LCons _ x (Lappend _ l1' l2)
  end.

CoFixpoint repeat_General (A:Set) (l : LList A) : LList A :=
  (* Lappend _ l (repeat_General _ l).  <- This is wrong*)
  let cofix rpg (l l' : LList A) : LList A :=
      match l with
        | LCons x l'' => LCons _ x (rpg l'' l')
        | LNil =>
          match l' with
            | LNil => LNil _
            | LCons x l'' => LCons _ x (rpg l'' l')
          end
      end in rpg l l.

CoInductive LBT (A:Set) : Set :=
| lleaf : LBT A
| llbnode : A -> LBT A -> LBT A -> LBT A.

Definition Nats : LList nat :=
  let cofix natc (n : nat) : LList nat := LCons _ n (natc (S n)) in natc O.

CoFixpoint graft (A:Set) (t t': LBT A) : LBT A :=
  match t with
    | lleaf  => t'
    | llbnode x tl tr => llbnode _ x (graft _ tl t') (graft _ tr t')
  end.

CoInductive Stream (A:Set) : Set :=
  SCons : A -> Stream A -> Stream A.

Fixpoint CNth (n:nat) (A:Set) (l : Stream A) {struct n} : A :=
  match n with
    | O => match l with SCons x _ => x end
    | S n' => match l with SCons _ l' => CNth n' _ l' end
  end.

Definition NatS : Stream nat :=
  let cofix NatSC (n:nat) := SCons _ n (NatSC (S n)) in NatSC O.

Definition NatBTree : LBT nat :=
  let positive := match NatS with SCons _ x => x end in
  let cofix buildtree (n:nat) : LBT nat :=
      llbnode _ (CNth n _ positive) (buildtree (2*n+1)) (buildtree(2*n+2)) in
  buildtree 0.

CoFixpoint LMap (A B:Set) (f: A -> B) (l: LList A) : LList B :=
  match l with
    | LNil => LNil _
    | LCons x y => LCons _ (f x) (LMap _ _ f y)
  end.

Fixpoint LList_decompose_n (n:nat) (A:Set) (l:LList A) {struct n} : LList A :=
  match n with
    | O => l
    | S n' =>
      match l with
        | LNil => LNil _
        | LCons x l' => LCons _ x (LList_decompose_n n' _ l')
      end
  end.

Eval simpl in (repeat _ 33).
Eval simpl in (LList_decompose_n 5 _ (repeat _ 33)).

Theorem id_L_Decompose:
  forall (n:nat) (A:Set) (l:LList A),
    l = LList_decompose_n n A l.
  intro n. elim n. intros; simpl; trivial.
  intros. simpl. case l; auto. intros.
  rewrite <- (H _ l0). auto.
Qed.
Ltac LList_decompose term := apply trans_equal with (1 := id_L_Decompose 1 _ term).

Ltac LList_unfold := LList_decompose.

Ltac LList_unfold2 term := pattern term; rewrite (id_L_Decompose 1 _ term); simpl.
Theorem LAppend_LNil:
  forall (A:Set) (l:LList A), Lappend _ (LNil _) l = l.
  intros. LList_decompose (Lappend A (LNil A) l). simpl. case l; auto.
Qed.

Definition LAppend := Lappend.

Theorem LAppend_LCons :
  forall (A:Set) (a:A) (u v:LList A),
    LAppend _ (LCons _ a u) v = LCons _ a (LAppend _ u v).
  intros.
  LList_unfold (LAppend _ (LCons _ a u) v). auto.
Qed.

Hint Rewrite LAppend_LNil LAppend_LCons : llists.

CoFixpoint from (n:nat) : LList nat := LCons _ n (from (S n)).

Lemma from_unfold :
  forall (n:nat),
    from n = LCons _ n (from (S n)).
  intros.
  LList_unfold (from n); auto.
Qed.

Lemma repeat_unfold:
  forall (A:Set) (a:A),
    repeat _ a = LCons _ a (repeat _ a).
  intros; LList_unfold (repeat _ a); auto.
Qed.

CoFixpoint general_omega (A:Set) (u v:LList A) : LList A :=
  match v with
    | LNil => u
    | LCons b v' =>
      match u with
        | LNil => LCons _ b (general_omega _ v' v)
        | LCons a u' => LCons _ a (general_omega _ u' v)
      end
  end.

Definition omega (A:Set) (u: LList A) := general_omega _ u u.

Lemma general_omega_LNil :
  forall A:Set, omega _ (LNil A) = LNil _.
  intros. LList_unfold (omega A (LNil A)). simpl; auto.
Qed.

Lemma general_omega_LCons :
  forall (A:Set) (a:A) (u v:LList A),
    general_omega _ (LCons _ a u) v =  LCons _ a (general_omega _ u v).
  intros; autorewrite with llists. LList_unfold2 (general_omega A (LCons A a u) v).
  case v. LList_unfold2 (general_omega A u (LNil A)). case u; auto.
  trivial.
Qed.

Lemma general_omega_LNil_LCons :
  forall (A:Set) (a:A) (u:LList A),
    general_omega _ (LNil _) (LCons _ a u) = LCons _ a (general_omega _ u (LCons _ a u)).
  intros.
  LList_unfold2 (general_omega A (LNil A) (LCons A a u)). trivial.
Qed.

Lemma graft_works:
  forall (A:Set) (t:LBT A),
    graft _ (lleaf _) t = t.
  intros.
  refine
    ((fun (x: LBT A) (h : x = graft A (lleaf A) t) => _ ) (graft A (lleaf A) t) _).
Abort.

(* refine tactic -> remeber tactic *)

Inductive Finite (A:Set) : LList A -> Prop :=
| Finite_LNil : Finite A (LNil _)
| Finite_LCons :
    forall (a:A) (l:LList A), Finite A l -> Finite A (LCons _ a l).

Hint Resolve Finite_LNil Finite_LCons : llists.

Lemma one_two_three:
  Finite _ (LCons _ 1 (LCons _ 2 (LCons _ 3 (LNil _)))).
  auto with llists.
Qed.

Lemma Finite_of_LCons :
  forall (A:Set) (a:A) (l:LList A), Finite _ (LCons _ a l) -> Finite _ l.
  intros.
  inversion H; trivial.
Qed.

Lemma LAppend_of_Finite :
  forall (A:Set) (l l' :LList A),
    Finite _ l -> Finite _ l' -> Finite _ (LAppend _ l l').
  intros. generalize l' H0. elim H.
  intros. autorewrite with llists. trivial.
  intros. autorewrite with llists. auto with llists.
Qed.

Hint Rewrite from_unfold repeat_unfold general_omega_LNil general_omega_LCons general_omega_LNil_LCons: llists.

Lemma general_omega_shoots_again :
  forall (A:Set) (v:LList A),
    general_omega _ (LNil _) v = general_omega _ v v.
  intros.
  LList_unfold2 (general_omega A (LNil A) v). simpl. case v; autorewrite with llists.
  LList_unfold2 (general_omega A (LNil A) (LNil A)). trivial.
  intros. autorewrite with llists. trivial.
Qed.

Hint Rewrite general_omega_shoots_again : llists.

Theorem omega_and_append:
  forall (A:Set) (l1 l2:LList A),
    Finite _ l1 ->
    LAppend _ l1 (general_omega _ (LNil _) l2) = general_omega _ l1 l2.
  intros. elim H. autorewrite with llists; trivial.
  intros. autorewrite with llists. rewrite <- general_omega_shoots_again. rewrite H1. trivial.
Qed.

Theorem omega_of_Finite:
  forall (A:Set) (u:LList A),
    Finite _ u -> omega _ u = LAppend _ u (omega _ u).
  intros. elim H.   autorewrite with llists using auto with llists.
  intros. unfold omega. rewrite <- general_omega_shoots_again.
  pose (Finite_LCons _ a l H0). pose (omega_and_append _ (LCons _ a l) (LCons _ a l) f).
  rewrite e. autorewrite with llists. trivial.
Qed.

CoInductive Infinite {A:Set} : LList A -> Prop :=
  Infinite_LCons:
    forall (a:A) (x: LList A) , Infinite x -> Infinite (LCons _ a x).

Theorem LNil_dec:
  forall (A:Set) (l:LList A), {l = LNil _} + {l <> LNil _}.
  intros. case l. left; trivial.
  right. unfold not. intros. inversion H.
Qed.

Goal forall a:nat, Infinite (from a).
  refine
    (cofix inffrom (a:nat) : Infinite (from a) :=
       (fun (l : LList nat) (h: l = from a) =>
          match (LNil_dec _ l) return Infinite (from a) with
            | left HNil => _
            | right HNNil => _
          end) (from a) (eq_refl (from a))).
  rewrite h in HNil. generalize HNil. LList_unfold2 (from a).
  intros. inversion HNil0.
  LList_unfold2 (from a).
  apply Infinite_LCons.
  apply (inffrom (S a)).
Defined.

Lemma infinite_from :forall a:nat, Infinite (from a).
  refine
    (cofix inffrom (a:nat) : Infinite (from a) :=
       _).
  LList_unfold2 (from a).
  apply Infinite_LCons. apply (inffrom (S a)).
Defined.

Goal forall a:nat, Infinite (from a).
  cofix H.
  intros. LList_unfold2 (from a). apply Infinite_LCons.
  apply H.
Qed.

Lemma repeat_infinite:
  forall (A:Set) (a:A),
    Infinite (repeat _ a).
  cofix H.
  intros. LList_unfold2 (repeat A a). apply Infinite_LCons.
  apply H. Guarded.
Defined.

Lemma general_omega_infinite:
  forall (A:Set) (a:A) (u v:LList A),
    Infinite (general_omega _ v (LCons _ a u)).
  cofix H.
  intros.
  LList_unfold2 (general_omega A v (LCons A a u)).
  case v. apply Infinite_LCons. apply H.
  intros.
  apply Infinite_LCons. apply H.
Defined.

Theorem omega_infinite:
  forall (A:Set) (a:A) (l:LList A),
    Infinite (omega _ (LCons _ a l)).
  intros.
  unfold omega. apply general_omega_infinite.
Defined.

Theorem Infinite_of_LCons:
  forall (A:Set) (a:A) (u:LList A),
    Infinite (LCons _ a u) -> Infinite u.
  intros. inversion H. trivial.

Qed.

Theorem LNil_not_Infinite:
  forall A:Set, ~Infinite (LNil A).
  unfold not; intros.
  inversion H.
Qed.

Theorem LAppend_of_Infinite:
  forall (A:Set) (u:LList A),
    Infinite u -> forall v:LList A, Infinite (LAppend _ u v).
  cofix H.
  intros. inversion H0. autorewrite with llists. apply Infinite_LCons.
  apply H. auto.
Defined.

Theorem Finite_not_Infinite:
  forall (A:Set) (l:LList A),
    Finite _ l -> ~Infinite l.
  unfold not. intros A l h1. elim h1. intros h; inversion h.
  intros. apply H0. inversion H1; auto.
Qed.

Theorem Infinite_not_Finite:
  forall (A:Set) (l:LList A),
    Infinite l -> ~Finite _ l.
  unfold not; intros.
  pose (Finite_not_Infinite _ l H0).
  auto.
Qed.

Theorem not_Finite_Infinite:
  forall (A:Set) (l:LList A),
    ~Finite _ l -> Infinite l.
  cofix H.
  intros A l. case l. Focus 2.
  intros. apply Infinite_LCons.
  assert (~Finite A l0). auto with llists.
  apply (H _ l0 H1).
  unfold not. intros.
  assert (Finite A (LNil A)). auto with llists.
  elim (H0 H1).
Defined.

Require Import Classical.
(*
Lemma Not_Infinite_Finite:
  forall (A:Set) (l:LList A),
    ~Infinite l -> Finite _ l.
  pose not_Finite_Infinite.
  intros A l. apply or_to_imply.
  SearchPattern (_ -> ~~_).*)

Theorem PPNN:
  forall p:Prop, p -> ~~p.
  intros. unfold not. intros. elim (H0 H).
Qed.

(*
Theorem negation_truth:
  forall p q:Prop,
    (~p -> q) -> (~q -> p).
  intros.
*)

  (*
Lemma Not_Infinite_Finite:
  forall (A:Set) (l:LList A),
    ~Infinite l -> Finite _ l.
  pose not_Finite_Infinite.
  intros A l. apply or_to_imply.
  SearchPattern (_ \/ _ ->).*)

Theorem negation_truth:
  forall p q:Prop,
    (~p -> q) -> (~q -> p).
  intros. pose (imply_to_or _ _ H).
  elim o. apply NNPP.
  intros. elim (H0 H1).
Qed.

Lemma Not_Infinite_Finite:
  forall (A:Set) (l:LList A),
    ~Infinite l -> Finite _ l.
  intros A l. apply negation_truth.
  apply not_Finite_Infinite.
Qed.

Lemma imply_transitive_in_or:
  forall p q r:Prop,
    (p \/ q) -> (p -> r) -> (r \/ q).
  intros.
  elim H; tauto.
Qed.

Lemma Finite_or_Infinite:
  forall (A:Set) (l:LList A),
    Finite _ l \/ Infinite l.
  intros. apply imply_transitive_in_or with (p := ~Infinite l).
  tauto. apply Not_Infinite_Finite.
Qed.

Print ex.

Definition Infinite_ok (A:Set) (X:LList A -> Prop) :=
  forall l:LList A,
    X l -> exists a:A, (exists l' :LList A, l = LCons _ a l' /\ X l').

Definition Infinite1 (A:Set) (l:LList A) :=
  exists X:LList A -> Prop, Infinite_ok A X /\ X l.

CoInductive bisimilar {A:Set} : LList A -> LList A -> Prop :=
| bisim0 : bisimilar (LNil _) (LNil _)
| bisim1 : forall (a:A) (l l' :LList A), bisimilar l l' -> bisimilar (LCons _ a l) (LCons _ a l').

Hint Resolve bisim0 bisim1 : llists.

Require Import Relations.

Print equivalence.

Theorem equiv_bisimilar:
  forall (A:Set), equivalence (LList A) bisimilar.
  intros. split.
  unfold reflexive.  cofix H. intros. case x. apply bisim0. intros; apply bisim1; auto. Guarded.
  unfold transitive. cofix H. intros x y z. case x;case y; case z; try (intros; try (inversion H1); try (inversion H0)).
  apply bisim0. rewrite H5. apply bisim1. eapply H. apply H8. apply H3. Guarded.
  unfold symmetric. cofix H. intros x y.
  case x; case y; try (intros; try (inversion H0); try (inversion H1)).
  apply bisim0. apply bisim1. apply H. apply H2.
Qed.

Fixpoint LNth {A:Set} (n:nat) (l:LList A) {struct n} : option A :=
  match l with
    | LNil => None
    | LCons a l' =>
      match n with O => Some a | S p => LNth p l' end
  end.

Lemma bisimilar_LNth :
  forall (A:Set) (n:nat) (u v:LList A),
    bisimilar u v -> LNth n u = LNth n v.
  intros A n. elim n. intros; inversion H; auto.
  intros. inversion H0; auto. simpl. auto.
Qed.

Lemma LNth_bisimilar :
  forall (A:Set) (u v:LList A),
    (forall n:nat, LNth n u = LNth n v) -> bisimilar u v.
  cofix hh.
  intros A u v. case u;case v; intros. apply bisim0.
  pose (H 0). inversion e.
  pose (H 0). inversion e.
  pose (H 0). inversion e.
  apply bisim1.
  assert (forall n:nat, LNth n l0 = LNth n l).
  intros. pose (H (S n)). simpl in e0. apply e0.
  apply hh; apply H0.
Qed.

Theorem bisimilar_of_Finite_is_Finite :
  forall (A:Set) (l:LList A),
    Finite _ l -> forall l' :LList A, bisimilar l l' -> Finite _ l'.

  intros A l h1. elim h1. intros.  inversion H. auto with llists.
  intros a l0 h2 h3 l'. case l'. intros h; inversion h.
  intros. inversion H. auto with llists.
Qed.

Theorem bisimilar_of_Infinite_is_Infinite :
  forall (A:Set) (l:LList A),
    Infinite l -> forall l' : LList A, bisimilar l l' -> Infinite l'.

  cofix hh.
  intros A l h1 l'. inversion h1. case l; case l'; intros; try (inversion H0); try (inversion H1).
  apply Infinite_LCons. eapply hh. apply H. apply H4.
  apply Infinite_LCons. eapply hh. apply H. apply H4.
Qed.

Theorem bisimilar_of_Finite_is_eq:
  forall (A:Set) (l:LList A),
    Finite _ l -> forall l' :LList A, bisimilar l l' -> l = l'.
  intros A l h1. elim h1.
  intros. inversion H; auto.
  intros. inversion H1. pose (H0 l'0 H5).
  rewrite e; auto.
Qed.

Theorem LAppend_assoc:
  forall (A:Set) (u v w:LList A),
    bisimilar (LAppend _ u (LAppend _ v w)) (LAppend _ (LAppend _ u v) w).

  cofix hh.
  intros. case u;  case v. autorewrite with llists. apply equiv_bisimilar.
  intros; autorewrite with llists. apply equiv_bisimilar.
  intros; autorewrite with llists. apply bisim1. pose (hh A l (LNil _) w).
  assert (LAppend _ (LNil A) w = w). LList_unfold2 (LAppend _ (LNil A) w). case w; auto.
  rewrite H in b. apply b. Guarded.
  intros. autorewrite with llists. apply bisim1.
  assert (LCons _ a (LAppend A l w) = LAppend A (LCons _ a l) w); autorewrite with llists; trivial. Guarded.
  rewrite H. apply hh.
  Guarded.
Qed.

Lemma LAppend_of_Infinite_bisim :
  forall (A:Set) (u:LList A),
    Infinite u -> forall v:LList A, bisimilar u (LAppend _ u v).
  cofix hh.
  intros A u. case u. intros h1; inversion h1.
  intros. inversion H. autorewrite with llists. apply bisim1.
  apply hh. apply H1.
Qed.

Lemma general_omega_and_append:
  forall (A:Set) (l l' : LList A),
    bisimilar (LAppend _ l (general_omega _ (LNil _) l')) (general_omega _ l l').
  cofix hh.
  intros. case l. autorewrite with llists. apply equiv_bisimilar.
  intros; autorewrite with llists. apply bisim1.  rewrite <- general_omega_shoots_again.
  apply hh.
Qed.

Lemma omega_lappend:
  forall (A:Set) (u:LList A),
    bisimilar (omega _ u) (LAppend _ u (omega _ u)).
  unfold omega. intros. pattern (general_omega A u u). rewrite <- general_omega_shoots_again.
  pose general_omega_and_append.
  pose (b A u u).
  apply equiv_bisimilar. pattern (general_omega A (LNil A) u) at 2. rewrite general_omega_shoots_again. apply b0.
Qed.

Section LTL.
  Variables (A:Set) (a b c:A).
  Definition satisfies (l:LList A) (P: LList A -> Prop) := P l.

  Hint Unfold satisfies : llists.

  Inductive Atomic (At: A -> Prop) : LList A -> Prop :=
    Atomic_intro:
      forall (a:A) (l:LList A), At a -> Atomic At (LCons _ a l).

  Inductive Next (P : LList A -> Prop) : LList A -> Prop :=
    Next_intro :
      forall (a:A) (l:LList A), P l -> Next P (LCons _ a l).

  Hint Resolve Atomic_intro Next_intro : llists.

  Theorem Next_example :
    satisfies (LCons _ a (repeat _ b)) (Next (Atomic (eq b))).
    unfold satisfies. apply Next_intro. LList_unfold2 (repeat _ b). auto with llists.
  Qed.

  Inductive Eventually (P:LList A -> Prop ) : LList A -> Prop :=
  | Eventually_here :
      forall (a:A) (l:LList A), P (LCons _ a l) -> Eventually P (LCons _ a l)
  | Eventually_further :
      forall (a:A) (l:LList A), Eventually P l ->
                                Eventually P (LCons _ a l).

  CoInductive Always (P : LList A -> Prop) : LList A -> Prop :=
    Always_LCons :
      forall (a:A) (l:LList A),
        P (LCons _ a l) -> Always P l -> Always P (LCons _ a l).

Hint Resolve Eventually_here Eventually_further: llists.

  Lemma always_a :
    satisfies (repeat _ a) (Always (Atomic (eq a))).
    unfold satisfies. cofix hh.
    LList_unfold2 (repeat _ a).
    apply Always_LCons. apply Atomic_intro. reflexivity.
    apply hh. Guarded.
  Qed.

  Definition F_infinite (P:LList A -> Prop) : LList A -> Prop :=
    Always (Eventually P).

  Theorem always_a' :
      F_infinite (Atomic (eq a)) (omega _ (LCons _ a (LCons _ b (LNil _)))).
    unfold F_infinite.
    cofix hh.
    LList_unfold2 (omega _ (LCons _ a (LCons _ b (LNil _)))).
    apply Always_LCons. auto with llists.
    rewrite general_omega_LCons. apply Always_LCons. apply Eventually_further.
    rewrite general_omega_shoots_again. rewrite general_omega_LCons. apply Eventually_here. apply Atomic_intro. trivial. rewrite general_omega_shoots_again. apply hh. Guarded.
  Qed.

  Definition G_Infinite (P:LList A -> Prop) : LList A -> Prop :=
    Eventually (Always P).

  Lemma LAppend_G_Infinite :
    forall (P:LList A -> Prop) (u v :LList A),
      Finite _ u -> satisfies v (G_Infinite P) ->
      satisfies (LAppend _ u v) (G_Infinite P).
  Abort.

  Lemma LAppend_G_Infinite_R :
    forall (P:LList A -> Prop) (u v : LList A),
      Finite _ u -> satisfies (LAppend _ u v) (G_Infinite P) ->
      satisfies v (G_Infinite P).
  Abort.

End LTL.

Record automaton : Type :=
  mk_auto {
      states : Set ;
      actions : Set ;
      initial : states ;
      transitions : states -> actions -> list states
    }.

Definition deadlock (A:automaton) (q:states A) :=
  forall a:actions A, @transitions A q a = nil.

Require Import List.

CoInductive Trace (A:automaton) : states A -> LList (actions A) -> Prop :=
| empty_trace :
    forall q: states A, deadlock A q -> Trace A q (LNil _)
| lcons_trace :
    forall (q q' :states A) (a:actions A) (l:LList (actions A)),
      In q' (transitions A q a) -> Trace A q' l -> Trace A q' (LCons _ a l).

Set Implicit Arguments.

(* states *)
Inductive st : Set := q0 | q1 | q2.

(* actions *)
Inductive acts : Set := a | b.

(* transitions *)
Definition trans (q:st) (x:acts) : list st :=
  match q, x with
    | q0, a => cons q1 nil
    | q0, b => cons q1 nil
    | q1, a => cons q2 nil
    | q2, b => cons q2 (cons q1 nil)
    | _, _ => nil
  end.

Print mk_auto.

Definition A1 := mk_auto _ _ q0 trans.

Theorem Infinite_bs :
  forall (q:st) (t:LList acts),
    Trace A1 q t ->
    satisfies _ t (F_infinite _ (Atomic _ (eq b))).
  unfold satisfies.
  unfold F_infinite. cofix hh.
  intros. inversion H.
Abort.


(*****************************************************************************)
(*                                                                           *)
(*  Tensor.v                                                                 *)
(*                                                                           *)
(*  Tensors are represented as maps from tuples to values.                   *)
(*                                                                           *)
(*  For the purpose of discussing (memory) safety, it suffices to consider   *)
(*  only two values:                                                         *)
(*    (1) the undefined value 'VUndef', which represents a memory location   *)
(*        that does not carry a defined value; and                           *)
(*    (2) any other value 'VSome', which represents any and all              *)
(*        meaningfully defined memory locations.                             *)
(*                                                                           *)
(*  For a map from tuples to values to be considered a tensor, the map must  *)
(*  satisfy the 'DomainBound' predicate, which says that there is a (unique) *)
(*  tuple 't' such that the map is defined for all tuples below 't'          *)
(*  ("below" in the relation '.<=.', i.e. for all tuples 'i' with 'i.<=.t'). *)
(*                                                                           *)
(*****************************************************************************)

Require Import FunctionalExtensionality.
Require Import PeanoNat.

Require Import TensorIR.Tuple.Tuple.

Inductive Value : Set :=
  | VUndef : Value
  | VSome  : Value.

Definition DomainBound (x:Tuple -> Value) (t:Tuple) :=
  forall (i:Tuple), x i = VSome <-> i.<=.t.

Definition DomainBound_undef (x:Tuple -> Value) (t:Tuple) :=
  forall (i:Tuple), x i <> VUndef <-> i.<=.t.

Definition DomainBound_nle (x:Tuple -> Value) (t:Tuple) :=
  forall (i:Tuple), x i = VUndef <-> ~i.<=.t.

Definition Tensor : Set :=
  {x:Tuple -> Value | exists (t:Tuple), DomainBound x t}.

Lemma ten_some_not_undef : forall (x:Tuple -> Value) (i:Tuple),
  x i = VSome <-> x i <> VUndef.
Proof with auto.
  intuition. rewrite H in H0. inversion H0.
  destruct (x i) eqn:xieq... contradiction.
Qed.

Lemma ten_undef_not_some : forall (x:Tuple -> Value) (i:Tuple),
  x i = VUndef <-> x i <> VSome.
Proof with auto.
  intuition. rewrite H in H0. inversion H0.
  destruct (x i) eqn:xieq... contradiction.
Qed.

(* Equivalence of the different versions of 'DomainBound': *)

Lemma ten_domain_domain_undef : forall (x:Tuple -> Value) (t: Tuple),
  DomainBound x t <-> DomainBound_undef x t.
Proof with auto.
  unfold DomainBound_undef. unfold DomainBound. intuition.
  apply ten_some_not_undef in H0; apply H in H0...
  apply H in H0; apply ten_some_not_undef in H0...
  apply ten_some_not_undef in H0; apply H in H0...
  destruct (x i) eqn:xieq... apply H in xieq... contradiction.
Qed.

Lemma ten_domain_undef_domain_nle : forall (x:Tuple -> Value) (t: Tuple),
  DomainBound_undef x t <-> DomainBound_nle x t.
Proof with auto.
  unfold DomainBound_undef. unfold DomainBound_nle. intuition.
  apply H in H1...
  destruct (x i) eqn:xieq... rewrite ten_some_not_undef in xieq.
    apply H in xieq. contradiction.
  destruct (tup_le_dec i t)... apply H in n. contradiction.
  apply H in H1...
Qed.

Lemma ten_domain_nle_domain : forall (x:Tuple -> Value) (t: Tuple),
  DomainBound_nle x t <-> DomainBound x t.
Proof with auto.
  unfold DomainBound_nle. unfold DomainBound. intuition...
  destruct (tup_le_dec i t)... apply H in n. rewrite H0 in n. inversion n.
  apply ten_some_not_undef. destruct (x i) eqn:xieq.
    apply H in xieq... intro F; inversion F.
  apply H in H1. rewrite H0 in H1. inversion H1.
  destruct (x i) eqn:xieq... apply H in xieq. contradiction.
Qed.

Open Scope list_scope.

(* Tensors with a bound of '[]' (i.e. the empty tuple) have exactly *)
(* one entry. Such tensors should be thought of as scalars:         *)

Theorem ten_domain_one_entry : forall (x:Tuple -> Value),
  DomainBound x [] -> x [] = VSome /\ forall i, i <> [] -> x i = VUndef.
Proof with auto.
  intuition.
  destruct (x []) eqn:xnileq... rewrite ten_domain_domain_undef in H.
    apply H in xnileq. contradiction. simpl; trivial.
  destruct (x i) eqn:xieq...
    apply H in xieq. destruct i; contradiction.
Qed.

(* The proof of uniqueness of the tuple (i.e. the bound) *)
(* in 'DomainBound' is split into a couple of lemmas :   *)

Definition ten_projection (x:Tuple -> Value) (i:nat) := fun j => x (i::j).

Lemma ten_projection_domain :
  forall (t:Tuple) (n i:nat) (x:Tuple -> Value),
  DomainBound x (n::t) -> i <= n ->
    DomainBound (ten_projection x i) t.
Proof with auto.
  intros. unfold DomainBound in H. unfold DomainBound. intuition.
  apply H in H1. simpl in H1. destruct H1...
  assert((i::i0).<=.(n::t)). simpl...
  apply H in H2...
Qed.

(* Helper lemma for the uniqueness of bounds: *)

Lemma ten_domain_unique' : forall (m n:nat) (t t':Tuple) (x:Tuple -> Value),
  DomainBound x (m::t) ->
  DomainBound x (n::t') ->
    m = n.
Proof with auto.
  intuition.
  destruct (Compare_dec.lt_eq_lt_dec m n). destruct s...
    destruct (x (n::t')) eqn:xeq.
      assert((n::t').<=.(n::t')) by apply tup_le_refl. apply H0 in H1.
        rewrite xeq in H1. inversion H1.
      assert(~(n::t').<=.(m::t)). intro. destruct H1.
        apply (Nat.lt_le_trans m n m l) in H1. apply Nat.lt_irrefl in H1...
          rewrite <- ten_domain_nle_domain in H. apply H in H1.
            rewrite xeq in H1. inversion H1.
    destruct (x (m::t)) eqn:xeq.
      assert((m::t).<=.(m::t)) by apply tup_le_refl. apply H in H1.
        rewrite xeq in H1. inversion H1.
      assert(~(m::t).<=.(n::t')). intro. destruct H1.
        apply (Nat.lt_le_trans n m n l) in H1. apply Nat.lt_irrefl in H1...
          rewrite <- ten_domain_nle_domain in H0. apply H0 in H1.
            rewrite xeq in H1. inversion H1.
Qed.

(* Finally, uniqueness lemma for bounds in 'DomainBound': *)

Theorem ten_domain_unique : forall (t t':Tuple) (x:Tuple -> Value),
  DomainBound x t ->
  DomainBound x t' ->
    t = t'.
Proof with auto.
  induction t. destruct t'; intuition.
    destruct (x (n::t')) eqn:xeq.
      assert((n::t').<=.(n::t')) by apply tup_le_refl. apply H0 in H1.
      rewrite xeq in H1. inversion H1.
      apply H in xeq. inversion xeq.
    intuition. destruct t'.
      destruct (x (a::t)) eqn:xeq.
        assert((a::t).<=.(a::t)) by apply tup_le_refl. apply H in H1.
        rewrite xeq in H1. inversion H1.
        apply H0 in xeq. inversion xeq.
    pose proof (ten_domain_unique' a n _ _ x H H0). subst.
      pose proof (ten_projection_domain _ _ _ _ H (Nat.le_refl n)).
      pose proof (ten_projection_domain _ _ _ _ H0 (Nat.le_refl n)).
      apply (IHt _ _ H1) in H2. subst...
Qed.

(* The following definition constructs a tensor from a given bound 't'. *)
(* Since 'VSome' is the only meaningful value, there is precisely one   *)
(* tensor for any given bound 't'.                                      *)

Definition ten_tensor_from_tuple (t:Tuple) : Tensor.
  refine(exist _ (fun i => if i.<=?.t then VSome else VUndef) _).
Proof with auto.
  exists t. unfold DomainBound. intro i.
  destruct (i.<=?.t) eqn:iteq.
    apply tup_le_leb in iteq. intuition.
    intuition. inversion H. apply tup_nle_nleb in H... inversion H.
Defined.

Lemma ten_from_tuple_bound : forall (t:Tuple),
  DomainBound (proj1_sig (ten_tensor_from_tuple t)) t.
Proof with auto.
  simpl. unfold DomainBound. split.
  destruct (i.<=?.t) eqn:itle. apply tup_le_leb in itle... inversion 1.
  intro H. destruct (i.<=?.t) eqn:itle... apply tup_nle_nleb in itle.
    contradiction.
Qed.

(* The following uniqueness lemma relies on functional extensionality: *)

Lemma ten_tensor_unique : forall (t:Tuple) (x:Tuple -> Value),
  DomainBound x t -> x = proj1_sig (ten_tensor_from_tuple t).
Proof with auto.
  intuition. simpl. apply functional_extensionality. intro i.
  destruct (i.<=?.t) eqn:itle.
    apply tup_le_leb in itle. apply H in itle...
    apply tup_nle_nleb in itle. apply ten_domain_nle_domain in H.
      unfold DomainBound_nle in H. apply H in itle...
Qed.

Close Scope list_scope.


Require Coq.Structures.Equalities.
Require Coq.Strings.String.

Require Genevan.ProtoVersion.
Require Genevan.ProtoName.

(** * Protocol Identifier *)

(** A protocol identifier combines a _protocol name_ and a _protocol version_. *)

Record t := {
  name    : ProtoName.t;
  version : ProtoVersion.t;
}.

(** A protocol _x_ is _compatible_ with a protocol _y_ if both protocols have
    the same name, and both have compatible versions. *)

Definition isCompatibleWith (x y : t) : Prop :=
  name x = name y /\ ProtoVersion.isCompatibleWith (version x) (version y).

(** The _isCompatibleWith_ relation is reflexive. *)

Theorem isCompatibleWith_reflexive : forall x,
  isCompatibleWith x x.
Proof.
  intro x.
  constructor.
  reflexivity.
  apply ProtoVersion.isCompatibleWith_reflexive.
Qed.

(** The _isCompatibleWith_ relation is symmetric. *)

Theorem isCompatibleWith_symmetric : forall x y,
  isCompatibleWith x y -> isCompatibleWith y x.
Proof.
  intros x y [Hxy0 Hxy1].
  constructor.
  symmetry; exact Hxy0.
  apply (ProtoVersion.isCompatibleWith_symmetric _ _ Hxy1).
Qed.

(** The _isCompatibleWith_ relation is transitive. *)

Theorem isCompatibleWith_transitive : forall x y z,
  isCompatibleWith x y -> isCompatibleWith y z -> isCompatibleWith x z.
Proof.
  intros x y z [Hxy0 Hxy1] [Hyz0 Hyz1].
  constructor.
  - rewrite Hxy0.
    exact Hyz0.
  - apply (ProtoVersion.isCompatibleWith_transitive _ _ _ Hxy1 Hyz1).
Qed.

(** Therefore, the _isCompatibleWith_ relation is an equivalence relation. *)

Theorem isCompatibleWith_Eq : RelationClasses.Equivalence isCompatibleWith.
Proof.
  constructor.
  exact isCompatibleWith_reflexive.
  exact isCompatibleWith_symmetric.
  exact isCompatibleWith_transitive.
Qed.

(** Protocol identifiers have decidable equality. *)

Module Dec : Equalities.UsualDecidableType
  with Definition t := t.

  Definition t := t.
  Definition eq       := @Logic.eq t.
  Definition eq_refl  := @Logic.eq_refl t.
  Definition eq_sym   := @Logic.eq_sym t.
  Definition eq_trans := @Logic.eq_trans t.

  #[local]
  Instance eq_equiv : RelationClasses.Equivalence eq := { }.

  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
  Proof.
    intros x y.
    destruct (String.string_dec (name x) (name y)) as [HnL|HnR]. {
      destruct (ProtoVersion.Ord.eq_dec (version x) (version y)) as [HvL|HvR]. {
        left.
        destruct x as [xn xv].
        destruct y as [yn yv].
        simpl in *.
        rewrite HnL in *.
        rewrite HvL in *.
        reflexivity.
      } {
        destruct x as [xn xv].
        destruct y as [yn yv].
        simpl in *.
        subst xn.
        right.
        unfold not; intro Hcontra; simpl in *.
        assert (xv = yv) by congruence.
        contradiction.
      }
    } {
      destruct x as [xn xv].
      destruct y as [yn yv].
      simpl in *.
      right.
      unfold not; intro Hcontra; simpl in *.
      assert (xn = yn) by congruence.
      contradiction.
    }
  Qed.

End Dec.


Require Import Coq.Bool.Sumbool.
Require Import Coq.micromega.Lia.
Require Import Coq.NArith.NArith.
Require Import Coq.PArith.PArith.
Require Import Coq.Lists.List.
Require Import Coq.Init.Wf.

Local Open Scope positive_scope.

(* given [n] and [d₀], returns, possibly, [d, v] where [d ≥ d₀] is small and [d * v = n]

   Precondition: [d₀] is either 2, or an odd number > 2 *)
Definition find_N_factor (factor_val : N) (d0 : N) : option (N * N).
Proof.
  refine (let (d', r) := N.div_eucl factor_val d0 in (* special-case the first one, which might be 2 *)
          if N.eqb 0 r
          then Some (d0, d')
          else
            let sfactor_val := N.sqrt factor_val in
            Fix
              (Acc_intro_generator (S (S (S (N.to_nat (N.div2 sfactor_val))))) (@N.gt_wf sfactor_val)) (fun _ => option (N * N)%type)
              (fun d find_N_factor
               => let (d', r) := N.div_eucl factor_val d in
                  if N.eqb 0 r
                  then Some (d, d')
                  else let d' := (d + 2)%N in
                       if Sumbool.sumbool_of_bool (N.leb d' sfactor_val)
                       then find_N_factor d' _
                       else None)
              (if N.eqb 2%N d0 then 3%N else (d0 + 2)%N)).
  { subst sfactor_val d'.
    clear find_N_factor.
    let H := match goal with H : _ = true |- _ => H end in
    clear -H;
      abstract (
          apply N.leb_le in H;
          split; try assumption;
          lia
        ). }
Defined.

(* given [n] and [d₀], gives a list of factors of [n] which are ≥ d₀, lowest to highest *)
Definition factorize' (n : N) : N -> list N.
Proof.
  refine (Fix
            (Acc_intro_generator (S (S (S (S (N.to_nat (N.div2 (N.sqrt n))))))) N.lt_wf_0) (fun _ => N -> list N)
            (fun n factorize cur_max_factor
             => _)
            n).
  refine match find_N_factor n cur_max_factor with
         | Some (d, n') => if Sumbool.sumbool_of_bool (n' <? n)%N
                           then d :: factorize n' _ d
                           else d :: n' :: nil
         | None => n::nil
         end.
  { let H := match goal with H : _ = true |- _ => H end in
    clear -H;
      abstract (
          apply N.ltb_lt in H;
          assumption
        ). }
Defined.

Definition factorize (n : N) : list N := factorize' n 2%N.

Definition factorize_or_fail (n:N) : option (list N) :=
  let factors := factorize n in
  if N.eqb (List.fold_right N.mul 1%N factors) n then Some factors else None.
Lemma product_factorize_or_fail (n:N) (factors:list N)
      (H:Logic.eq (factorize_or_fail n) (Some factors))
  : Logic.eq (List.fold_right N.mul 1%N factors) n.
Proof.  cbv [factorize_or_fail] in H; destruct ((fold_right N.mul 1 (factorize n) =? n)%N) eqn:?;
          try apply N.eqb_eq; congruence. Qed.


Require Import List.

#[local] Notation "x 'el' L" := (In x L) (at level 70).

(** Minimal separation logic **)

(** Syntax **)

Definition sp_term := option nat.

Inductive msp_form :=
| mpointer : sp_term -> sp_term -> sp_term -> msp_form (* weak binary pointer *)
| mbot : msp_form
| mimp : msp_form -> msp_form -> msp_form
| mand : msp_form -> msp_form -> msp_form
| mor : msp_form -> msp_form -> msp_form
| mall : msp_form -> msp_form
| mex : msp_form -> msp_form.

(** Semantics **)

Definition val := option nat.
Definition stack := nat -> val.
Definition heap := list (nat * (val * val)).

Definition sp_eval (s : stack) (t : sp_term) : val :=
  match t with Some x => s x | None => None end.

Definition update_stack (s : stack) v :=
  fun x => match x with 0 => v | S x => s x end.

Fixpoint msp_sat (s : stack) (h : heap) (P : msp_form) :=
  match P with
  | mpointer E E1 E2 => exists l, sp_eval s E = Some l /\ (l, (sp_eval s E1, sp_eval s E2)) el h
  | mbot => False
  | mimp P1 P2 => msp_sat s h P1 -> msp_sat s h P2
  | mand P1 P2 => msp_sat s h P1 /\ msp_sat s h P2
  | mor P1 P2 => msp_sat s h P1 \/ msp_sat s h P2
  | mall P => forall v, msp_sat (update_stack s v) h P
  | mex P => exists v, msp_sat (update_stack s v) h P
  end.

(** Satisfiability problem **)

Definition functional (h : heap) :=
  forall l p p', (l, p) el h -> (l, p') el h -> p = p'.

Definition MSLSAT (P : msp_form) :=
  exists s h, functional h /\ msp_sat s h P.


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

Require Import Arith.

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

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 less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.
Fixpoint eqb (n m: natural) : bool :=
match n, m with
   | Zero, Zero => true
   | Zero, Succ _ => false
   | Succ _, Zero => false
   | Succ n', Succ m' => eqb n' m'
end.
Fixpoint mem (mem_arg0 : natural) (mem_arg1 : lst) : bool
           := match mem_arg0, mem_arg1 with
              | x, Nil => false
              | x, Cons y z => orb (eqb x y) (mem x z)
              end.

Fixpoint insort (insort_arg0 : natural) (insort_arg1 : lst) : lst
           := match insort_arg0, insort_arg1 with
              | i, Nil => Cons i Nil
              | i, Cons x y => if less i x then Cons i (Cons x y) else Cons x (insort i y)
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort x (sort y)
              end.
Lemma Nat_beq_eq : forall (x y : natural), eqb x y = true -> x = y.
Proof.
   intros.
   generalize dependent y.
   induction x.

   - intros. destruct y.
   + simpl in H. apply IHx in H. rewrite H. reflexivity.
   + discriminate.

   - intros. destruct y.
   + discriminate.
   + reflexivity.

Qed.
(* Requires No helper lemma, the apply is in the hypothesis *)
Theorem theorem0 : forall (x : natural) (y : natural) (z : lst), not (eq x y) -> eq (mem x (insort y z)) true -> eq (mem x z) true.
Proof.
   intros.
   induction z.
   - simpl in H0. simpl. destruct (less y n) eqn:?.
   + simpl in H0. apply Bool.orb_true_iff in H0. destruct H0.
lfind.  contradiction.
Admitted.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Supplementary Coq material: polymorphism and generic data structures
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

Set Implicit Arguments.
(* This command sets up automatic inference of tedious arguments. *)

(* One of the recurring ingredients in effective machine formalization is data
 * structures, and, as in general programming, we want to be able to define data
 * structures that are *generic* in the kinds of data they contain.  Coq
 * supports such things in roughly the same way as Haskell and OCaml, via
 * *parametric polymorphism*, which is closely related to the idea of *generics*
 * in languages like Java. *)

(* Our first example: the [option] type family.  While Java and friends force
 * all sorts of different types to include the special value [null], in Coq we
 * request that option explicitly by wrapping a type in [option].  Specifically,
 * any value of type [option A], for some type [A], is either [None] (sort of
 * like [null]) or [Some v] for a [v] of type [A]. *)
Inductive option (A : Set) : Set :=
| None
| Some (v : A).

Arguments None {A}.
(* This command asks Coq to *infer* the [A] type for each specific use of
 * [None]. *)

(* Here are a few example terms using [option]. *)
Example no_number : option nat := None.
Example a_number : option nat := Some 42.
Example no_number_squared : option (option nat) := None.
Example no_number_squared_inside : option (option nat) := Some None.
Example a_number_squared : option (option nat) := Some (Some 42).

(* Pattern matching is the key ingredient for working with inductive definitions
 * of all sorts.  Here are some examples matching on [option]s. *)

Definition increment_optional (no : option nat) : option nat :=
  match no with
  | None => None
  | Some n => Some (n + 1)
  end.

(* Here we use type [A * B] of *pairs*, inhabited by values [(a, b)], with
 * [a : A] and [b : B]. *)
Definition add_optional (po : option (nat * nat)) : option nat :=
  match po with
  | None => None
  | Some (n, m) => Some (n + m)
  end.

(** * Lists *)

(* For functional programming (as in Coq), the king of all generic data
 * structures is the *list*. *)
Inductive list (A : Set) : Set :=
| nil
| cons (hd : A) (tl : list A).

Arguments nil {A}.

(* [nil] is the empty list, while [cons], standing for "construct," extends a
 * list of length [n] into one of length [n+1]. *)

(* Here are some simple lists. *)

Example nats0 : list nat := nil.
Example nats1 : list nat := cons 1 nil.
Example nats2 : list nat := cons 1 (cons 2 nil).

(* Coq features a wonderful notation system, to help us write more concise and
 * readable code after introducing new syntactic forms.  We will not give a
 * systematic presentation of the notation system, but we will show many
 * examples, from which it is possible to infer generality by scientific
 * induction.  And, of course, the interested reader can always check the
 * notations chapter of the Coq reference manual. *)

(* First, our examples can get more readable with an infix operator for [cons]. *)

Infix "::" := cons.

Example nats1' : list nat := 1 :: nil.
Example nats2' : list nat := 1 :: 2 :: nil.

(* Getting even more fancy, we declare a notation for list literals. *)

Notation "[ ]" := nil.
Notation "[ x1 ; .. ; xN ]" := (cons x1 (.. (cons xN nil) ..)).

Example nats0'' : list nat := [].
Example nats1'' : list nat := [1].
Example nats2'' : list nat := [1; 2].
Example nats3'' : list nat := [1; 2; 3].

(* Here are some classic recursive functions that operate over lists.
 * First, here is how to compute the length of a list.  We put *implicit*
 * function arguments in curly braces, asking Coq to infer them at call
 * sites. *)

Fixpoint length {A} (ls : list A) : nat :=
  match ls with
  | nil => 0
  | _ :: ls' => 1 + length ls'
  end.

(* Here are two classic recursive functions on lists. *)

(* First, concatenation: *)
Fixpoint app {A} (ls1 ls2 : list A) : list A :=
  match ls1 with
  | nil => ls2
  | x :: ls1' => x :: app ls1' ls2
  end.

Infix "++" := app.

(* Next, reversal: *)
Fixpoint rev {A} (ls : list A) : list A :=
  match ls with
  | nil => nil
  | x :: ls' => rev ls' ++ [x]
  end.

Theorem length_app : forall A (ls1 ls2 : list A),
    length (ls1 ++ ls2) = length ls1 + length ls2.
Proof.
  induct ls1; simplify; equality.
Qed.

(* One of the classic gotchas in functional-programming class is how slow this
 * naive [rev] is.  Each [app] operation requires linear time, so running
 * linearly many [app]s brings us to quadratic time for [rev].  Using a helper
 * function, we can bring [rev] to its optimal linear time. *)

Fixpoint rev_append {A} (ls acc : list A) : list A :=
  match ls with
  | nil => acc
  | x :: ls' => rev_append ls' (x :: acc)
  end.

(* This function [rev_append] takes an extra *accumulator* argument, in which we
 * gradually build up the original input in reversed order.  The base case just
 * returns the accumulator.  Now reversal just needs to do a [rev_append] with
 * an empty initial accumulator. *)

Definition rev' {A} (ls : list A) : list A :=
  rev_append ls [].

(* A few test cases can help convince us that this seems to work. *)

Compute rev [1; 2; 3; 4].
Compute rev' [1; 2; 3; 4].
Compute rev ["hi"; "bye"; "sky"].
Compute rev' ["hi"; "bye"; "sky"].

(* OK, great.  Now it seems worth investing in a correctness proof.  We'll
 * discover it interactively in class, but here's a worked-out final
 * answer, with the several lemmas that we discover are useful. *)

(* List concatenation is associative. *)
Lemma app_assoc : forall A (ls1 ls2 ls3 : list A),
    (ls1 ++ ls2) ++ ls3 = ls1 ++ (ls2 ++ ls3).
Proof.
  induct ls1; simplify.

  equality.

  rewrite IHls1.
  equality.
Qed.

(* The natural correctness condition for [rev_append]: it does what it says on
 * the package, combining reversal with appending! *)
Lemma rev_append_ok : forall A (ls acc : list A),
    rev_append ls acc = rev ls ++ acc.
Proof.
  induct ls; simplify.

  equality.

  rewrite IHls.
  simplify.
  rewrite app_assoc.
  simplify.
  equality.
Qed.

(* IMPORTANT NOTE: the proof above would *not* have worked with the orders of
 * variables [ls] and [acc] swapped in the lemma statement!  Try the proof that
 * way to see what goes wrong.  The problem is that the induction hypothesis
 * would be too weak.  A single [acc] value would be fixed for the whole proof,
 * while we need [acc] to *vary* throughout the induction, by retaining a
 * universal quantifier for it in the IH. *)

(* Concatenating the empty list has no effect. *)
Lemma app_nil : forall A (ls : list A),
    ls ++ [] = ls.
Proof.
  induct ls; simplify.

  equality.

  equality.
Qed.

(* Now we can prove equivalence of [rev'] and [rev], with no new induction. *)
Theorem rev'_ok : forall A (ls : list A),
    rev' ls = rev ls.
Proof.
  simplify.
  unfold rev'.
  rewrite rev_append_ok.
  apply app_nil.
Qed.

(** ** Zipping and unzipping *)

(* Another classic pair of list operations is zipping and unzipping.
 * These functions convert between pairs of lists and lists of pairs. *)

Fixpoint zip {A1 A2} (ls1 : list A1) (ls2 : list A2) : list (A1 * A2) :=
  match ls1, ls2 with
  | x1 :: ls1', x2 :: ls2' => (x1, x2) :: zip ls1' ls2'
  | _, _ => []
  end.
(* Note how, when passed two lengths of different lists, [zip] drops the
 * mismatched suffix of the longer list. *)

(* An explicit [Set] annotation is needed here, for obscure type-inference
 * reasons. *)
Fixpoint unzip {A1 A2 : Set} (ls : list (A1 * A2)) : list A1 * list A2 :=
  match ls with
  | [] => ([], [])
  | (x1, x2) :: ls' =>
    let (ls1, ls2) := unzip ls' in
    (x1 :: ls1, x2 :: ls2)
  end.

(* A few common-sense properties hold of these definitions. *)

Theorem length_zip : forall A1 A2 (ls1 : list A1) (ls2 : list A2),
    length (zip ls1 ls2) = min (length ls1) (length ls2).
Proof.
  induct ls1; simplify.

  linear_arithmetic.

  cases ls2; simplify.

  linear_arithmetic.

  rewrite IHls1.
  linear_arithmetic.
Qed.

(* We write [fst] and [snd] for the first and second projection operators on
 * pairs, respectively. *)

Theorem length_unzip1 : forall (A1 A2 : Set) (ls : list (A1 * A2)),
    length (fst (unzip ls)) = length ls.
Proof.
  induct ls; simplify.

  equality.

  cases hd.
  (* Note that [cases] allows us to pull apart a pair into its two pieces. *)
  cases (unzip ls).
  simplify.
  equality.
Qed.

Theorem length_unzip2 : forall (A1 A2 : Set) (ls : list (A1 * A2)),
    length (snd (unzip ls)) = length ls.
Proof.
  induct ls; simplify.

  equality.

  cases hd.
  cases (unzip ls).
  simplify.
  equality.
Qed.

Theorem zip_unzip : forall (A1 A2 : Set) (ls : list (A1 * A2)),
    (let (ls1, ls2) := unzip ls in zip ls1 ls2) = ls.
Proof.
  induct ls; simplify.

  equality.

  cases hd.
  cases (unzip ls).
  simplify.
  equality.
Qed.

(* There are also interesting interactions with [app] and [rev]. *)

Theorem unzip_app : forall (A1 A2 : Set) (x y : list (A1 * A2)),
    unzip (x ++ y)
    = (let (x1, x2) := unzip x in
       let (y1, y2) := unzip y in
       (x1 ++ y1, x2 ++ y2)).
Proof.
  induct x; simplify.

  cases (unzip y).
  equality.

  cases hd.
  cases (unzip x).
  simplify.
  rewrite IHx.
  cases (unzip y).
  equality.
Qed.

Theorem unzip_rev : forall (A1 A2 : Set) (ls : list (A1 * A2)),
    unzip (rev ls) = (let (ls1, ls2) := unzip ls in
                      (rev ls1, rev ls2)).
Proof.
  induct ls; simplify.

  equality.

  cases hd.
  cases (unzip ls).
  simplify.
  rewrite unzip_app.
  rewrite IHls.
  simplify.
  equality.
Qed.

(** * Binary trees *)

(* Another classic datatype is binary trees, which we can define like so. *)
Inductive tree (A : Set) : Set :=
| Leaf
| Node (l : tree A) (d : A) (r : tree A).

Arguments Leaf {A}.

Example tr1 : tree nat := Node (Node Leaf 7 Leaf) 8 (Node Leaf 9 (Node Leaf 10 Leaf)).

(* There is a natural notion of size of a tree. *)
Fixpoint size {A} (t : tree A) : nat :=
  match t with
  | Leaf => 0
  | Node l _ r => 1 + size l + size r
  end.

(* There is also a natural sense of reversing a tree, flipping it around its
 * vertical axis. *)
Fixpoint reverse {A} (t : tree A) : tree A :=
  match t with
  | Leaf => Leaf
  | Node l d r => Node (reverse r) d (reverse l)
  end.

(* There is a natural relationship between the two. *)
Theorem size_reverse : forall A (t : tree A),
    size (reverse t) = size t.
Proof.
  induct t; simplify.

  equality.

  linear_arithmetic.
Qed.

(* Another classic tree operation is flattening into lists. *)
Fixpoint flatten {A} (t : tree A) : list A :=
  match t with
  | Leaf => []
  | Node l d r => flatten l ++ d :: flatten r
  end.
(* Note here that operators [++] and [::] are right-associative. *)

Theorem length_flatten : forall A (t : tree A),
    length (flatten t) = size t.
Proof.
  induct t; simplify.

  equality.

  rewrite length_app.
  simplify.
  linear_arithmetic.
Qed.

Lemma rev_app : forall A (ls1 ls2 : list A),
    rev (ls1 ++ ls2) = rev ls2 ++ rev ls1.
Proof.
  induct ls1; simplify.

  rewrite app_nil.
  equality.

  rewrite IHls1.
  apply app_assoc.
Qed.

Theorem rev_flatten : forall A (t : tree A),
    rev (flatten t) = flatten (reverse t).
Proof.
  induct t; simplify.

  equality.

  rewrite rev_app.
  simplify.
  rewrite app_assoc.
  simplify.
  equality.
Qed.

(** * Syntax trees *)

(* Trees are particularly important to us in studying program proof, since it is
 * natural to represent programs as *syntax trees*.  Here's a quick example, for
 * a tiny imperative language. *)

Inductive expression : Set :=
| Const (n : nat)
| Var (x : var)
| Plus (e1 e2 : expression)
| Minus (e1 e2 : expression)
| Times (e1 e2 : expression)
| GreaterThan (e1 e2 : expression)
| Not (e : expression).

Inductive statement : Set :=
| Assign (x : var) (e : expression)
| Sequence (s1 s2 : statement)
| IfThenElse (e : expression) (s1 s2 : statement)
| WhileLoop (e : expression) (s : statement).

(* First, here's a quick sample of nifty notations to write
 * almost-natural-looking embedded programs in Coq. *)
Coercion Const : nat >-> expression.
Coercion Var : string >-> expression.
Infix "+" := Plus : embedded_scope.
Infix "-" := Minus : embedded_scope.
Infix "*" := Times : embedded_scope.
Infix ">" := GreaterThan : embedded_scope.
Infix "<-" := Assign (at level 75) : embedded_scope.
Infix ";" := Sequence (at level 76) : embedded_scope.
Notation "'If' e {{ s1 }} 'else' {{ s2 }}" := (IfThenElse e s1 s2) (at level 75) : embedded_scope.
Notation "'While' e {{ s }}" := (WhileLoop e s) (at level 75) : embedded_scope.
Delimit Scope embedded_scope with embedded.

Example factorial :=
  ("answer" <- 1;
   While ("input" > 0) {{
     "answer" <- "answer" * "input";
     "input" <- "input" - 1
   }})%embedded.

(* A variety of compiler-style operations can be coded on top of this type.
 * Here's one to count total variable occurrences. *)

Fixpoint varsInExpression (e : expression) : nat :=
  match e with
  | Const _ => 0
  | Var _ => 1
  | Plus e1 e2
  | Minus e1 e2
  | Times e1 e2
  | GreaterThan e1 e2 => varsInExpression e1 + varsInExpression e2
  | Not e1 => varsInExpression e1
  end.

Fixpoint varsInStatement (s : statement) : nat :=
  match s with
  | Assign _ e => 1 + varsInExpression e
  | Sequence s1 s2 => varsInStatement s1 + varsInStatement s2
  | IfThenElse e s1 s2 => varsInExpression e + varsInStatement s1 + varsInStatement s2
  | WhileLoop e s1 => varsInExpression e + varsInStatement s1
  end.

(* We will need to wait for a few more lectures' worth of conceptual progress
 * before we can prove that transformations on programs preserve meaning, but we
 * do already have enough tools that prove that transformations preserve more
 * basic properties, like number of variables.  Here's one such transformation,
 * which flips "then" and "else" cases while also negating "if" conditions. *)
Fixpoint flipper (s : statement) : statement :=
  match s with
  | Assign _ _ => s
  | Sequence s1 s2 => Sequence (flipper s1) (flipper s2)
  | IfThenElse e s1 s2 => IfThenElse (Not e) (flipper s2) (flipper s1)
  | WhileLoop e s1 => WhileLoop e (flipper s1)
  end.

Theorem varsIn_flipper : forall s,
    varsInStatement (flipper s) = varsInStatement s.
Proof.
  induct s; simplify.

  equality.

  equality.

  linear_arithmetic.

  equality.
Qed.

(* Just for the sheer madcap fun of it, let's write some translations of
 * programs into our lists from before, with variables as data values. *)

Fixpoint listifyExpression (e : expression) : list var :=
  match e with
  | Const _ => []
  | Var x => [x]
  | Plus e1 e2
  | Minus e1 e2
  | Times e1 e2
  | GreaterThan e1 e2 => listifyExpression e1 ++ listifyExpression e2
  | Not e1 => listifyExpression e1
  end.

Fixpoint listifyStatement (s : statement) : list var :=
  match s with
  | Assign x e => x :: listifyExpression e
  | Sequence s1 s2 => listifyStatement s1 ++ listifyStatement s2
  | IfThenElse e s1 s2 => listifyExpression e ++ listifyStatement s1 ++ listifyStatement s2
  | WhileLoop e s1 => listifyExpression e ++ listifyStatement s1
  end.

Compute listifyStatement factorial.

(* At this point, I can't resist switching to a more automated proof style,
 * though still a pretty tame one. *)

Local Hint Rewrite length_app.

Lemma length_listifyExpression : forall e,
    length (listifyExpression e) = varsInExpression e.
Proof.
  induct e; simplify; linear_arithmetic.
Qed.

Local Hint Rewrite length_listifyExpression.

Theorem length_listifyStatement : forall s,
    length (listifyStatement s) = varsInStatement s.
Proof.
  induct s; simplify; linear_arithmetic.
Qed.

(* Other transformations are also possible, like the Swedish-Chef optimization,
 * which turns every variable into "bork".  It saves many bits when most variable
 * names are longer than 4 characters. *)

Fixpoint swedishExpression (e : expression) : expression :=
  match e with
  | Const _ => e
  | Var _ => Var "bork"
  | Plus e1 e2 => Plus (swedishExpression e1) (swedishExpression e2)
  | Minus e1 e2 => Minus (swedishExpression e1) (swedishExpression e2)
  | Times e1 e2 => Times (swedishExpression e1) (swedishExpression e2)
  | GreaterThan e1 e2 => GreaterThan (swedishExpression e1) (swedishExpression e2)
  | Not e1 => Not (swedishExpression e1)
  end.

Fixpoint swedishStatement (s : statement) : statement :=
  match s with
  | Assign _ e => Assign "bork" (swedishExpression e)
  | Sequence s1 s2 => Sequence (swedishStatement s1) (swedishStatement s2)
  | IfThenElse e s1 s2 => IfThenElse (swedishExpression e) (swedishStatement s1) (swedishStatement s2)
  | WhileLoop e s1 => WhileLoop (swedishExpression e) (swedishStatement s1)
  end.

Compute swedishStatement factorial.

Fixpoint swedishList (ls : list var) : list var :=
  match ls with
  | [] => []
  | _ :: ls => "bork" :: swedishList ls
  end.

Lemma swedishList_app : forall ls1 ls2,
    swedishList (ls1 ++ ls2) = swedishList ls1 ++ swedishList ls2.
Proof.
  induct ls1; simplify; equality.
Qed.

Local Hint Rewrite swedishList_app.

Lemma listifyExpression_swedishExpression : forall e,
    listifyExpression (swedishExpression e) = swedishList (listifyExpression e).
Proof.
  induct e; simplify; equality.
Qed.

Local Hint Rewrite listifyExpression_swedishExpression.

Lemma listifyStatement_swedishStatement : forall s,
    listifyStatement (swedishStatement s) = swedishList (listifyStatement s).
Proof.
  induct s; simplify; equality.
Qed.


Set Implicit Arguments.
Require Import List Omega.
Import ListNotations.

Lemma list_decompose k {X} (A: list X):
  k <= length A -> exists A1 A2, A = A1 ++ A2 /\ length A1 = k.
Proof.
  induction A in k |-*; intros.
  - exists nil. exists nil; cbn. destruct k; intuition.
  - destruct k.
    + exists nil; exists (a :: A); intuition.
    + cbn in *; assert (k <= length A) by omega. destruct (IHA _ H0) as (A1 & A2 & ?).
      intuition. exists (a :: A1). exists A2. subst.
      intuition.
Qed.

Lemma list_decompose_alt k {X} (A: list X):
  k <= length A -> exists A1 A2, A = A1 ++ A2 /\ length A2 = k.
Proof.
  intros H.
  assert (length A - k <= length A) by omega.
  destruct (list_decompose _ H0) as (A1 & A2 & ?).
  intuition. exists A1. exists A2. intuition.
  specialize (app_length A1 A2) as H4.
  rewrite <-H2 in H4. rewrite H4 in H3. omega.
Qed.

Lemma list_decompose_end {X} (A: list X):
  A = nil \/ exists a' A', A = A' ++ [a'].
Proof.
  induction A; intuition; subst.
  all: right; try destruct IH as (a' & A' & ?).
  + exists a. exists nil. reflexivity.
  + destruct H as (a' & A' & ?); subst.
    exists a'. exists (a :: A'). reflexivity.
Qed.

Lemma list_decompose_strong Y k (A: list Y):
  k <= length A -> { A1 & { A2 | A = A1 ++ A2 /\ length A1 = k}}.
Proof.
  induction A in k |-*; intros H.
  - exists nil. exists nil. intuition.
  - destruct k.
    + exists nil. exists (a :: A). intuition.
    + cbn in H; eapply le_S_n in H.
      destruct (IHA _ H) as (A1 & A2 & H1 & H2); subst.
      exists (a :: A1). exists A2. intuition.
Qed.

Lemma list_pointwise_eq X (A B: list X):
  (forall x, nth_error A x = nth_error B x) -> A = B.
Proof.
  induction A in B |-*; cbn; destruct B as [| b B]; eauto.
  - intros H; specialize (H 0); discriminate.
  - intros H; specialize (H 0); discriminate.
  - intros H.
    specialize (H 0) as H'; injection H' as ->.
    f_equal; eapply IHA.
    intros x; exact (H (S x)).
Qed.

Lemma list_end_ind:
  forall (A : Type) (P : list A -> Prop),
    P [] ->
    (forall (a : A) (l : list A), P l -> P (l ++ [a])) -> forall l : list A, P l.
Proof.
  intros A P H IH l.
  specialize (rev_list_ind P H) as Ind.
  rewrite <-rev_involutive. eapply Ind.
  intros; cbn; now apply IH.
Qed.

Lemma app_injective {X} (A B C D: list X):
  length A = length C -> A ++ B = C ++ D -> A = C /\ B = D.
Proof.
  induction A in C |-*; destruct C; try discriminate.
  cbn; intuition.
  injection 1 as ?. injection 1 as ?.
  subst. edestruct IHA; eauto; subst; intuition.
Qed.

Lemma app_injective_right Y (A1 A2 B1 B2 : list Y):
  length A2 = length B2 -> A1 ++ A2 = B1 ++ B2 -> A1 = B1 /\ A2 = B2.
Proof.
  intros H; induction A1 in B1 |-*; destruct B1; cbn; eauto.
  1 - 2: intros; subst; cbn in H; autorewrite with list in H; omega.
  intros [= -> ? % IHA1]; intuition; now subst.
Qed.


Welcome to Coq 8.4pl6 (January 2017)

Coq < Inductive boollist : Type := | bool_nil : boollist | bool_cons : bool -> boollist -> boollist.
boollist is defined
boollist_rect is defined
boollist_ind is defined
boollist_rec is defined

Coq < Inductive list (X:Type) : Type := | nil : list X | cons : X -> list X -> list X.
list is defined
list_rect is defined
list_ind is defined
list_rec is defined

Coq < Check nil.
nil
     : forall X : Type, list X

Coq < Check cons.
cons
     : forall X : Type, X -> list X -> list X

Coq < Check (cons nat 2 (cons nat 1 (nil nat))).
cons nat 2 (cons nat 1 (nil nat))
     : list nat

Coq < Fixpoint repeat (X : Type) (x : X) (count : nat) : list X := match count with | O => nil X | S count' => cons X x (repeat X x count') end.
repeat is recursively defined (decreasing on 3rd argument)

Coq < Example test_repeat1 : repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
1 subgoal

  ============================
   repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat))

test_repeat1 < Proof.
1 subgoal

  ============================
   repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat))

test_repeat1 < info_auto.
(* info auto : *)
 apply @eq_refl.
No more subgoals.

test_repeat1 < Qed.
info_auto.

test_repeat1 is defined

Coq < Example test_repeat2 : repeat bool false 1 = cons bool false (nil bool).
1 subgoal

  ============================
   repeat bool false 1 = cons bool false (nil bool)

test_repeat2 < Proof.
1 subgoal

  ============================
   repeat bool false 1 = cons bool false (nil bool)

test_repeat2 < info_auto.
(* info auto : *)
 apply @eq_refl.
No more subgoals.

test_repeat2 < Qed.
info_auto.

test_repeat2 is defined


From Coq Require Export List.
From Coq Require Export Arith micromega.Lia.

Import ListNotations.

Fixpoint map_seq {A:Type} (f : nat -> A) start len :=
  match len with
  | 0%nat => nil
  | S len => f start :: (map_seq f (S start) len)
  end.

Lemma map_seq_spec {A:Type} (f : nat -> A) start len :
  map_seq f start len = map f (seq start len).
Proof.
  revert start; induction len; [reflexivity|].
  intros; cbn; rewrite IHlen. reflexivity. Qed.

Lemma map_seq_nonnil {A:Type} (f : nat -> A) n m : (0 < m)%nat -> map_seq f n m <> nil.
Proof. destruct m. lia. simpl. congruence. Qed.

Lemma map_seq_In {A:Type} (f : nat -> A) n m :
  forall i, (n <= i < n + m)%nat -> In (f i) (map_seq f n m).
Proof. rewrite map_seq_spec. intros; apply in_map; apply in_seq; assumption. Qed.

Lemma In_map_seq {A:Type} (f : nat -> A) n m x :
  In x (map_seq f n m) -> exists i, f i = x.
Proof. intros. rewrite map_seq_spec in H. apply in_map_iff in H as [i []]. exists i. assumption. Qed.

Lemma seq_snoc len : forall start, seq start (S len) = seq start len ++ [start + len].
Proof.
  induction len; intros.
  { cbv [seq app]. rewrite Nat.add_0_r; reflexivity. }
  { remember (S len); simpl seq.
    rewrite (IHlen (S start)); subst; simpl seq.
    rewrite Nat.add_succ_r; reflexivity. }
Qed.

Lemma map_seq_ext {A} (f g : nat -> A) (n m k : nat)
      (H : forall i : nat, n <= i < m + k -> f i = g (i + (m - n))%nat)
      (Hnm : n <= m) :
  map f (seq n k) = map g (seq m k).
Proof.
  generalize dependent m; generalize dependent n; induction k as [|k IHk]; intros; simpl.
  - reflexivity.
  - simpl; rewrite H by lia; replace (n + (m - n))%nat with m by lia.
    rewrite (IHk (S n) (S m)); [reflexivity| |lia].
    intros; rewrite Nat.sub_succ; apply H; lia. Qed.

Lemma cons_map_seq {A : Type} : forall len start (f : nat -> A), (f start) :: map_seq f (S start) len = map_seq f start (S len).
Proof. reflexivity. Qed.

Lemma map_seq_snoc {A : Type} : forall len start (f : nat -> A), map_seq f start (S len) = map_seq f start len ++ [f (start + len)%nat].
Proof.
  induction len; intros.
  { cbv [seq app]. rewrite Nat.add_0_r; reflexivity. }
  { remember (S len); simpl map_seq.
    rewrite (IHlen (S start)); subst; simpl seq.
    rewrite Nat.add_succ_r; reflexivity. }
Qed.


Require Import List.
Import ListNotations.
Require Import Arith.EqNat.

Section Sort.

Variable Element : Type.
Variable beqElement : Element -> Element -> bool.
Variable beqEqElement : forall x y : Element, {x = y} + {x <> y}.
Definition GraphEntry := (Element * list Element)%type.
Definition Graph := list GraphEntry.
Definition Order := list (list Element).

Definition graphLookup (elem: Element) (graph: Graph) : list Element :=
  match find (fun entry => beqElement elem (fst entry)) graph with
    | Some (_, es) => es
    | None => []
  end.

Definition bElemIn (elem: Element) (es: list Element) : bool :=
  if find (beqElement elem) es then true else false.
Definition bElemNotIn (elem: Element) (es: list Element) : bool :=
  if find (beqElement elem) es then false else true.

Fixpoint cycleEntryAux (graph: Graph) (seens: list Element) (elem: Element) (counter: nat) : Element :=
  if bElemIn elem seens
  then elem
  else match counter with
         | S c => match graphLookup elem graph with
                   | e' :: _ =>
                     (* cas où elem est bien dans le graphe et a au moins un successeur *)
                     (* on devrait toujours être dans ce cas quand on utilise la fonction *)
                     cycleEntryAux graph (elem :: seens) e' c
                   | _ => elem
                 end
         | _ => elem
       end.

Definition cycleEntry (graph : Graph) : option Element :=
  match graph with
    | (e, _) :: _ => Some (cycleEntryAux graph [] e (length graph))
    | _ => None
  end.

Fixpoint cycleExtractAux (graph: Graph) (counter: nat) (elem: Element) (cycl: list Element) : list Element :=
  match counter with
    | S c => if bElemIn elem cycl
            then cycl (* déjà présent dans le cycle, on arrête le parcours sur cette branche *)
            else
              let es := graphLookup elem graph in
                fold_right (cycleExtractAux graph c) (elem :: cycl) es
    | _ => cycl (* peut arriver si tous les nœuds sont dans le cycle *)
  end.

Definition cycleExtract (graph: Graph): list Element :=
  match cycleEntry graph with
    | None => []
    | Some elem => cycleExtractAux graph (length graph) elem []
  end.

(* Définition utile ? *)
Definition comp {A B C: Type} (f: B -> C) (g: A -> B) (x: A) := f (g x).
Definition null {A: Type} (xs: list A) : bool :=
  if xs then true else false.

Fixpoint topologicalSortAux (graph: Graph) (counter: nat) : Order :=
  match counter with
    | S c =>
      if null graph
      then []
      else
        let mins := map (@fst _ _) (filter (comp null (@snd _ _)) graph) in
        let mins' := if null mins then cycleExtract graph else mins in
        let rest := filter (fun entry => bElemNotIn (fst entry) mins') graph in
        let rest' := map (fun entry => (fst entry, filter (fun e => bElemNotIn e mins') (snd entry))) rest in
        mins' :: topologicalSortAux rest' c
    | _ => []
  end.

Definition topologicalSort (graph: Graph) : Order :=
  topologicalSortAux graph (length graph).

Definition topologicalRankList (graph : Graph) : list (Element * nat) :=
  let lorder := topologicalSort graph in
  concat (map (fun (x: list Element * nat) => let (fs, rk) := x in map (fun f => (f, rk)) fs)
              (combine lorder (seq 0 (length lorder)))).

End Sort.

Ltac autorank elem_beq ranklist :=
  intros f;
  pose (f' := f);
  destruct f;
  match eval compute in (find (fun fr => elem_beq f' (fst fr)) ranklist) with
    | Some (_, ?r) => exact r
      (* cas des fonctions n’apparaissant pas dans le programme *)
    | None         => exact 0
  end.

(*
Eval compute in (topologicalSort nat beq_nat [ (1, [2]); (2, []) ]).
Eval compute in (topologicalSort nat beq_nat [ (1, [2]); (2, [1]) ]).

Eval compute in (topologicalSort nat beq_nat [ (1, [2; 3]);
                                   (2, [1]);
                                   (3, []) ]).

Eval compute in (topologicalSort nat beq_nat [ (1, [2; 3]);
                                   (2, [1]);
                                   (3, []);
                                   (4, [2; 3])]).
*)


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.

Require Import BWT.Lib.List.
Import Coq.Lists.List.ListNotations.

Section Props.
  Context {A : Type} {P : A -> Prop} .
  Variables l l' : list A.
  Hypothesis HP : Permutation l l'.

  Theorem Permutation_exists :
    Exists P l -> Exists P l'.
  Proof.
    intros HE.
    apply Exists_exists.
    apply Exists_exists in HE; destruct HE as [x [HIn HPx]].
    eauto using Permutation_in.
  Defined.

  Theorem Permutation_forall :
    Forall P l -> Forall P l'.
  Proof.
    intros.
    apply Forall_forall.
    intros a HA.
    apply Permutation_in with (l' := l) in HA; auto using Permutation_sym.
    revert a HA.
    apply Forall_forall.
    auto.
  Qed.
End Props.

Section Preserve.
  Context {A : Type} (f : list A -> list A).
  Hypothesis HF: forall l, Permutation l (f l).

  Theorem f_perm : forall (x y : list A),
      Permutation x y -> Permutation x (f y).
  Proof.
    assert (LP: forall l, Permutation (f l) l). {
      intro l. apply Permutation_sym. apply HF.
    }
    intros. inversion H; subst; clear H.
    - apply HF.
    - apply Permutation_sym. eapply perm_trans. apply LP.
      apply perm_skip. apply Permutation_sym. auto.
    - apply Permutation_sym. eapply perm_trans. apply LP.
      repeat constructor.
    - apply Permutation_sym. eapply perm_trans. apply LP.
      apply Permutation_sym. eapply perm_trans; eauto.
  Qed.

  Theorem f_perm' : forall (x y : list A),
      Permutation x y -> Permutation (f x) (f y).
  Proof.
    intros.
    eapply perm_trans. apply Permutation_sym. apply f_perm; auto.
    apply Permutation_sym.
    eapply perm_trans. apply Permutation_sym. apply f_perm; auto.
    apply Permutation_sym. apply H.
  Qed.

  Theorem f_nonempty : forall l,
      l <> [] -> f l <> [].
  Proof.
    intros. intro contra.
    specialize (HF l).
    rewrite contra in HF.
    apply Permutation_sym in HF.
    apply Permutation_nil in HF.
    rewrite HF in H. contradiction.
  Qed.
End Preserve.

Lemma Permutation_cons_in {A} : forall (x y : A) xs ys,
    Permutation (x :: xs) (y :: ys) ->
    (x = y \/ In x ys).
Proof.
  intros x y xs ys P.
  eapply Permutation_in in P.
  cbn in P. destruct P as [E | I]; eauto.
  cbn; eauto.
Qed.

(** A property of permutations that is missing from the List library:
  a permutation of a list without duplicates is a list without duplicates. *)

Lemma Permutation_NoDup {A}:
  forall (l l': list A), Permutation l l' -> NoDup l -> NoDup l'.
Proof.
  induction 1; intros.
  constructor.

  inversion H0; subst. constructor; auto.
  red; intro; elim H3. apply Permutation_in with l'; auto. apply Permutation_sym; auto.

  inversion H; subst. inversion H3; subst.
  constructor. simpl. simpl in H2. intuition.
  constructor. simpl in H2. intuition. auto.

  auto.
Qed.

Theorem Permutation_1 {A} : forall (a : A) y,
    Permutation [a] y -> y = [a].
Proof.
  intros a y HP.
  remember [a] as x. revert a Heqx.
  induction HP.
  - reflexivity.
  - intros a H. inversion H; subst; clear H.
    apply Permutation_nil in HP. subst l'.
    reflexivity.
  - intros a H. inversion H.
  - intros.
    specialize (IHHP1 a Heqx).
    specialize (IHHP2 a (eq_trans IHHP1 Heqx )).
    subst; auto.
Qed.

Theorem Permutation_zip_eq {A B} : forall l1 l2 : list (A * B),
    Permutation l1 l2 ->
    NoDup (map fst l1) ->
    map fst l1 = map fst l2 ->
    map snd l1 = map snd l2.
Proof.
  induction l1 as [|[xl xr] l1 IH]; intros [|[yl yr] l2];
    intros P ND H1;
    [..|symmetry in P|];
    [reflexivity|apply Permutation_nil_cons in P; contradiction..|].
  cbn in *.
  inversion H1; subst; clear H1.
  destruct (Permutation_in (yl, xr) P) as [HE | HP]; [left; easy|..].
  - inversion HE; subst; clear HE.
    f_equal.
    apply IH.
    eapply Permutation_cons_inv; apply P.
    eapply NoDup_cons_iff; apply ND.
    easy.
  - exfalso.
    apply NoDup_cons_iff with (a := yl) (l := map fst l1); [easy|].
    rewrite H2.
    apply in_map_iff. exists (yl, xr). easy.
Qed.

Theorem Permutation_combine_eq {A B} : forall (x : list A) (y1 y2 : list B),
    Permutation (combine x y1) (combine x y2) ->
    length x = length y1 -> length x = length y2 ->
    NoDup x ->
    y1 = y2.
Proof.
  intros x y1 y2 HP HL1 HL2 ND.
  pose proof (combine_split x y1 HL1) as S1.
  pose proof (combine_split x y2 HL2) as S2.
  rewrite map_split in S1, S2.
  inversion S1 as [[X1 Y1]]; rewrite X1 in *; clear S1.
  inversion S2 as [[X2 Y2]]; rewrite Y2, X2 in *; rewrite <- Y2; clear S2.
  apply Permutation_zip_eq; rewrite ?X1, ?X2; easy.
Qed.


Require Import Arith.
Require Import Omega.
Require Import Recdef.
Require Import String.
Require Import List.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require Import Ascii.
Require Import Program.
Require Import Bool.
Require Import Sorting.Permutation.

Section CharacterFacts.
  (* Perhaps useful in your regular-expression development. *)

  (* `ascii_eq` is an executable equality test for characters. *)
  Definition ascii_eq (a b:ascii) : bool :=
    match (a, b) with
    | (Ascii a1 a2 a3 a4 a5 a6 a7 a8,
       Ascii b1 b2 b3 b4 b5 b6 b7 b8) =>
      eqb a1 b1 && eqb a2 b2 && eqb a3 b3 && eqb a4 b4 &&
          eqb a5 b5 && eqb a6 b6 && eqb a7 b7 && eqb a8 b8
    end.

  Lemma ascii_eq_refl (a:ascii):
    ascii_eq a a = true.
  Proof.
    destruct a; unfold ascii_eq; repeat rewrite eqb_reflx; simpl; auto.
  Qed.

  (* `ascii_eq` is equivalent to character equality. *)
  Lemma ascii_eq_iff a b:
    ascii_eq a b = true <-> a = b.
  Proof.
    split; intros.
    - unfold ascii_eq in H; destruct a; destruct b;
        repeat rewrite andb_true_iff in *; destruct_pairs;
          rewrite eqb_true_iff in *; congruence.
    - rewrite H; apply ascii_eq_refl.
  Qed.
End CharacterFacts.

Section StringFacts.
  (* Perhaps useful in your regular-expression development. *)

  (* Coq `string`s are constructed from characters using a
     `list`-like cons procedure. The two `string` constructors
     are `EmptyString` (also written ` ""%string `; like `nil`)
     and `String ch s` (which is like `ch :: s`). *)

  (* `append` is the string version of `app` (list append).
     The Coq library has fewer `append` lemmas; we provide them. *)

  Lemma append_nil_l s:
    ("" ++ s)%string = s.
  Proof.
    simpl; auto.
  Qed.

  Lemma append_nil_r s:
    (s ++ "")%string = s.
  Proof.
    induction s; simpl; try rewrite IHs; auto.
  Qed.

  Lemma append_assoc s1 s2 s3:
    (s1 ++ s2 ++ s3)%string = ((s1 ++ s2) ++ s3)%string.
  Proof.
    induction s1; simpl; try rewrite IHs1; auto.
  Qed.

  Lemma append_comm_cons a s1 s2:
    (String a s1 ++ s2)%string = String a (s1 ++ s2)%string.
  Proof.
    induction s1; simpl; auto.
  Qed.

  Definition strlen := String.length.

  Lemma append_strlen_l s1 s2:
    strlen s1 <= strlen (s1 ++ s2).
  Proof.
    induction s1; simpl; try rewrite IHs1; omega.
  Qed.

  Lemma append_strlen_r s1 s2:
    strlen s2 <= strlen (s1 ++ s2).
  Proof.
    induction s1; simpl; try rewrite IHs1; omega.
  Qed.
End StringFacts.

(* Define a type that represents regular expressions.

   Support the following grammar (but you don’t need to
   use this concrete syntax):

   regex ::= 'ε'    // matches the empty string
          |  'ANY'  // matches any character
          |  CHAR   // matches a specific character
          |  regex '++' regex   // concatenation
          |  regex '|' regex    // or
          |  regex '*'          // Kleene star

   This type *represents* regular expressions in memory,
   so it is a `Set` (not a `Prop`). *)

(* YOUR CODE HERE *)

(* Now define an inductive proposition with two parameters,
   a regex and a string, that holds iff the regex matches
   the string.

   (This type *defines* the semantics of regular expressions,
   so you can’t prove it correct---it just needs to match
   the expected semantics.) *)

(* YOUR CODE HERE *)

(* Write a couple `Example`s that show that specific regular
   expressions match specific strings, and prove them. *)

(* YOUR CODE HERE *)

(* State and prove a theorem that relates Kleene-star and
   concatenation. Your theorem should say that if `r*` matches
   a string `s`, then there exists a regex `r ++ r ++ ... ++ r`
   that matches `s`, and vice versa. (Probably easiest to
   introduce a helper function that produces `r ++ ... ++ r`
   for a given count, and then to prove two lemmas, one per
   direction. *)

(* YOUR CODE HERE *)

(* Now, write a regular expression IMPLEMENTATION and prove
   it at least partially correct.

   Q. What does “implementation” mean?
   A. Here are some possibilities.
      - COMPUTATIONAL MATCHER: You could write a `Function`
        or `Fixpoint` that takes a regex as an argument and
        returns `true` if the regex matches.
      - NFA MATCHER: You could design an inductive type for
        nondeterministic finite automata. This would include
        a `Function` or `Fixpoint` that builds the NFA for
        a regex using Thompson’s construction, and an
        inductive proposition that implements NFA matching.
      - DERIVATIVES MATCHER:
        http://www.ccs.neu.edu/home/turon/re-deriv.pdf
      - OTHER: Check with me!

   Q. Any general gotchas?
   A. DON’T PREMATURELY OPTIMIZE.

   Q. Any gotchas with a computational matcher?
   A. Kleene-star will cause problems since your recursion
      might never terminate. It’s OK to add an extra “fuel”
      argument to force termination. Each recursive call
      will consume a unit of fuel, and the match may terminate
      prematurely (i.e., return `false`) if it runs out of
      fuel. But given enough fuel, your matcher should succeed
      on Kleene-star arguments (it’s not OK to return `false`
      for every Kleene-star regex).

   Q. Any gotchas with an NFA matcher?
   A. I found it far easier to work with a “nested” NFA
      design, in which an NFA node may contain another NFA as
      a subgraph, than a “flat” NFA design, in which the
      regex-to-NFA function flattens the regex as it goes.

   Q. What does “partially correct” mean?
   A. Full correctness requires that (1) every string that
      matches the spec also matches the implementation (perhaps
      with a “given enough fuel” clause), and (2) every string
      that matches the implementation also matches the spec.
      Please prove AT LEAST ONE of these directions.

   Q. Any general hints?
   A. I found the NFA matcher easier to work with because of
      the absence of fuel.
   A. You will likely need some additional type definitions.
   A. `inversion` is your friend.
   A. You will almost certainly want `Hint Constructors` for
      your types. `auto` goes a lot further when `Hint
      Constructors` is active. Consider writing your own
      tactics too; I benefited enormously from a tactic that
      can tell when an edge (such as one created by
      `inversion` or `destruct`) is not actually in an NFA.

   Q. This is fun. How can I go further?
   A. You’re crazy. But, for example, given an NFA matcher,
      you could implement an NFA-to-DFA converter and prove it
      preserved the NFA’s semantics. I wrote an NFA flattener,
      which de-nests a recursive NFA into a flat graph, and
      proved that flattening preserves the NFA’s semantics.
      That was hard, but fun.

   Q. How can I not get stuck?
   A. Share your inductive definitions with me before you get
      too far down the proof route. *)

(* YOUR CODE HERE *)


(* 定義と関数 *)
Definition one' := 1.
Print one'.
Definition one : nat := 1.
Definition double x := x + x.
Print double.
Eval compute in double 2.
Definition double' := fun x => x + x.
Print double'.
Definition quad x := let y := double x in 2 * y.
Eval compute in quad 2.
Definition quad' x := double (double x).
Eval compute in quad' 2.
Definition triple x :=
  let double x := x + x in
  double x + x.
Eval compute in triple 3.

(* 整数とモジュール *)
Eval compute in 1 - 2.

Require Import ZArith.
Module Z.
  Open Scope Z_scope.

  Eval compute in 1 - 2.
  Eval compute in (2 + 3) / 2.

  Definition p (x y : Z) := 2 * x - y * y.
  Print p.

  Eval compute in p 3 4.

  Definition p' := fun x => fun y => 2 * x - y * y.
  Print p'.
  Definition q := p 3.

  Eval compute [p q] in q.
  Eval compute in q 4.

  Eval compute in let x := 0 in q x.
  Eval compute in let x := 0 in q x.
End Z.

Print Z.p.

Eval compute in 1 - 2.

(* データ型の定義 *)
Inductive janken : Set :=
  | gu
  | choki
  | pa.

Definition weakness t :=
  match t with
  | gu    => pa
  | choki => gu
  | pa    => choki
  end.
Eval compute in weakness pa.
Print bool.
Print janken.

Definition wins t1 t2 :=
  match t1, t2 with
  | gu, choki => true
  | choki, pa => true
  | pa,    gu => true
  | _, _      => false
  end.
Check wins.
Eval compute in wins gu pa.

Module Play2.
  Inductive winner : Set :=
    | first
    | second
    | aiko.

  Definition play t1 t2 :=
    if wins t1 t2 then first else
    if wins t2 t1 then second else
    aiko.

  Eval compute in play gu pa.
  Eval compute in play choki choki.
End Play2.

Print andb.
Print orb.

Module Play3.
  Inductive winner : Set :=
    | first
    | second
    | third
    | aiko.

  Definition play (t1 t2 t3 : janken) : winner := aiko.
End Play3.