(* This file is extracted from the TLC library.
   http://github.com/charguer/tlc
   DO NOT EDIT. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Reflection : Basic Operations on Booleans                               *
**************************************************************************)

Set Implicit Arguments.
From SLF Require Import LibTactics LibLogic LibOperation.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Boolean type *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition *)

(** From the Prelude:

  Inductive bool : Type :=
    | true : bool
    | false : bool.

*)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inhabited *)

Instance Inhab_bool : Inhab bool.
Proof using. constructor. apply (Inhab_of_val true). Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Extensionality *)

(** See [LibReflect] for extensionality of booleans. *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Boolean Operations *)

(* ================================================================= *)
(** ** Comparison *)

Definition eqb (x y:bool) : bool :=
  match x, y with
  | true, true => true
  | false, false => true
  | _, _ => false
  end.

(** Negation *)

Definition neg (x:bool) : bool :=
  match x with
  | true => false
  | false => true
  end.

(** Conjunction *)

Definition and (x y:bool) : bool :=
  match x, y with
  | true, true => true
  | _, _ => false
  end.

(** Disjunction *)

Definition or (x y:bool) : bool :=
  match x, y with
  | false, false => false
  | _, _ => true
  end.

(** Implication *)

Definition impl (x y:bool) : bool :=
  or x (neg y).

(** Exclusive or *)

Definition xor (x y:bool) : bool :=
  neg (eqb x y).

(** Notations *)

Declare Scope Bool_scope.
Bind Scope Bool_scope with bool.
Open Scope Bool_scope.

Notation "! x" := (neg x)
  (at level 35, right associativity) : Bool_scope.
Infix "&&" := and
  (at level 40, left associativity) : Bool_scope.
Infix "||" := or
  (at level 50, left associativity) : Bool_scope.

Notation "! x" := (neg x)
  (at level 35, right associativity) : Bool_scope.
Infix "&&" := and
  (at level 40, left associativity) : Bool_scope.
Infix "||" := or
  (at level 50, left associativity) : Bool_scope.

(* ********************************************************************** *)
(** * Boolean Decision Procedure : tactic working by exponential case
      analysis on all variables of type bool. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic [tautob] *)

(** [tautob] introduces all variables that it can, performs a
    case analysis on all the boolean variables, then splits
    all subgoals and attempts resolution using intuition *)

Ltac tautob_post tt :=
  simpls; try split; intros; try discriminate;
  try solve [ intuition auto_false ].

Ltac tautob_core tt :=
  let rec aux tt :=
    (try intros_all); match goal with
    | b : bool |- _ => destruct b; clear b; aux tt
    | _ => tautob_post tt
    end in
  aux tt.

Tactic Notation "tautob" :=
  tautob_core tt.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Properties of boolean operators *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [eqb] *)

Lemma eqb_same : forall x,
  eqb x x = true.
Proof using. tautob. Qed.

Lemma eqb_true_l : neutral_l eqb true.
(* forall x, eqb true x = x. *)
Proof using. tautob. Qed.

Lemma eqb_true_r : neutral_r eqb true.
Proof using. tautob. Qed.

Lemma eqb_false_l : forall x,
  eqb false x = neg x.
Proof using. tautob. Qed.

Lemma eqb_false_r : forall x,
  eqb x false = neg x.
Proof using. tautob. Qed.

Lemma eqb_comm : comm eqb.
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [and] *)

Lemma and_same : idempotent2 and.
Proof using. tautob. Qed.

Lemma and_true_l : neutral_l and true.
Proof using. tautob. Qed.

Lemma and_true_r : neutral_r and true.
Proof using. tautob. Qed.

Lemma and_false_l : absorb_l and false.
Proof using. tautob. Qed.

Lemma and_false_r : absorb_r and false.
Proof using. tautob. Qed.

Lemma and_comm : comm and.
Proof using. tautob. Qed.

Lemma and_assoc : assoc and.
Proof using. tautob. Qed.

Lemma and_or_l : distrib_r and or.
(* forall x y z, (x || y) && z = x && z ||| y && z. *)
Proof using. tautob. Qed.

Lemma and_or_r : distrib_l and or.
(* forall x y z, x && (y ||| z) = x && y ||| x && z. *)
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [or] *)

Lemma or_same : idempotent2 or.
Proof using. tautob. Qed.

Lemma or_false_l : neutral_l or false.
Proof using. tautob. Qed.

Lemma or_false_r : neutral_r or false.
Proof using. tautob. Qed.

Lemma or_true_l : absorb_l or true.
Proof using. tautob. Qed.

Lemma or_true_r : absorb_r or true.
Proof using. tautob. Qed.

Lemma or_comm : comm or.
Proof using. tautob. Qed.

Lemma or_assoc : assoc or.
Proof using. tautob. Qed.

Lemma or_and_l : distrib_r or and.
(* forall x y z, (x && y) || z = (x || z) && (y || z). *)
Proof using. tautob. Qed.

Lemma or_and_r : distrib_l or and.
(* forall x y z, x || (y && z) = (x || y) && (x || z). *)
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [neg] *)

Lemma neg_false : ! false = true.
Proof using. auto. Qed.

Lemma neg_true : ! true = false.
Proof using. auto. Qed.

(* --LATER: fix coq display of goals below *)

Lemma neg_and : automorphism neg and or.
(* forall x y, ! (x && y) = (! x) || (! y) *)
Proof using. tautob. Qed.

Lemma neg_or : automorphism neg or and.
(* forall x y, ! (x || y) = (! x) && (! y) *)
Proof using. tautob. Qed.

Lemma neg_neg : involutive neg.
(* forall x, ! (! b) = b *)
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [if then else] *)

Section PropertiesIf.
Implicit Types x y z : bool.

Lemma if_true : forall x y,
  (if true then x else y) = x.
Proof using. auto. Qed.

Lemma if_false : forall x y,
  (if false then x else y) = y.
Proof using. auto. Qed.

Lemma if_then_else_same : forall x y,
  (if x then y else y) = y.
Proof using. tautob. Qed.

Lemma if_then_true_else_false : forall x,
  (if x then true else false) = x.
Proof using. tautob. Qed.

Lemma if_then_false_else_true : forall x,
  (if x then false else true) = !x.
Proof using. tautob. Qed.

Lemma if_then_true : forall x y,
  (if x then true else y) = x || y.
Proof using. tautob. Qed.

Lemma if_then_false : forall x y,
  (if x then false else y) = (!x) && y.
Proof using. tautob. Qed.

Lemma if_else_false : forall x y,
  (if x then y else false) = x && y.
Proof using. tautob. Qed.

Lemma if_else_true : forall x y,
  (if x then y else true) = (!x) || y.
Proof using. tautob. Qed.

End PropertiesIf.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [impl] and [xor] *)

(** We do not provide lemmas for [impl] and [xor]
   because these functions can be easily expressed
   in terms of the other operators. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Opacity *)

Opaque eqb neg and or.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic [rew_neg_neg] *)

(** [rew_neg_neg] is a tactic that simplifies all double negations
    of booleans, i.e. replaces [!!b] with [b]. *)

Hint Rewrite neg_neg : rew_neg_neg.

Tactic Notation "rew_neg_neg" :=
  autorewrite with rew_neg_neg.
Tactic Notation "rew_neg_neg" "~" :=
  rew_neg_neg; auto_tilde.
Tactic Notation "rew_neg_neg" "*" :=
  rew_neg_neg; auto_star.
Tactic Notation "rew_neg_neg" "in" hyp(H) :=
  autorewrite with rew_neg_neg in H.
Tactic Notation "rew_neg_neg" "~" "in" hyp(H) :=
  rew_neg_neg in H; auto_tilde.
Tactic Notation "rew_neg_neg" "*" "in" hyp(H) :=
  rew_neg_neg in H; auto_star.
Tactic Notation "rew_neg_neg" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_neg_neg).
  (* autorewrite with rew_neg_neg in *. *)
Tactic Notation "rew_neg_neg" "~" "in" "*" :=
  rew_neg_neg in *; auto_tilde.
Tactic Notation "rew_neg_neg" "*" "in" "*" :=
  rew_neg_neg in *; auto_star.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic [rew_bool] *)

(** [rew_bool] simplifies boolean expressions, using rewriting
    lemmas in the database [rew_bool] defined below. *)

Hint Rewrite
  eqb_same eqb_true_l eqb_true_r eqb_false_l eqb_false_r
  neg_false neg_true neg_neg neg_and neg_or
  and_true_l and_true_r and_false_l and_false_r
  or_false_l or_false_r or_true_l or_true_r
  if_true if_false if_then_else_same
  if_then_true_else_false if_then_false_else_true
  if_then_true if_else_false
  if_then_false if_else_true
  : rew_bool.

Tactic Notation "rew_bool" :=
  autorewrite with rew_bool.
Tactic Notation "rew_bool" "~" :=
  rew_bool; auto_tilde.
Tactic Notation "rew_bool" "*" :=
  rew_bool; auto_star.
Tactic Notation "rew_bool" "in" hyp(H) :=
  autorewrite with rew_bool in H.
Tactic Notation "rew_bool" "~" "in" hyp(H) :=
  rew_bool in H; auto_tilde.
Tactic Notation "rew_bool" "*" "in" hyp(H) :=
  rew_bool in H; auto_star.
Tactic Notation "rew_bool" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_bool).
  (* autorewrite with rew_bool in *. *)
Tactic Notation "rew_bool" "~" "in" "*" :=
  rew_bool in *; auto_tilde.
Tactic Notation "rew_bool" "*" "in" "*" :=
  rew_bool in *; auto_star.

(* 2021-08-11 15:24 *)


(** * F4: Kolisty [TODO] *)

(* begin hide *)
(* TODO: insertion sort na kolistach *)
(* end hide *)
Set Primitive Projections.

Set Warnings "+cannot-define-projection".
Set Warnings "+non-primitive-record".

(** * Kolisty nie znaczy okrągły *)

From Typonomikon Require Import D5.

(** Ten rozdział będzie o kolistach, czyli koinduktywnych odpowiednikach
    list różniących się od nich tym, że mogą być potencjalnie
    nieskończone. *)

Inductive CoListF (A : Type) (F : Type -> Type) : Type :=
| NilF  : CoListF A F
| ConsF : forall (h : A) (t : F A), CoListF A F.

Arguments NilF {A F}.
Arguments ConsF {A F} _ _.

CoInductive CoList (A : Type) : Type :=
{
  uncons : CoListF A CoList
}.

Arguments uncons {A}.

(** ** Bipodobieństwo *)

(** Zdefiniuj relację bipodobieństwa dla kolist. Udowodnij, że jest ona
    relacją równoważności. Z powodu konfliktu nazw bipodobieństwo póki
    co nazywać się będzie [lsim]. *)

(* begin hide *)
Inductive lsimF {A : Type} (l1 l2 : CoList A) (F : CoList A -> CoList A -> Prop) : Prop :=
| conils  :
    forall (H1 : uncons l1 = NilF) (H2 : uncons l2 = NilF), lsimF l1 l2 F
| coconss :
    forall
      (h1 h2 : A) (t1 t2 : CoList A)
      (H1 : uncons l1 = ConsF h1 t1)
      (H2 : uncons l2 = ConsF h2 t2)
      (heads : h1 = h2) (tails : F t1 t2),
        lsimF l1 l2 F.

CoInductive lsim {A : Type} (l1 l2 : CoList A) : Prop :=
{
  lsim' : lsimF l1 l2 lsim
}.

#[global] Hint Constructors lsim : core.

(*

Axiom eq_lsim :
  forall (A : Type) (l1 l2 : CoList A), lsim l1 l2 -> l1 = l2.
(* end hide *)

Lemma lsim_refl :
  forall (A : Type) (l : CoList A), lsim l l.
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct l as [[]].
    left; cbn; reflexivity.
    eright; cbn; auto.
Qed.
(* end hide *)

Lemma lsim_symm :
  forall (A : Type) (l1 l2 : CoList A),
    lsim l1 l2 -> lsim l2 l1.
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct H as [[]].
    left; assumption.
    eright; try eassumption; auto.
Qed.
(* end hide *)

Lemma lsim_trans :
  forall (A : Type) (l1 l2 l3 : CoList A),
    lsim l1 l2 -> lsim l2 l3 -> lsim l1 l3.
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct H as [[]], H0 as [[]].
    left; auto.
    congruence.
    congruence.
    eright.
      1-2: eassumption.
      congruence.
      eapply CH.
        eassumption.
        congruence.
Qed.
(* end hide *)

(** Przyda się też instancja klasy [Equivalence], żebyśmy przy dowodzeniu
    o [lsim] mogli używać taktyk [reflexivity], [symmetry] oraz [rewrite]. *)

#[export]
Instance Equivalence_lsim (A : Type) : Equivalence (@lsim A).
Proof.
  esplit; red.
    apply lsim_refl.
    apply lsim_symm.
    apply lsim_trans.
Defined.

(** ** Różność *)

(** Przyda się też induktywna wersja relacji [<>]. Zdefiniuj ją i pokaż,
    że induktywna wersja implikuje zwykłą. Czy implikacja w drugą stronę
    zachodzi? *)

Inductive CoList_neq
  {A : Type} : CoList A -> CoList A -> Prop :=
| CoList_neq_nc :
    forall l1 l2 : CoList A,
      uncons l1 = NilF -> uncons l2 <> NilF -> CoList_neq l1 l2
| CoList_neq_cn :
    forall l1 l2 : CoList A,
      uncons l1 <> NilF -> uncons l2 = NilF -> CoList_neq l1 l2
| CoList_neq_cc_here :
    forall (h1 h2 : A) (t1 t2 l1 l2 : CoList A),
      uncons l1 = ConsF h1 t1 ->
      uncons l2 = ConsF h2 t2 ->
        h1 <> h2 -> CoList_neq l1 l2
| CoList_neq_cc_there :
    forall (h1 h2 : A) (t1 t2 l1 l2 : CoList A),
      uncons l1 = ConsF h1 t1 ->
      uncons l2 = ConsF h2 t2 ->
        CoList_neq t1 t2 -> CoList_neq l1 l2.

Lemma CoList_neq_not_lsim :
  forall {A : Type} {l1 l2 : CoList A},
    CoList_neq l1 l2 -> ~ lsim l1 l2.
(* begin hide *)
Proof.
  induction 1; intros [[]]; try congruence.
Qed.
(* end hide *)

Lemma nlsim_neq :
  forall {A : Type} {l1 l2 : CoList A},
    ~ lsim l1 l2 -> l1 <> l2.
(* begin hide *)
Proof.
  intros A l1 l2 Hsim Heq.
  subst.
  apply Hsim, lsim_refl.
Qed.
(* end hide *)

Lemma CoList_neq_antirefl :
  forall {A : Type} (l : CoList A),
    ~ CoList_neq l l.
(* begin hide *)
Proof.
  intros A l H.
  apply CoList_neq_not_lsim, nlsim_neq in H.
  contradiction.
Qed.
(* end hide *)

#[global] Hint Constructors CoList_neq : core.

Lemma CoList_neq_sym :
  forall {A : Type} {l1 l2 : CoList A},
    CoList_neq l1 l2 -> CoList_neq l2 l1.
(* begin hide *)
Proof.
  induction 1; eauto.
Qed.
(* end hide *)

(** ** [conil] i [cocons] *)

(** Zdefiniuj [conil], czyli kolistę pustą, oraz [cocons], czyli funkcję,
    która dokleja do kolisty nową głowę. Udowodnij, że [cocons] zachowuje
    i odbija bipodobieństwo. *)

(* begin hide *)

Definition conil {A : Type} : CoList A :=
{|
  uncons := NilF
|}.

Definition cocons {A : Type} (h : A) (t : CoList A) : CoList A :=
{|
  uncons := ConsF h t
|}.
(* end hide *)

Lemma lsim_cocons :
  forall (A : Type) (x y : A) (l1 l2 : CoList A),
    x = y -> lsim l1 l2 -> lsim (cocons x l1) (cocons y l2).
(* begin hide *)
Proof.
  constructor. econstructor 2; cbn; try reflexivity; assumption.
Qed.
(* end hide *)

Lemma lsim_cocons_inv :
  forall (A : Type) (x y : A) (l1 l2 : CoList A),
    lsim (cocons x l1) (cocons y l2) -> x = y /\ lsim l1 l2.
(* begin hide *)
Proof.
  intros. destruct H as [[]]; cbn in *.
    congruence.
    subst. inv H1. inv H2. split; trivial.
Qed.
(* end hide *)

(** ** [len] *)

(** Przygodę z funkcjami na kolistach zaczniemy od długości. Tak jak zwykła,
    induktywna lista ma długość będącą się liczbą naturalną, tak też i
    długość kolisty można wyrazić za pomocą liczby konaturalnej.

    Napisz funkcję [len], która oblicza długość kolisty. Pokaż, że
    bipodobne kolisty mają tę samą długość. Długość kolisty pustej
    oraz [cocons]a powinny być oczywiste. *)

From Typonomikon Require Import F2.

(* begin hide *)
CoFixpoint len {A : Type} (l : CoList A) : conat :=
{|
  out :=
    match uncons l with
    | NilF      => Z
    | ConsF h t => S (len t)
    end;
|}.
(* end hide *)

Lemma sim_len :
  forall (A : Type) (l1 l2 : CoList A),
    lsim l1 l2 -> sim (len l1) (len l2).
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct H as [[]].
    left; cbn; rewrite ?H1, ?H2; reflexivity.
    eright; cbn; rewrite ?H1, ?H2; try reflexivity. apply CH. assumption.
Qed.
(* end hide *)

Lemma len_conil :
  forall A : Type,
    len (@conil A) = zero.
(* begin hide *)
Proof.
  intros. apply eq_out. cbn. reflexivity.
Qed.
(* end hide *)

Lemma len_cocons :
  forall (A : Type) (x : A) (l : CoList A),
    len (cocons x l) = succ (len l).
(* begin hide *)
Proof.
  intros. apply eq_out. cbn. reflexivity.
Qed.
(* end hide *)

(** ** [snoc] *)

(** Zdefiniuj funkcję [snoc], która dostawia element na koniec kolisty. *)

(* begin hide *)
CoFixpoint snoc {A : Type} (l : CoList A) (x : A) : CoList A :=
{|
  uncons :=
    match uncons l with
    | NilF      => ConsF x conil
    | ConsF h t => ConsF h (snoc t x)
    end;
|}.
(* end hide *)

Lemma snoc_cocons :
  forall (A : Type) (l : CoList A) (x y : A),
    lsim (snoc (cocons x l) y) (cocons x (snoc l y)).
(* begin hide *)
Proof.
  cofix CH.
  constructor. econstructor 2; cbn; reflexivity.
Qed.
(* end hide *)

Lemma len_snoc :
  forall (A : Type) (l : CoList A) (x : A),
    sim (len (snoc l x)) (succ (len l)).
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct l as [[| h t]].
    eright; cbn; try reflexivity.
    eright with (len (snoc t x)) (succ (len t)); cbn.
      reflexivity.
      f_equal. apply eq_out. cbn. reflexivity.
      apply CH.
Qed.
(* end hide *)

(** ** [app] *)

(** Zdefiniuj funkcję [app], która skleja dwie kolisty. Czy jest to w ogóle
    możliwe? Czy taka funkcja ma sens? Porównaj z przypadkiem sklejania
    strumieni. *)

(* begin hide *)
CoFixpoint app {A : Type} (l1 l2 : CoList A) : CoList A :=
{|
  uncons :=
    match uncons l1 with
    | NilF      => uncons l2
    | ConsF h t => ConsF h (app t l2)
    end
|}.
(* end hide *)

Lemma app_conil_l :
  forall (A : Type) (l : CoList A),
    app conil l = l.
(* begin hide *)
Proof.
  intros. apply eq_uncons. cbn. reflexivity.
Qed.
(* end hide *)

Lemma app_conil_r :
  forall (A : Type) (l : CoList A),
    lsim (app l conil) l.
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct l as [[| h t]]; cbn.
    left; cbn; reflexivity.
    eright; try reflexivity. apply CH.
Qed.
(* end hide *)

Lemma app_cocons_l :
  forall (A : Type) (x : A) (l1 l2 : CoList A),
    lsim (app (cocons x l1) l2) (cocons x (app l1 l2)).
(* begin hide *)
Proof.
  cofix CH.
  constructor. eright; try reflexivity.
Qed.
(* end hide *)

Lemma len_app :
  forall (A : Type) (l1 l2 : CoList A),
    sim (len (app l1 l2)) (add (len l1) (len l2)).
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct l1 as [[| h1 t1]].
    destruct l2 as [[| h2 t2]].
      left; cbn; reflexivity.
      eright; cbn; reflexivity.
    eright; cbn; try reflexivity. apply CH.
Qed.
(* end hide *)

Lemma snoc_app :
  forall (A : Type) (l1 l2 : CoList A) (x : A),
    lsim (snoc (app l1 l2) x) (app l1 (snoc l2 x)).
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct l1 as [[| h1 t1]]; cbn.
    destruct l2 as [[| h2 t2]]; cbn.
      eright; cbn; eauto. apply lsim_refl.
      eright; cbn; eauto. apply lsim_refl.
    eright; cbn; eauto.
Qed.
(* end hide *)

(* #[global] Hint Constructors lsimF : core. *)

Lemma app_snoc_l :
  forall (A : Type) (l1 l2 : CoList A) (x : A),
    lsim (app (snoc l1 x) l2) (app l1 (cocons x l2)).
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct l1 as [[| h1 t1]]; cbn.
    eright; cbn; eauto. rewrite app_conil_l. apply lsim_refl.
    eright; cbn; eauto.
Qed.
(* end hide *)

Lemma app_assoc :
  forall (A : Type) (l1 l2 l3 : CoList A),
    lsim (app (app l1 l2) l3) (app l1 (app l2 l3)).
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct l1 as [[| h1 t1]]; cbn.
    destruct l2 as [[| h2 t2]]; cbn.
      destruct l3 as [[| h3 t3]]; cbn.
        left; split; reflexivity.
        eright; cbn; eauto. apply lsim_refl.
      eright; cbn; eauto. apply lsim_refl.
    eright; cbn; eauto.
Qed.
(* end hide *)

(** ** [lmap] *)

(** Zdefiniuj funkcję [lmap], która aplikuje funkcję [f : A -> B] do
    każdego elementu kolisty.

    Uwaga: nazywamy tę funkcję [lmap] zamiast po prostu [map], żeby uniknąć
    konfliktu nazw - nazwa [map] jest już zajętą przez analogiczną funkcję
    dla list. *)

(* begin hide *)
CoFixpoint lmap {A B : Type} (f : A -> B) (l : CoList A) : CoList B :=
{|
  uncons :=
    match uncons l with
    | NilF => NilF
    | ConsF h t => ConsF (f h) (lmap f t)
    end
|}.
(* end hide *)

Lemma lmap_conil :
  forall (A B : Type) (f : A -> B),
    lmap f conil = conil.
(* begin hide *)
Proof.
  intros. apply eq_uncons. cbn. reflexivity.
Qed.
(* end hide *)

Lemma lmap_cocons :
  forall (A B : Type) (f : A -> B) (x : A) (l : CoList A),
    lsim (lmap f (cocons x l)) (cocons (f x) (lmap f l)).
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  eright; cbn; eauto.
  apply lsim_refl.
Qed.
(* end hide *)

Lemma len_lmap :
  forall (A B : Type) (f : A -> B) (l : CoList A),
    sim (len (lmap f l)) (len l).
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct l as [[| h t]].
    left; cbn; reflexivity.
    eright; cbn; try reflexivity. apply CH.
Qed.
(* end hide *)

Lemma lmap_snoc :
  forall (A B : Type) (f : A -> B) (l : CoList A) (x : A),
    lsim (lmap f (snoc l x)) (snoc (lmap f l) (f x)).
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct l as [[| h t]]; cbn.
    eright; cbn; eauto. do 2 constructor; cbn; reflexivity.
    eright; cbn; eauto.
Qed.
(* end hide *)

Lemma lmap_app :
  forall (A B : Type) (f : A -> B) (l1 l2 : CoList A),
    lsim (lmap f (app l1 l2)) (app (lmap f l1) (lmap f l2)).
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct l1 as [[| h1 t1]]; cbn.
    destruct l2 as [[| h2 t2]]; cbn.
      left; split; reflexivity.
      eright; cbn; eauto. apply lsim_refl.
    eright; cbn; eauto.
Qed.
(* end hide *)

Lemma lmap_id :
  forall (A : Type) (l : CoList A),
    lsim (lmap id l) l.
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct l as [[| h t]]; cbn.
    left; split; reflexivity.
    eright; cbn; eauto.
Qed.
(* end hide *)

Lemma lmap_comp :
  forall (A B C : Type) (f : A -> B) (g : B -> C) (l : CoList A),
    lsim (lmap g (lmap f l)) (lmap (fun x => g (f x)) l).
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct l as [[| h t]].
    left; cbn; reflexivity.
    eright; cbn; eauto.
Qed.
(* end hide *)

Lemma lmap_ext :
  forall (A B : Type) (f g : A -> B) (l : CoList A),
    (forall x : A, f x = g x) -> lsim (lmap f l) (lmap g l).
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct l as [[| h t]]; cbn.
    left; cbn; reflexivity.
    eright; cbn; eauto.
Qed.
(* end hide *)

(** ** [iterate] *)

(** Zdefiniuj funkcję [iterate], która tworzy nieskończoną kolistę przez
    iterowanie funkcji [f] poczynając od pewnego ustalonego elementu. *)

(* begin hide *)
CoFixpoint iterate {A : Type} (f : A -> A) (x : A) : CoList A :=
{|
  uncons := ConsF x (iterate f (f x))
|}.
(* end hide *)

Lemma len_iterate :
  forall (A : Type) (f : A -> A) (x : A),
    sim (len (iterate f x)) omega.
(* begin hide *)
Proof.
  cofix CH.
  constructor; eright; cbn; try reflexivity.
  apply CH.
Qed.
(* end hide *)

(** ** [piterate] *)

(** Zdefiniuj funkcję [piterate], która tworzy kolistę przez iterowanie
    funkcji częściowej [f : A -> option A] poczynając od pewnego ustalonego
    elementu. *)

(* begin hide *)
CoFixpoint piterate {A : Type} (f : A -> option A) (x : A) : CoList A :=
{|
  uncons := ConsF x
    (match f x with
    | None => conil
    | Some y => piterate f y
    end)
|}.
(* end hide *)

(** ** [zipW] *)

(** Zdefiniuj funkcję [zipW], która bierze funkcję [f : A -> B -> C] oraz
    dwie kolisty [l1] i [l2] i zwraca kolistę, której elementy powstają z
    połączenia odpowiadających sobie elementów [l1] i [l2] za pomocą funkcji
    [f]. *)

(* begin hide *)
CoFixpoint zipW {A B C : Type}
  (f : A -> B -> C) (l1 : CoList A) (l2 : CoList B) : CoList C :=
{|
  uncons :=
    match uncons l1, uncons l2 with
    | ConsF h1 t1, ConsF h2 t2 => ConsF (f h1 h2) (zipW f t1 t2)
    | _, _ => NilF
    end;
|}.
(* end hide *)

Lemma zipW_conil_l :
  forall (A B C : Type) (f : A -> B -> C) (l : CoList B),
    lsim (zipW f conil l) conil.
(* begin hide *)
Proof.
  constructor. left; cbn; reflexivity.
Qed.
(* end hide *)

Lemma zipW_conil_r :
  forall (A B C : Type) (f : A -> B -> C) (l1 : CoList A) (l2 : CoList B),
    sim (len (zipW f l1 l2)) (min (len l1) (len l2)).
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct l1 as [[| h1 t1]],
           l2 as [[| h2 t2]];
  cbn.
    1-3: left; split; reflexivity.
    eright; cbn; try reflexivity. apply CH.
Qed.
(* end hide *)

Lemma len_zipW :
  forall (A B C : Type) (f : A -> B -> C) (l1 : CoList A) (l2 : CoList B),
    sim (len (zipW f l1 l2)) (min (len l1) (len l2)).
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct l1 as [[| h1 t1]],
           l2 as [[| h2 t2]];
  cbn.
    1-3: left; split; reflexivity.
    eright; cbn; try reflexivity. apply CH.
Qed.
(* end hide *)

(** ** [scan] *)

(** Napisz funkcję [scan], która przekształca [l : CoList A] w kolistę
    sum częściowych działania [f : B -> A -> B]. *)

(* begin hide *)
CoFixpoint scan
  {A B : Type} (l : CoList A) (f : B -> A -> B) (b : B) : CoList B :=
{|
  uncons :=
    match uncons l with
    | NilF => NilF
    | ConsF h t => ConsF b (scan t f (f b h))
    end;
|}.
(* end hide *)

Lemma scan_conil :
  forall (A B : Type) (f : B -> A -> B) (b : B),
    lsim (scan conil f b) conil.
(* begin hide *)
Proof.
  constructor. left; cbn; reflexivity.
Qed.
(* end hide *)

Lemma scan_cocons :
  forall (A B : Type) (x : A) (l : CoList A) (f : B -> A -> B) (b : B),
    lsim (scan (cocons x l) f b) (cocons b (scan l f (f b x))).
(* begin hide *)
Proof.
  constructor.
  eright; cbn; eauto.
  apply lsim_refl.
Qed.
(* end hide *)

Lemma len_scan :
  forall (A B : Type) (l : CoList A) (f : B -> A -> B) (b : B),
    sim (len (scan l f b)) (len l).
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct l as [[| h t]]; cbn.
    left; cbn; reflexivity.
    eright; cbn; try reflexivity. apply CH.
Qed.
(* end hide *)

Lemma scan_lmap :
  forall (A B C : Type) (f : B -> C -> B) (g : A -> C) (l : CoList A) (b : B),
    lsim (scan (lmap g l) f b) (scan l (fun b a => f b (g a)) b).
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct l as [[| h t]]; cbn.
    constructor; cbn; reflexivity.
    eright; cbn; eauto.
Qed.
(* end hide *)

(** ** [intersperse] *)

(** Napisz funkcję [intersperse], która działa analogicznie jak dla list. *)

(* begin hide *)
CoFixpoint intersperse {A : Type} (x : A) (l : CoList A) : CoList A :=
{|
  uncons :=
    match uncons l with
    | NilF => NilF
    | ConsF h t =>
      match uncons t with
      | NilF => ConsF h t
      | ConsF h' t' => ConsF h (cocons x (intersperse x t))
      end
    end;
|}.
(* end hide *)

Lemma intersperse_conil :
  forall (A : Type) (x : A),
    lsim (intersperse x conil) conil.
(* begin hide *)
Proof.
  constructor. left; cbn; reflexivity.
Qed.
(* end hide *)

(** Pułapka: czy poniższe twierdzenie jest prawdziwe? *)

Lemma len_intersperse :
  forall (A : Type) (x : A) (l : CoList A),
    len l <> zero -> len l <> succ zero ->
      sim (len (intersperse x l)) ((add (len l) (len l))).
(* begin hide *)
Proof.
  cofix CH.
  intros A x [[| h1 [[| h2 t]]]] H0 H1; cbn.
    contradict H0. apply eq_out. cbn. reflexivity.
    contradict H1. apply eq_out. cbn. f_equal. apply eq_out. cbn. reflexivity.
    do 2 (constructor; eright; cbn; try reflexivity).
Abort.
(* end hide *)

(** ** [splitAt] *)

(** Napisz rekurencyjną funkcję [splitAt]. [splitAt l n] zwraca
    [Some (begin, x, rest)], gdzie [begin] jest listą reprezentującą
    początkowy fragment kolisty [l] o długości [n], [x] to element
    [l] znajdujący się na pozycji [n], zaś [rest] to kolista będącą
    tym, co z kolisty [l] pozostanie po zabraniu z niej [l] oraz [x].
    Jeżeli [l] nie ma fragmentu początkowego o długości [n], funkcja
    [splitAt] zwraca [None]. *)

(* begin hide *)
Fixpoint splitAt
  {A : Type} (l : CoList A) (n : nat) : option (list A * A * CoList A) :=
match n, uncons l with
| _, NilF => None
| 0, ConsF h t => Some ([], h, t)
| Datatypes.S n', ConsF h t =>
  match splitAt t n' with
  | None => None
  | Some (start, mid, rest) => Some (h :: start, mid, rest)
  end
end.
(* end hide *)

(** Funkcji [splitAt] można użyć do zdefiniowania całej gamy funkcji
    działających na kolistach - rozbierających ją na kawałki, wstawiających,
    zamieniających i usuwających elementy, etc. *)

Definition nth {A : Type} (l : CoList A) (n : nat) : option A :=
match splitAt l n with
| None => None
| Some (_, x, _) => Some x
end.

Definition take {A : Type} (l : CoList A) (n : nat) : option (list A) :=
match splitAt l n with
| None => None
| Some (l, _, _) => Some l
end.

Definition drop {A : Type} (l : CoList A) (n : nat) : option (CoList A) :=
match splitAt l n with
| None => None
| Some (_, _, l) => Some l
end.

Fixpoint fromList {A : Type} (l : list A) : CoList A :=
match l with
| [] => conil
| h :: t => cocons h (fromList t)
end.

Definition insert {A : Type} (l : CoList A) (n : nat) (x : A)
  : option (CoList A) :=
match splitAt l n with
| None => None
| Some (start, mid, rest) =>
    Some (app (fromList start) (cocons x (cocons mid rest)))
end.

Definition remove {A : Type} (l : CoList A) (n : nat)
  : option (CoList A) :=
match splitAt l n with
| None => None
| Some (start, _, rest) => Some (app (fromList start) rest)
end.

(** ** [Finite] i [Infinite] *)

(** Zdefiniuj predykaty [Finite] oraz [Infinite], które są spełnione,
    odpowiednio, przez skończone i nieskończone kolisty. Zastanów się
    dobrze, czy definicje powinny być induktywne, czy koinduktywne.

    Udowodnij, że niezaprzeczalnie każda kolista jest skończona lub
    nieskończona oraz że żadna kolista nie jest jednocześnia skończona
    i nieskończona.

    Następnie udowodnij własności tych predykatów oraz sprawdź, które
    kolisty i operacje je spełniają. *)

(* begin hide *)
Inductive Finite {A : Type} : CoList A -> Prop :=
| Finite_None :
    forall l : CoList A, uncons l = NilF -> Finite l
| Finite_Some :
    forall (h : A) (t l : CoList A),
      uncons l = ConsF h t -> Finite t -> Finite l.

Set Warnings "-cannot-define-projection".
CoInductive Infinite {A : Type} (l : CoList A) : Prop :=
{
  h : A;
  t : CoList A;
  p : uncons l = ConsF h t;
  inf' : Infinite t;
}.
Set Warnings "cannot-define-projection".
(* end hide *)

Lemma Finite_or_Infinite_irrefutable :
  forall {A : Type} (l : CoList A),
    ~ ~ (Finite l \/ Infinite l).
(* begin hide *)
Proof.
  intros A l H.
  apply H. right. revert A l H. cofix CH.
  intros A l H.
  destruct l as [[| h t]].
    contradiction H. left. constructor. cbn. reflexivity.
    econstructor.
      cbn. reflexivity.
      apply CH. intros [H' | H']; apply H.
        left. econstructor 2.
          cbn. reflexivity.
          assumption.
        right. econstructor.
          cbn. reflexivity.
          assumption.
Qed.
(* end hide *)

Lemma Finite_not_Infinite :
  forall (A : Type) (l : CoList A),
    Finite l -> Infinite l -> False.
(* begin hide *)
Proof.
  induction 1; intro.
    destruct H0. congruence.
    apply IHFinite. destruct H1. congruence.
Qed.
(* end hide *)

Lemma sim_Infinite :
  forall (A : Type) (l1 l2 : CoList A),
    lsim l1 l2 -> Infinite l1 -> Infinite l2.
(* begin hide *)
Proof.
  cofix CH.
  destruct 1 as [[| h1 t1 h2 t2 p1 p2 p3 H]], 1.
    rewrite H1 in p. congruence.
    econstructor.
      exact p2.
      rewrite p1 in p. inversion p; subst. eapply CH; eauto.
Qed.
(* end hide *)

Lemma len_Finite :
  forall (A : Type) (l : CoList A),
    Finite l -> len l <> omega.
(* begin hide *)
Proof.
  induction 1; cbn.
    intro. apply (f_equal out) in H0. cbn in H0. rewrite H in H0. congruence.
    intro. apply (f_equal out) in H1. cbn in H1. rewrite H in H1. congruence.
Qed.
(* end hide *)

Lemma len_Infinite :
  forall (A : Type) (l : CoList A),
    len l = omega -> Infinite l.
(* begin hide *)
Proof.
  cofix CH.
  destruct l as [[| h t]]; cbn.
    intro. apply (f_equal out) in H. cbn in H. inv H.
    econstructor.
      cbn. reflexivity.
      apply CH. apply (f_equal out) in H. cbn in H. inv H.
Qed.
(* end hide *)

Lemma len_Infinite_conv :
  forall (A : Type) (l : CoList A),
    Infinite l -> sim (len l) omega.
(* begin hide *)
Proof.
  cofix CH.
  constructor.
  destruct l as [[| h t]]; cbn in *.
    inv H. inv p.
    eright; cbn; try reflexivity. apply CH. inv H. cbn in p. inv p.
Qed.
(* end hide *)

Lemma Finite_snoc :
  forall (A : Type) (l : CoList A) (x : A),
    Finite l -> Finite (snoc l x).
(* begin hide *)
Proof.
  induction 1; cbn.
    apply (Finite_Some x conil).
      cbn. rewrite H. reflexivity.
      constructor. cbn. reflexivity.
    apply (Finite_Some h (snoc t x)).
      cbn. rewrite H. reflexivity.
      assumption.
Qed.
(* end hide *)

Lemma Infinite_snoc :
  forall (A : Type) (l : CoList A) (x : A),
    Infinite l -> lsim (snoc l x) l.
(* begin hide *)
Proof.
  cofix CH.
  constructor. destruct H.
  eright; cbn; eauto.
  rewrite p. reflexivity.
Qed.
(* end hide *)

Lemma Infinite_app_l :
  forall (A : Type) (l1 l2 : CoList A),
    Infinite l1 -> Infinite (app l1 l2).
(* begin hide *)
Proof.
  cofix CH.
  destruct 1. econstructor.
    destruct l1; cbn in *; inversion p; cbn. reflexivity.
    apply CH. assumption.
Qed.
(* end hide *)

Lemma Infinite_app_r :
  forall (A : Type) (l1 l2 : CoList A),
    Infinite l2 -> Infinite (app l1 l2).
(* begin hide *)
Proof.
  cofix CH.
  destruct l1 as [[| h t]]; intros.
    destruct H. econstructor.
      lazy. destruct l2; cbn in *. rewrite p. reflexivity.
      assumption.
    econstructor.
      cbn. reflexivity.
      apply CH. assumption.
Qed.
(* end hide *)

Lemma Infinite_app :
  forall (A : Type) (l1 l2 : CoList A),
    Infinite l1 \/ Infinite l2 -> Infinite (app l1 l2).
(* begin hide *)
Proof.
  destruct 1.
    apply Infinite_app_l. assumption.
    apply Infinite_app_r. assumption.
Qed.
(* end hide *)

Lemma Finite_app :
  forall (A : Type) (l1 l2 : CoList A),
    Finite l1 -> Finite l2 -> Finite (app l1 l2).
(* begin hide *)
Proof.
  induction 1; cbn; intros.
    destruct H0.
      left. cbn. rewrite H. assumption.
      eright; eauto. cbn. rewrite H. exact H0.
    eright.
      cbn. rewrite H. reflexivity.
      apply IHFinite. assumption.
Qed.
(* end hide *)

#[global] Hint Constructors Finite : core.

Lemma Finite_app_conv :
  forall (A : Type) (l1 l2 : CoList A),
    Finite (app l1 l2) -> Finite l1 /\ Finite l2.
(* begin hide *)
Proof.
  intros. remember (app l1 l2) as l. revert l1 l2 Heql.
  induction H; intros; subst; cbn in *.
    destruct l1 as [[| h t]]; cbn in H.
      split; auto.
      inv H.
    destruct l1 as [[| h' t']]; cbn in H.
      split; eauto.
      inv H. destruct (IHFinite _ _ eq_refl).
        split; auto. eright; cbn; eauto.
Qed.
(* end hide *)

Lemma Finite_lmap :
  forall (A B : Type) (f : A -> B) (l : CoList A),
    Finite l -> Finite (lmap f l).
(* begin hide *)
Proof.
  induction 1.
    constructor. cbn. rewrite H. reflexivity.
    eright; eauto. cbn. rewrite H. reflexivity.
Qed.
(* end hide *)

Lemma Infinite_lmap :
  forall (A B : Type) (f : A -> B) (l : CoList A),
    Infinite l -> Infinite (lmap f l).
(* begin hide *)
Proof.
  cofix CH.
  destruct 1. econstructor.
    cbn. rewrite p. reflexivity.
    apply CH. assumption.
Qed.
(* end hide *)

Lemma Infinite_iterate :
  forall (A : Type) (f : A -> A) (x : A),
    Infinite (iterate f x).
(* begin hide *)
Proof.
  cofix CH.
  econstructor.
    cbn. reflexivity.
    apply CH.
Qed.
(* end hide *)

Lemma piterate_Finite :
  forall (A : Type) (f : A -> option A) (x : A),
    Finite (piterate f x) -> exists x : A, f x = None.
(* begin hide *)
Proof.
  intros. remember (piterate f x) as l.
  revert f x Heql.
  induction H; intros; subst; cbn in *; inversion H; subst.
  clear H. case_eq (f h); intros; rewrite H in *.
    eapply IHFinite. reflexivity.
    exists h. assumption.
Qed.
(* end hide *)

Lemma Finite_zipW_l :
  forall (A B C : Type) (f : A -> B -> C) (l1 : CoList A) (l2 : CoList B),
    Finite l1 -> Finite (zipW f l1 l2).
(* begin hide *)
Proof.
  intros until 1. revert l2.
  induction H.
    constructor. cbn. rewrite H. reflexivity.
    destruct l2 as [[| h2 t2]]; cbn.
      left. cbn. rewrite H. reflexivity.
      eright.
        cbn. rewrite H. reflexivity.
        apply IHFinite.
Qed.
(* end hide *)

Lemma Finite_zipW_r :
  forall (A B C : Type) (f : A -> B -> C) (l1 : CoList A) (l2 : CoList B),
    Finite l2 -> Finite (zipW f l1 l2).
(* begin hide *)
Proof.
  intros until 1. revert l1.
  induction H.
    destruct l1 as [[| h1 t1]]; constructor; cbn.
      reflexivity.
      rewrite H. reflexivity.
    destruct l1 as [[| h1 t1]]; cbn.
      left. cbn. reflexivity.
      eright.
        cbn. rewrite H. reflexivity.
        apply IHFinite.
Qed.
(* end hide *)

Lemma Infinite_zipW_l :
  forall (A B C : Type) (f : A -> B -> C) (l1 : CoList A) (l2 : CoList B),
    Infinite (zipW f l1 l2) -> Infinite l1.
(* begin hide *)
Proof.
  cofix CH.
  destruct 1. destruct l1 as [[| h1 t1]]; cbn in *.
    inv p.
    econstructor.
      cbn. reflexivity.
      destruct (uncons l2) as []; inv p. eapply CH. eassumption.
Qed.
(* end hide *)

Lemma Infinite_zipW_r :
  forall (A B C : Type) (f : A -> B -> C) (l1 : CoList A) (l2 : CoList B),
    Infinite (zipW f l1 l2) -> Infinite l1.
(* begin hide *)
Proof.
  cofix CH.
  destruct 1.
  destruct l1 as [[| h1 t1]], l2 as [[| h2 t2]]; cbn in *; inv p.
  econstructor; cbn; eauto.
Qed.
(* end hide *)

Lemma Infinite_splitAt :
  forall (A : Type) (n : nat) (l : CoList A),
    Infinite l ->
      exists (start : list A) (x : A) (rest : CoList A),
        splitAt l n = Some (start, x, rest).
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros.
    destruct H.
      rewrite p. exists [], h, t. reflexivity.
      destruct H. rewrite p. destruct (IHn' _ H) as (start & x & rest & IH).
        rewrite IH. exists (h :: start), x, rest. reflexivity.
Qed.
(* end hide *)

(** ** [Exists] i [Forall] *)

(** Zdefiniuj predykaty [Exists P] oraz [Forall P], które są spełnione
    przez kolisty, których odpowiednio jakiś/wszystkie elementy spełniają
    predykat [P]. Zastanów się dobrze, czy definicje powinny być induktywne,
    czy koinduktywne.

    Sprawdź, które z praw de Morgana zachodzą. *)

Inductive Exists {A : Type} (P : A -> Prop) : CoList A -> Prop :=
| Exists_hd :
    forall (l : CoList A) (h : A) (t : CoList A),
      uncons l = ConsF h t -> P h -> Exists P l
| Exists_tl :
    forall (l : CoList A) (h : A) (t : CoList A),
      uncons l = ConsF h t -> Exists P t -> Exists P l.

CoInductive All {A : Type} (P : A -> Prop) (l : CoList A) : Prop :=
{
  All' :
    uncons l = NilF \/
    exists (h : A) (t : CoList A),
      uncons l = ConsF h t /\ P h /\ All P t;
}.

Lemma Exists_not_All :
  forall (A : Type) (P : A -> Prop) (l : CoList A),
    Exists P l -> ~ All (fun x : A => ~ P x) l.
(* begin hide *)
Proof.
  induction 1; destruct 1 as [[H' | (h' & t' & H1' & H2' & H3')]];
  congruence.
Qed.
(* end hide *)

Lemma All_Exists :
  forall (A : Type) (P : A -> Prop) (l : CoList A),
    All P l -> l = conil \/ Exists P l.
(* begin hide *)
Proof.
  intros. destruct H as [[H | (h & t & H1 & H2 & H3)]].
    left. apply eq_uncons. cbn. assumption.
    right. destruct l as [[]]; inv H1. econstructor.
      cbn. reflexivity.
      assumption.
Qed.
(* end hide *)

*)

(*

Fixpoint tocoList {A : Type} (l : list A) : coList A :=
{|
  uncons :=
  match l with
  | [] => None
  | h :: t => Some (h, tocoList t)
  end
|}.

Lemma tocoList_inj :
  forall {A : Type} (l1 l2 : list A),
    tocoList l1 = tocoList l2 -> l1 = l2.
Proof.
  induction l1 as [| h1 t1]; destruct l2 as [| h2 t2]; cbn; inversion 1.
    reflexivity.
    f_equal. apply IHt1. assumption.
Defined.

CoFixpoint from (n : nat) : coList nat :=
{|
  uncons := Some (n, from (S n));
|}.

Definition lhead {A : Type} (l : coList A) : option A :=
match uncons l with
| Some (a, _) => Some a
| _ => None
end.

Definition ltail {A : Type} (l : coList A) : option (coList A) :=
match uncons l with
| Some (_, t) => Some t
| _ => None
end.

Fixpoint lnth {A : Type} (n : nat) (l : coList A) : option A :=
match n, uncons l with
| _, None => None
| 0, Some (x, _) => Some x
| S n', Some (_, l') => lnth n' l'
end.

Eval compute in lnth 511 (from 0).

Definition nats := from 0.

CoFixpoint repeat {A : Type} (x : A) : coList A :=
{|
  uncons := Some (x, repeat x);
|}.

Eval cbn in lnth 123 (repeat 5).

CoFixpoint lapp {A : Type} (l1 l2 : coList A) : coList A :=
match uncons l1 with
| None => l2
| Some (h, t) => {| uncons := Some (h, lapp t l2) |}
end.

CoFixpoint lmap {A B : Type} (f : A -> B) (l : coList A) : coList B :=
{|
  uncons :=
  match uncons l with
  | None => None
  | Some (h, t) => Some (f h, lmap f t)
  end
|}.

Inductive Finite {A : Type} : coList A -> Prop :=
| Finite_nil : Finite {| uncons := None |}
| Finite_cons :
    forall (h : A) (t : coList A),
      Finite t -> Finite {| uncons := Some (h, t) |}.

CoInductive Infinite {A : Type} (l : coList A) : Prop :=
{
  h : A;
  t : coList A;
  p : uncons l = Some (h, t);
  inf' : Infinite t;
}.

Lemma empty_not_Infinite :
  forall A : Type,
    ~ Infinite {| uncons := @None (A * coList A) |}.
Proof.
  intros A []. cbn in p. inversion p.
Qed.

Lemma lmap_Infinite :
  forall (A B : Type) (f : A -> B) (l : coList A),
    Infinite l -> Infinite (lmap f l).
Proof.
  cofix CH.
  destruct 1. econstructor.
    cbn. rewrite p. reflexivity.
    apply CH. assumption.
Qed.

Lemma lapp_Infinite_l :
  forall (A : Type) (l1 l2 : coList A),
    Infinite l1 -> Infinite (lapp l1 l2).
Proof.
Admitted.
(*
  cofix CH.
  intros A l1 l2 Hinf.
  destruct 1. econstructor.
    destruct l1; cbn in *; inversion p; cbn. reflexivity.
    apply CH. assumption.
Qed.
*)

Lemma lapp_Infinite_r :
  forall (A : Type) (l1 l2 : coList A),
    Infinite l2 -> Infinite (lapp l1 l2).
Proof.
Admitted.
(*
  cofix CH.
  destruct l1 as [[[h t] |]]; intros.
    econstructor.
      cbn. reflexivity.
      apply CH. assumption.
    destruct H. econstructor.
      lazy. destruct l2; cbn in *. rewrite p. reflexivity.
      assumption.
Qed.
*)

Lemma Finite_not_Infinite :
  forall (A : Type) (l : coList A),
    Finite l -> ~ Infinite l.
Proof.
  induction 1; intro.
    inversion H. cbn in p. inversion p.
    apply IHFinite. inversion H0; inversion p; subst. assumption.
Qed.

CoInductive bisim2 {A : Type} (l1 l2 : coList A) : Prop :=
{
  bisim2' :
    uncons l1 = None /\ uncons l2 = None \/
    exists (h1 : A) (t1 : coList A) (h2 : A) (t2 : coList A),
      uncons l1 = Some (h1, t1) /\
      uncons l2 = Some (h2, t2) /\
        h1 = h2 /\ bisim2 t1 t2
}.

#[global] Hint Constructors bisim2 : core.

Lemma bisim2_refl :
  forall (A : Type) (l : coList A), bisim2 l l.
Proof.
Admitted.
(*
  cofix CH.
  destruct l as [[[h t]|]].
    constructor. right. exists h, t, h, t; auto.
    constructor. left. cbn. split; reflexivity.
Qed.
*)

Lemma bisim2_symm :
  forall (A : Type) (l1 l2 : coList A),
    bisim2 l1 l2 -> bisim2 l2 l1.
Proof.
  cofix CH.
  destruct 1 as [[[] | (h1 & t1 & h2 & t2 & p1 & p2 & p3 & H)]].
    constructor. left. split; assumption.
    constructor. right. exists h2, t2, h1, t1. auto.
Qed.

Lemma bisim2_trans :
  forall (A : Type) (l1 l2 l3 : coList A),
    bisim2 l1 l2 -> bisim2 l2 l3 -> bisim2 l1 l3.
Proof.
  cofix CH.
  destruct 1 as [[[] | (h11 & t11 & h12 & t12 & p11 & p12 & p13 & H1)]],
           1 as [[[] | (h21 & t21 & h22 & t22 & p21 & p22 & p23 & H2)]];
  subst.
    auto.
    rewrite H0 in p21. inversion p21.
    rewrite H in p12. inversion p12.
    rewrite p12 in p21; inversion p21; subst.
      econstructor. right. exists h22, t11, h22, t22.
        do 3 try split; auto. eapply CH; eauto.
Qed.

Lemma lmap_compose :
  forall (A B C : Type) (f : A -> B) (g : B -> C) (l : coList A),
    bisim2 (lmap g (lmap f l)) (lmap (fun x => g (f x)) l).
Proof.
Admitted.
(*
  cofix CH.
  constructor. destruct l as [[[h t]|]]; [right | left]; cbn.
    exists (g (f h)), (lmap g (lmap f t)),
           (g (f h)), (lmap (fun x => g (f x)) t).
      repeat (split; [reflexivity | idtac]). apply CH.
    do 2 split.
Qed.
*)

Lemma bisim2_Infinite :
  forall (A : Type) (l1 l2 : coList A),
    bisim2 l1 l2 -> Infinite l1 -> Infinite l2.
Proof.
  cofix CH.
  destruct 1 as [[[] | (h1 & t1 & h2 & t2 & p1 & p2 & p3 & H)]], 1.
    rewrite H0 in p. inversion p.
    econstructor.
      exact p2.
      rewrite p1 in p. inversion p; subst. eapply CH; eauto.
Qed.
*)

(*

(* begin hide *)
(** TODO: końcówka kolistowego burdla *)

Ltac inv H := inversion H; subst; clear H.

(*
CoInductive Rev {A : Type} (l r : CoList A) : Prop :=
{
  Rev' :
    (uncons l = None /\ uncons r = None)
    \/
    exists (h : A) (tl tr : CoList A),
      uncons l = Some (h, tl) /\ r = snoc tr h /\ Rev tl tr
}.

Lemma Rev_wut :
  forall (A : Type) (l r : CoList A),
    Infinite l -> Infinite r -> Rev l r.
(* begin hide *)
Proof.
  cofix CH.
  constructor. right. destruct H, H0.
  exists h, t, r. split.
    assumption.
    split.
      apply eq_lsim. apply lsim_symm. apply Infinite_snoc. econstructor; eauto.
      apply CH; auto; econstructor; eauto.
Qed.
(* end hide *)

Lemma Rev_Finite :
  forall (A : Type) (l r : CoList A),
    Rev l r -> Finite r -> Finite l.
(* begin hide *)
Proof.
  intros A l r HRev H. revert l HRev.
  induction H as [r H | h t r' H IH]; intros.
    destruct HRev as [[[H1 H2] | (h & tl & tr & H1 & H2 & H3)]].
      left. assumption.
      subst. cbn in H. destruct (uncons tr) as [[]|]; inv H.
    destruct HRev as [[[H1 H2] | (h' & tl & tr & H1 & H2 & H3)]].
      congruence.
      subst.
Abort.
(* end hide *)

Lemma Rev_Finite :
  forall (A : Type) (l r : CoList A),
    Rev l r -> Finite l -> Finite r.
(* begin hide *)
Proof.
  intros A l r HRev H. revert r HRev.
  induction H; intros.
    destruct HRev as [[[H1 H2] | (h & tl & tr & H1 & H2 & H3)]].
      left. assumption.
      subst. congruence.
    destruct HRev as [[[H1 H2] | (h' & tl & tr & H1 & H2 & H3)]].
      congruence.
      subst. rewrite H1 in H. inv H. apply Finite_snoc, IHFinite.
        assumption.
Qed.
(* end hide *)

Lemma Infinite_Rev :
  forall (A : Type) (l r : CoList A),
    Rev l r -> Infinite l -> Infinite r.
(* begin hide *)
Proof.
  cofix CH.
  destruct 1. (* decompose [ex or and] Revc0; clear Revc0.
    destruct 1. congruence.
    intro. subst. destruct x1 as [[[h t] |]]; cbn.
      econstructor.
        cbn. reflexivity.
        apply (CH _ (cocons x t)).
          constructor. cbn. right. exists x, t, t. auto.
      congruence.
      subst. cbn in *. inversion p; subst. *)
Abort.
(* end hide *)

Lemma Finite_cocons :
  forall (A : Type) (x : A) (l : CoList A),
    Finite l -> Finite (cocons x l).
(* begin hide *)
Proof.
  intros. apply (Finite_Some x l); auto.
Qed.
(* end hide *)

Fixpoint fromList {A : Type} (l : list A) : CoList A :=
{|
  uncons :=
  match l with
  | [] => None
  | h :: t => Some (h, fromList t)
  end
|}.

Lemma fromList_inj  :
  forall {A : Set} (l1 l2 : list A),
    fromList l1 = fromList l2 -> l1 = l2.
(* begin hide *)
Proof.
  induction l1 as [| h1 t1]; destruct l2 as [| h2 t2]; cbn; inversion 1.
    reflexivity.
    f_equal. apply IHt1. assumption.
Defined.
*)
(* end hide *)
*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**
   divides.
   The division predicate.

   @author Olga Caprotti and Martijn Oostdijk
   @version $Revision$
*)

Require Import ZArith.
Require Import Wf_nat.

Require Import lemmas.
Require Import natZ.
Require Import dec.
Require Import exp.

(** * Division on nat *)

Definition Divides (n m : nat) : Prop := exists q : nat, m = n * q.

Lemma div_refl : forall a : nat, Divides a a.
Proof.
   intros. split with 1.
   rewrite <- mult_n_Sm.
   rewrite <- mult_n_O.
   simpl in |- *. reflexivity.
Qed.

Lemma div_trans :
 forall p q r : nat, Divides p q -> Divides q r -> Divides p r.
Proof.
   intros.
   elim H.
   elim H0.
   intros.
   unfold Divides in |- *.
   split with (x0 * x).
   rewrite H1.
   rewrite H2.
   rewrite mult_assoc.
   reflexivity.
Qed.

Lemma div_antisym : forall a b : nat, Divides a b -> Divides b a -> a = b.
Proof.
   intros. elim H. elim H0. intros x Ha y Hb.
   rewrite Hb in Ha.
   rewrite mult_assoc_reverse in Ha.
   elim (mult_ppq_p0q1 a (y * x)). intro.
   rewrite H1 in Hb.
   simpl in Hb. rewrite H1. rewrite Hb. reflexivity.
   intros. elim (mult_pq1_p1q1 y x H1).
   intros.
   rewrite H2 in Hb. rewrite <- mult_n_Sm in Hb. rewrite <- mult_n_O in Hb.
   simpl in Hb. symmetry  in |- *. assumption. assumption.
Qed.

Lemma div_le1 : forall n d : nat, Divides d (S n) -> d <= S n.
Proof.
   unfold Divides in |- *.
   intros.
   elim H.
   intro q.
   case q.
   rewrite <- (mult_n_O d).
   intros.
   discriminate H0.
   intro q1.
   intros.
   rewrite H0.
   apply le_n_nm.
Qed.

Lemma div_le : forall d n : nat, 0 < n -> Divides d n -> d <= n.
Proof.
   intros d n. case n.
   intro. elim (lt_irrefl 0). assumption.
   intros. apply div_le1. assumption.
Qed.

(** Divides with bounded ex quantifier. *)

Definition bDivides (d n : nat) :=
  n = 0 \/ (exists q : nat, q < S n /\ n = d * q).

Lemma divbdiv : forall n d : nat, Divides d n <-> bDivides d n.
Proof.
   unfold Divides in |- *.
   unfold bDivides in |- *.
   split.
   case n.
   left.
   reflexivity.
   right.
   elim H.
   intro q.
   case d.
   simpl in |- *.
   intros.
   discriminate H0.
   intro d1.
   intros.
   split with q.
   split.
   rewrite H0.
   unfold lt in |- *.
   apply le_n_S.
   apply le_n_mn.
   assumption.
   intros.
   elim H.
   intros.
   rewrite H0.
   split with 0.
   rewrite <- (mult_n_O d).
   reflexivity.
   elim H.
   intros.
   rewrite H0.
   split with 0.
   rewrite <- (mult_n_O d).
   reflexivity.
   intros.
   elim H0.
   intros.
   split with x.
   elim H2.
   intros.
   assumption.
Qed.

(** Divides is decidable. *)

Lemma bdivdec : forall n d : nat, bDivides d n \/ ~ bDivides d n.
Proof.
   intros. unfold bDivides in |- *.
   apply ordec.
   apply eqdec.
   apply (exdec (fun q : nat => n = d * q) (S n)).
   intros. apply eqdec.
Qed.

Lemma divdec : forall n d : nat, Divides d n \/ ~ Divides d n.
Proof.
   intros. elim (divbdiv n d).
   intros. elim (bdivdec n d).
   left. apply (H0 H1).
   right. intro. apply H1. apply (H H2).
Qed.

(** If d|n, then either d<sqrt(n) or the other divisor x<sqrt(n). *)

Theorem sqrdivbound :
 forall n d : nat,
 Divides d n ->
 exists x : nat, Divides x n /\ x * x <= n /\ (x = d \/ d * x = n).
Proof.
   intros.
   unfold Divides in H.
   elim H.
   intros.
   rewrite H0.
   elim (sqrbound d x).
   intros.
   split with d.
   split.
   split with x.
   reflexivity.
   split.
   assumption.
   left.
   reflexivity.
   intros.
   split with x.
   split.
   split with d.
   apply mult_comm.
   split.
   assumption.
   right.
   reflexivity.
Qed.

(**
   Division with remainder.
*)

Theorem div_rem :
 forall d n : nat,
 d > 0 -> exists q : nat, (exists r : nat, 0 <= r /\ r < d /\ n = q * d + r).
Proof.
   intros d n.
   apply (lt_wf_ind n). intros N IH. intros.
   elim (le_or_lt d N).

   (* case d<=N *)
   intro.
   elim (le_witness d N). intros x Hx.
   elim (IH x). intro q'. intros. elim H1. intro r'. intros.
   elim H2. intros. elim H4. intros.
   split with (S q'). split with r'.
   split. assumption.
   split. assumption.
   simpl in |- *. rewrite <- Hx. rewrite (plus_assoc_reverse d (q' * d)).
   rewrite <- H6. reflexivity.
   unfold lt in |- *. apply witness_le. split with (pred d). rewrite plus_Snm_nSm.
   rewrite <- (S_pred d 0). rewrite plus_comm. assumption. assumption.
   assumption.
   assumption.

   (* case N<d *)
   intro.
   split with 0. split with N.
   split. apply le_O_n.
   split. assumption.
   simpl in |- *. reflexivity.
Qed.

Lemma div_rem0 :
 forall n d q r : nat, n = q * d + r -> r < d -> Divides d n -> r = 0.
Proof.
   intros.
   elim H1.
   intros.
   rewrite H2 in H.
   rewrite (mult_comm q d) in H.
   apply (le_diff0 (d * q) (d * x)).
   apply le_mult_l.
   apply le_S_n.
   change (x < S q) in |- *.
   apply simpl_lt_mult_l with d.
   rewrite <- (mult_n_Sm d q).
   replace (d * x) with (d * q + r).
   apply plus_lt_compat_l.
   assumption.
   assumption.
Qed.

Theorem notdiv_rem :
 forall d n : nat,
 0 < d ->
 ~ Divides d n ->
 exists q : nat, (exists r : nat, 0 < r /\ r < d /\ n = q * d + r).
Proof.
   intros d n.
   elim (le_or_lt d n).
   intro.
   elim (le_lt_or_eq d n).
   apply (lt_wf_ind n).
   intros N IH. intros.
   elim (lt_witness d N). intros.
   elim H3. intros.
   elim (le_or_lt d x).
   intro.
   elim (le_lt_or_eq d x).
   intro.
   elim (divdec x d).
   intros.
   elim H8.
   intros.
   rewrite H9 in H4.
   rewrite plus_comm in H4.
   rewrite mult_n_Sm in H4.
   elim H2.
   split with (S x0).
   symmetry  in |- *.
   assumption.
   intros.
   elim (IH x).
   intro q'.
   intros.
   elim H9.
   intro r'.
   intros.
   elim H10.
   intros.
   elim H12.
   intros.
   split with (S q').
   split with r'.
   split.
   assumption.
   split.
   assumption.
   simpl in |- *.
   rewrite plus_assoc_reverse.
   rewrite <- H14.
   symmetry  in |- *.
   assumption.
   rewrite <- H4.
   pattern x at 1 in |- *.
   replace x with (0 + x).
   apply plus_lt_compat_r.
   assumption.
   simpl in |- *.
   reflexivity.
   assumption.
   assumption.
   assumption.
   intro.
   elim H2.
   split with 2.
   rewrite mult_comm.
   simpl in |- *.
   rewrite <- (plus_n_O d).
   rewrite <- H4.
   rewrite H7.
   reflexivity.
   assumption.
   intro.
   split with 1.
   split with x.
   split.
   assumption.
   split.
   assumption.
   simpl in |- *.
   rewrite <- (plus_n_O d).
   rewrite H4.
   reflexivity.
   assumption.
   intros.
   elim H2.
   split with 1.
   rewrite mult_comm.
   simpl in |- *.
   rewrite <- (plus_n_O d).
   symmetry  in |- *.
   assumption.
   assumption.
   case n.
   intros.
   elim H1.
   split with 0.
   apply mult_n_O.
   intro n1.
   intros.
   split with 0.
   split with (S n1).
   split.
   apply lt_O_Sn.
   split.
   assumption.
   simpl in |- *. reflexivity.
Qed.

(** Compatibility results. *)

Lemma div_plus_compat :
 forall a b c : nat, Divides a b -> Divides a c -> Divides a (b + c).
Proof.
   intros.
   elim H. intro x. intros.
   elim H0. intro y. intros.
   split with (x + y).
   rewrite H1. rewrite H2. symmetry  in |- *.
   rewrite (mult_comm a). rewrite (mult_comm a). rewrite (mult_comm a).
   apply mult_plus_distr_r.
Qed.

Lemma div_minus_compat :
 forall a b d : nat, Divides d a -> Divides d b -> Divides d (a - b).
Proof.
   intros. elim H. elim H0. intros.
   unfold Divides in |- *. rewrite H1. rewrite H2.
   rewrite (mult_comm d).
   rewrite (mult_comm d).
   rewrite <- mult_minus_distr_r.
   split with (x0 - x).
   apply mult_comm.
Qed.

Lemma div_mult_compat_l :
 forall a b c : nat, Divides a b -> Divides a (b * c).
Proof.
   intros.
   elim H.
   intro x.
   intros.
   unfold Divides in |- *.
   rewrite H0.
   split with (x * c).
   rewrite mult_assoc.
   reflexivity.
Qed.

Lemma div_absexp_compat :
 forall (b : Z) (d : nat),
 Divides d (Z.abs_nat b) -> forall n : nat, Divides d (Z.abs_nat (Exp b (S n))).
Proof.
   intros b d H. elim H. intros k Hk. simple induction n.
   split with k.
   rewrite <- Hk.
   simpl in |- *.
   rewrite abs_mult.
   rewrite mult_comm.
   simpl in |- *.
   rewrite <- plus_n_O.
   reflexivity.
   intros m IH.
   replace (Exp b (S (S m))) with (b * Exp b (S m))%Z.
   rewrite abs_mult.
   apply div_mult_compat_l.
   assumption.
   simpl in |- *. reflexivity.
Qed.

Lemma div_plus_r :
 forall a b d : nat, Divides d a -> Divides d (a + b) -> Divides d b.
Proof.
   intros. elim H. elim H0. intros.
   split with (x - x0).
   rewrite mult_comm.
   rewrite mult_minus_distr_r.
   rewrite mult_comm.
   rewrite <- H1.
   rewrite mult_comm.
   rewrite <- H2.
   rewrite minus_plus.
   reflexivity.
Qed.

(** * Division on Z. *)

Definition ZDivides (x y : Z) : Prop := exists q : Z, y = (x * q)%Z.

Lemma zdivdiv :
 forall a b : Z, ZDivides a b -> Divides (Z.abs_nat a) (Z.abs_nat b).
Proof.
   intros.
   elim H.
   intros d Hd.
   exists (Z.abs_nat d).
   rewrite Hd.
   apply abs_mult.
Qed.

Lemma divzdiv :
 forall a b : Z, Divides (Z.abs_nat a) (Z.abs_nat b) -> ZDivides a b.
Proof.
   intros.
   elim H.
   intros d Hd.
   elim (Zle_or_lt 0 a).
   elim (Zle_or_lt 0 b).

   (* case 0<=b, a<=b *)
   intros.
   exists (Z_of_nat d).
   rewrite <- (inj_abs_pos b).
   rewrite <- (inj_abs_pos a).
   rewrite <- Znat.inj_mult.
   rewrite Hd. reflexivity.
   apply Z.le_ge. assumption.
   apply Z.le_ge. assumption.

   (* case b<0, 0<=a *)
   intros.
   exists (- Z_of_nat d)%Z.
   rewrite <- (Z.opp_involutive b).
   rewrite <- (inj_abs_neg b).
   rewrite <- (inj_abs_pos a).
   rewrite Zmult_comm. rewrite Zopp_mult_distr_l_reverse. rewrite Zmult_comm.
   rewrite <- Znat.inj_mult.
   apply (f_equal (A:=Z)).
   rewrite Hd.
   reflexivity.
   apply Z.le_ge. assumption.
   assumption.

   elim (Zle_or_lt 0 b).

   (* case 0<=b, a<0 *)
   intros.
   exists (- Z_of_nat d)%Z.
   rewrite <- (Z.opp_involutive a).
   rewrite <- (inj_abs_neg a).
   rewrite <- (inj_abs_pos b).
   rewrite Zmult_opp_opp.
   rewrite <- Znat.inj_mult.
   rewrite Hd.
   reflexivity.
   apply Z.le_ge. assumption.
   assumption.

   (* case b<0, a<0 *)
   intros.
   exists (Z_of_nat d).
   rewrite <- (Z.opp_involutive b).
   rewrite <- (Z.opp_involutive a).
   rewrite <- (inj_abs_neg b).
   rewrite <- (inj_abs_neg a).
   rewrite Zopp_mult_distr_l_reverse.
   rewrite <- Znat.inj_mult.
   apply (f_equal (A:=Z)).
   rewrite Hd.
   reflexivity.
   assumption.
   assumption.
Qed.

Lemma zdivdec : forall x d : Z, ZDivides d x \/ ~ ZDivides d x.
Proof.
   intros.
   elim (divdec (Z.abs_nat x) (Z.abs_nat d)).
   left. apply divzdiv. assumption.
   right. intro. apply H. apply zdivdiv. assumption.
Qed.

Lemma zdiv_plus_r :
 forall a b d : Z, ZDivides d a -> ZDivides d (a + b) -> ZDivides d b.
Proof.
   intros.
   elim H.
   elim H0.
   intros.
   split with (x - x0)%Z.
   rewrite Zmult_comm.
   rewrite Zmult_minus_distr_r.
   rewrite Zmult_comm.
   rewrite <- H1.
   rewrite Zmult_comm.
   rewrite <- H2.
   rewrite Zminus_plus.
   reflexivity.
Qed.

Lemma zdiv_plus_compat :
 forall a b c : Z, ZDivides a b -> ZDivides a c -> ZDivides a (b + c).
Proof.
   intros.
   elim H. intro x. intros.
   elim H0. intro y. intros.
   split with (x + y)%Z.
   rewrite H1. rewrite H2. symmetry  in |- *.
   rewrite (Zmult_comm a). rewrite (Zmult_comm a). rewrite (Zmult_comm a).
   apply Zmult_plus_distr_l.
Qed.

Lemma zdiv_mult_compat_l :
 forall a b c : Z, ZDivides a b -> ZDivides a (b * c).
Proof.
   intros.
   elim H.
   intro x.
   intros.
   unfold ZDivides in |- *.
   rewrite H0.
   split with (x * c)%Z.
   rewrite Zmult_assoc.
   reflexivity.
Qed.

Theorem zdiv_rem :
 forall d n : Z,
 (d > 0)%Z ->
 exists q : Z, (exists r : Z, (0 <= r < d)%Z /\ n = (q * d + r)%Z).
Proof.
   intros d n. intro.
   elim (Zle_or_lt 0 n).

   (* case 0<=n *)
   intro. rewrite <- (inj_abs_pos d). rewrite <- (inj_abs_pos n).
   elim (div_rem (Z.abs_nat d) (Z.abs_nat n)).
   intro qn. intros. elim H1. intro rn. intros.
   elim H2. intros. elim H4. intros.
   split with (Z_of_nat qn). split with (Z_of_nat rn).
   split. split. change (Z_of_nat 0 <= Z_of_nat rn)%Z in |- *.
   apply Znat.inj_le. apply le_O_n.
   apply Znat.inj_lt. assumption.
   rewrite <- Znat.inj_mult. rewrite <- Znat.inj_plus. apply Znat.inj_eq.
   assumption. change (Z.abs_nat d > Z.abs_nat 0) in |- *. apply gtzgt.
   apply Zlt_le_weak. apply Z.gt_lt. assumption. apply Zeq_le. reflexivity.
   assumption. apply Z.le_ge. assumption. apply Z.le_ge.
   apply Zlt_le_weak. apply Z.gt_lt. assumption.

   (* case n<0 *)
   intro. rewrite <- (inj_abs_pos d).
   replace n with (- - n)%Z. rewrite <- (inj_abs_neg n).
   elim (div_rem (Z.abs_nat d) (Z.abs_nat n)).
   intro qn. intros. elim H1. intro rn. intros.
   elim H2. intros. elim H4. intros.
   elim (le_lt_or_eq 0 rn).

   (* case 0<rn *)
   intro. split with (- Z_of_nat (S qn))%Z. split with (d - Z_of_nat rn)%Z.
   split. split. rewrite <- (inj_abs_pos d). apply Zle_minus. apply Znat.inj_le.
   apply lt_le_weak. assumption.
   apply Z.le_ge. apply Zlt_le_weak. apply Z.gt_lt. assumption.
   rewrite inj_abs_pos. apply Zplus_lt_reg_l with (Z_of_nat rn).
   unfold Zminus in |- *. rewrite (Zplus_comm d).
   rewrite (Zplus_assoc (Z_of_nat rn)).
   rewrite Zplus_opp_r. simpl in |- *. change (0 + d < Z_of_nat rn + d)%Z in |- *.
   rewrite Zplus_comm. rewrite (Zplus_comm (Z_of_nat rn)). apply Zplus_lt_compat_l.
   change (Z_of_nat 0 < Z_of_nat rn)%Z in |- *. apply Znat.inj_lt. assumption.
   apply Z.le_ge. apply Zlt_le_weak. apply Z.gt_lt. assumption.
   rewrite Znat.inj_S. unfold Z.succ in |- *. rewrite Zopp_mult_distr_l_reverse.
   rewrite Zmult_plus_distr_l. rewrite <- Znat.inj_mult. rewrite Zmult_1_l.
   rewrite (inj_abs_pos d). rewrite Zopp_plus_distr.
   unfold Zminus in |- *. rewrite Zplus_assoc_reverse. rewrite (Zplus_assoc (- d)).
   rewrite Zplus_opp_l. simpl in |- *. rewrite <- Zopp_plus_distr. rewrite <- Znat.inj_plus.
   rewrite <- H6. reflexivity.
   apply Z.le_ge. apply Zlt_le_weak. apply Z.gt_lt. assumption.

   (* case 0=rn *)
   intro.
   split with (- Z_of_nat qn)%Z. split with 0%Z.
   split. split. unfold Z.le in |- *. simpl in |- *. discriminate.
   apply Z.le_lt_trans with (Z_of_nat rn).
   change (Z_of_nat 0 <= Z_of_nat rn)%Z in |- *. apply Znat.inj_le. apply le_O_n.
   apply Znat.inj_lt. assumption.
   rewrite <- Zplus_0_r_reverse. rewrite inj_abs_neg.
   rewrite Zopp_mult_distr_l_reverse. rewrite <- Znat.inj_mult.
   rewrite <- H7 in H6. rewrite <- plus_n_O in H6. rewrite <- H6.
   rewrite inj_abs_neg. reflexivity.
   assumption. assumption. assumption.
   change (Z.abs_nat d > Z.abs_nat 0) in |- *. apply gtzgt. apply Zlt_le_weak.
   apply Z.gt_lt. assumption.
   unfold Z.le in |- *. simpl in |- *. discriminate.
   assumption. assumption.
   apply Z.opp_involutive.
   apply Z.le_ge. apply Zlt_le_weak. apply Z.gt_lt. assumption.
Qed.


Require Import refocusing_substitutions_cs.

Module CallByName <: RED_LANG_CS.

Require Import List.

Parameter var_name : Set.

Inductive term' : Set :=
| Var : var_name -> term'
| Lam : var_name -> term' -> term'
| App : term' -> term' -> term'
| A   : term' -> term'
| C   : term' -> term'.
Definition term := term'.

Inductive value' : Set :=
| vVar : var_name -> value'
| vLam : var_name -> term -> value'.
Definition value := value'.

Inductive redex' : Set :=
| rApp  : value -> term -> redex'
| rAb   : term -> redex'
| rCall : term -> redex'.
Definition redex := redex'.

Definition value_to_term (v : value) : term :=
match v with
| vVar v' => Var v'
| vLam v' t => Lam v' t
end.
Coercion value_to_term : value >-> term.

Lemma value_to_term_injective : forall v v', value_to_term v = value_to_term v' -> v = v'.
Proof.
intros v v0; case v; case v0; simpl; intros; try discriminate; injection H;
intros; subst v1; try subst t; auto.
Qed.

Definition redex_to_term (r : redex) : term :=
match r with
| rApp v t => App (v:term) t
| rAb t => A t
| rCall t => C t
end.
Coercion redex_to_term : redex >-> term.

Lemma redex_to_term_injective : forall r r', redex_to_term r = redex_to_term r' -> r = r'.
Proof with auto.
intros r r0; case r; case r0; intros; try discriminate; simpl in *; injection H; intros; subst...
rewrite (value_to_term_injective _ _ H1)...
Qed.

Parameter subst : term -> var_name -> term -> term.
Parameter fresh_var : unit -> var_name.

Inductive elem_context' : Set :=
| ap_r : term -> elem_context'.
Definition elem_context := elem_context'.
Definition context := list elem_context.
Definition empty := nil : context.
Definition atom_plug (t : term) (ec : elem_context) : term :=
match ec with
| ap_r t0 => App t t0
end.
Definition plug (t : term) (c : context) := fold_left atom_plug c t.
Definition compose (c0 c1 : context) : context := app c0 c1.

Lemma plug_compose : forall c1 c2 r, plug r (compose c1 c2) = plug (plug r c1) c2.
Proof.
apply fold_left_app.
Qed.

Lemma plug_empty : forall t, plug t empty = t.
Proof.
auto.
Qed.

Lemma compose_empty : forall c, compose c empty = c.
Proof.
symmetry; apply app_nil_end.
Qed.

Definition contract (r : redex) (c : context) : option (term * context) :=
match r with
  | rApp v t => match v with
                   | vVar x => None
                   | vLam x t0 => Some (subst t0 x t, c)
                 end
  | rAb t => Some (t, empty)
  | rCall t => let z := fresh_var tt in Some (App t (Lam z (A (plug (Var z) c))), empty)
end.

(*Lemma decompose : forall t : term, (exists v : value, t = v) \/
                    (exists r : redex, exists c : context, plug r c = t).
Proof with auto.
induction t; simpl; [ left; split with (v_var v) | left; split with (v_lam v t) | right  | right | right ]; auto.
elim IHt1; intros.
destruct H as [v H]; exists (beta v t2); exists empty; simpl; subst; auto.
destruct H as [r [c H]]; exists r; exists (compose c (ap_r t2 empty)); rewrite plug_compose; simpl; subst; auto.
exists (ab_red t); exists empty...
exists (call_red t); exists empty...
Qed.
*)
Inductive decomp : Set :=
| d_val : value -> decomp
| d_red : redex -> context -> decomp.

  Inductive interm_dec : Set :=
  | in_red : redex -> interm_dec
  | in_val : value -> interm_dec
  | in_term: term -> elem_context -> interm_dec.

  Definition only_empty (t : term) : Prop := forall t' c, plug t' c = t -> c = empty.
  Definition only_trivial (t : term) : Prop := forall t' c, plug t' c = t -> c = empty \/ exists v, t' = value_to_term v.

Lemma value_trivial : forall v : value, only_trivial (value_to_term v).
Proof with auto.
intros v t c; generalize dependent t; induction c; simpl in *; auto; right.
destruct (IHc _ H) as [H0 | [v0 H0]]; subst; simpl in *;
match goal with [Hv : atom_plug ?t ?a = _ ?v |- _] => destruct a; destruct v; inversion Hv; subst end;
match goal with [ |- exists u, _ ?v = _ u] => exists v end...
Qed.

Lemma redex_trivial : forall r : redex, only_trivial (redex_to_term r).
Proof with auto.
intros r t c; generalize dependent t; induction c; simpl in *; auto; right.
destruct (IHc _ H) as [H0 | [v H0]]; subst; simpl in H; match goal with
[Hvr : atom_plug ?t ?a = _ ?v |- _] => destruct a; destruct v; inversion Hvr; subst end;
match goal with [ |- exists u, _ ?v = _ u] => exists v end...
Qed.

Lemma value_redex : forall (v : value) (r : redex), value_to_term v <> redex_to_term r.
Proof.
  intros v r H; destruct v; destruct r; discriminate H.
Qed.

Lemma ot_subt : forall t t0 ec, only_trivial t -> atom_plug t0 ec = t -> exists v, t0 = value_to_term v.
Proof with auto.
  intros; destruct (H t0 (ec :: nil)) as [H1 | [v H1]]...
  discriminate.
  exists v...
Qed.

  Ltac ot_v t ec :=
  match goal with
  | [Hot : (only_trivial ?H1) |- _] => destruct (ot_subt _ t ec Hot) as [?v HV]; [auto | subst t]
  end.

  Ltac mlr rv :=
  match goal with
  | [ |- (exists v, ?H1 = value_to_term v) \/ (exists r, ?H1 = redex_to_term r)] =>
    match rv with
    | (?v : value) => left; exists v
    | (?r : redex) => right; exists r
    end; simpl; auto
  end.

Lemma trivial_val_red : forall t : term, only_trivial t ->
    (exists v : value, t = value_to_term v) \/ (exists r : redex, t = redex_to_term r).
Proof.
  intros; destruct t.
  mlr (vVar v).
  mlr (vLam v t).
  ot_v t1 (ap_r t2); mlr (rApp v t2).
  mlr (rAb t).
  mlr (rCall t).
Qed.

Definition decomp_to_term (d : decomp) : term :=
  match d with
    | d_val v => value_to_term v
    | d_red r c0 => plug (redex_to_term r) c0
  end.

End CallByName.

Module CallByName_RefLang <: RED_REF_LANG_CS CallByName.

Module R := CallByName.

(** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
Definition dec_term : R.term -> R.interm_dec :=
fun t => match t with
  | R.Var vname => R.in_val (R.vVar vname)
  | R.Lam vname s => R.in_val (R.vLam vname s)
  | R.App t s => R.in_term t (R.ap_r s)
  | R.A t0 => R.in_red (R.rAb t0)
  | R.C t0 => R.in_red (R.rCall t0)
end.

Definition dec_context (ec : R.elem_context) (v : R.value) : R.interm_dec :=
match ec with
  | R.ap_r t => R.in_red (R.rApp v t)
end.

Lemma dec_term_value : forall (v:R.value), dec_term (v:R.term) = R.in_val v.
Proof.
destruct v; simpl; auto.
Qed.
Hint Resolve dec_term_value.

(*Lemma dec_context_not_value : forall (v v0 : value) (c c0 : context), ~dec_context v c = in_val v0 c0.
Proof with auto.
intros; destruct c; discriminate.
Qed.
Hint Resolve dec_context_not_value.*)

  Inductive subterm_one_step : R.term -> R.term -> Prop :=
  | st_1 : forall t t0 ec (DECT : t = R.atom_plug t0 ec), subterm_one_step t0 t.
  Lemma wf_st1 : well_founded subterm_one_step.
  Proof.
    prove_st_wf.
  Qed.

  Definition subterm_order := clos_trans_n1 R.term subterm_one_step.
  Notation " a <| b " := (subterm_order a b) (at level 40).
  Definition wf_sto : well_founded subterm_order := wf_clos_trans_r _ _ wf_st1.

  Definition ec_order : R.elem_context -> R.elem_context -> Prop := fun _ _ => False.
  Notation " a <: b " := (ec_order a b) (at level 40).
  Lemma wf_eco : well_founded ec_order.
  Proof.
    prove_ec_wf.
  Qed.

  Lemma dec_term_red_empty  : forall t r, dec_term t = R.in_red r -> R.only_empty t.
  Proof.
    intros t r H; destruct t; inversion H; subst; clear H;
    intros t0 c0; generalize dependent t0; induction c0; simpl in *; auto; intros;
    assert (hh := IHc0 _ H); subst c0; destruct a; inversion H.
  Qed.
  Lemma dec_term_val_empty  : forall t v, dec_term t = R.in_val v -> R.only_empty t.
    intros t v H; destruct t; inversion H; subst; clear H;
    intros t0 c0; generalize dependent t0; induction c0; simpl in *; auto; intros;
    assert (hh := IHc0 _ H); subst c0; destruct a; inversion H.
  Qed.
  Lemma dec_term_term_top   : forall t t' ec, dec_term t = R.in_term t' ec -> forall ec', ~ec <: ec'.
  Proof.
    intros t t' ec H; destruct t; inversion H; subst; clear H; destruct ec'; intro H; inversion H.
  Qed.
  Lemma dec_context_red_bot : forall ec v r, dec_context ec v = R.in_red r -> forall ec', ~ ec' <: ec.
  Proof.
    intros ec v r H; destruct ec; inversion H; subst; clear H; destruct ec'; intro H; inversion H.
  Qed.
  Lemma dec_context_val_bot : forall ec v v', dec_context ec v = R.in_val v' -> forall ec', ~ ec' <: ec.
  Proof.
    intros ec v v0 H; destruct ec; inversion H.
  Qed.
  Lemma dec_context_term_next : forall ec v t ec', dec_context ec v = R.in_term t ec' -> ec' <: ec /\ forall ec'', ec'' <: ec -> ~ ec' <: ec''.
  Proof.
    intros ec v t ec' H; destruct ec; inversion H.
  Qed.

  Lemma dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t' ec => R.atom_plug t' ec = t
    end.
  Proof.
    destruct t; simpl; auto.
  Qed.
  Lemma dec_context_correct : forall ec v, match dec_context ec v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) ec
    | R.in_val v' => R.value_to_term v' = R.atom_plug (R.value_to_term v) ec
    | R.in_term t ec' => R.atom_plug t ec' = R.atom_plug (R.value_to_term v) ec
    end.
  Proof.
    destruct ec; simpl; auto.
  Qed.

  Lemma ec_order_antisym : forall ec ec0, ec <: ec0 -> ~ ec0 <: ec.
  Proof.
    intros ec ec0 H; destruct ec; destruct ec0; inversion H.
  Qed.
  Lemma dec_ec_ord : forall t0 t1 ec0 ec1, R.atom_plug t0 ec0 = R.atom_plug t1 ec1 -> ec0 <: ec1 \/ ec1 <: ec0 \/ (t0 = t1 /\ ec0 = ec1).
  Proof.
    destruct ec0; destruct ec1; intro H; inversion H; subst; auto.
  Qed.
  Lemma elem_context_det : forall t0 t1 ec0 ec1, ec0 <: ec1 -> R.atom_plug t0 ec0 = R.atom_plug t1 ec1 ->
    exists v, t1 = R.value_to_term v.
  Proof.
    destruct ec0; destruct ec1; intro H; inversion H.
  Qed.

End CallByName_RefLang.

Module CallByNameCCRefSem := RedRefSemCS CallByName CallByName_RefLang.
Module CBNCC_PE_RefSem <: PE_REF_SEM (CallByName).

Module Red_Sem <: RED_REF_SEM_CS CallByName := CallByNameCCRefSem.

Lemma dec_context_not_val : forall v v0 ec, ~(Red_Sem.dec_context ec v = CallByName.in_val v0).
Proof.
  intro v; destruct v0; destruct ec; intro H; inversion H.
Qed.

Lemma dec_term_value : forall v, Red_Sem.dec_term (CallByName.value_to_term v) = CallByName.in_val v.
Proof.
  destruct v; auto.
Qed.

End CBNCC_PE_RefSem.

Module CBNCC_PEM := ProperPEMachineCS CallByName CBNCC_PE_RefSem.

(*Inductive dec : term -> context -> decomp -> Prop :=
| d_dec  : forall (t : term) (c : context) (d : decomp),
               dec_term t c = in_dec d -> dec t c d
| d_v    : forall (t : term) (c c0 : context) (v : value) (d : decomp),
               dec_term t c = in_val v c0 -> decctx v c0 d -> dec t c d
| d_term : forall (t t0 : term) (c c0 : context) (d : decomp),
               dec_term t c = in_term t0 c0 -> dec t0 c0 d -> dec t c d
with decctx : value -> context -> decomp -> Prop :=
| dc_dec  : forall (v : value) (c : context) (d : decomp),
              dec_context v c = in_dec d -> decctx v c d
| dc_val  : forall (v v0 : value) (c c0 : context) (d : decomp),
              dec_context v c = in_val v0 c0 -> decctx v0 c0 d -> decctx v c d
| dc_term : forall (v : value) (c c0 : context) (t : term) (d : decomp),
              dec_context v c = in_term t c0 -> dec t c0 d -> decctx v c d.

Scheme dec_Ind := Induction for dec Sort Prop
with decctx_Ind := Induction for decctx Sort Prop.

(** A redex in context will only ever be reduced to itself *)
Lemma dec_redex_self : forall (r : redex) (c : context), dec (redex_to_term r) c (d_red r c).
Proof with auto.
intros; induction r.
constructor 3 with (v:term) (ap_r t c); simpl...
constructor 2 with (ap_r t c) v; try apply dec_term_value; constructor 1; simpl...
constructor; simpl...
constructor; simpl...
Qed.

(** dec is left inverse of plug *)
Definition decomp_to_term (d : decomp) : term :=
match d with
  | d_val v => value_to_term v
  | d_red r c0 => plug (redex_to_term r) c0
end.
Lemma dec_term_correct : forall t c, match dec_term t c with
  | in_dec d => decomp_to_term d = plug t c
  | in_val v c0 => plug (value_to_term v) c0 = plug t c
  | in_term t0 c0 => plug t0 c0 = plug t c
end.
Proof with auto.
induction t; simpl...
Qed.

Lemma dec_context_correct : forall v c, match dec_context v c with
  | in_dec d => decomp_to_term d = plug (value_to_term v) c
  | in_val v0 c0 => plug (value_to_term v0) c0 = plug (value_to_term v) c
  | in_term t c0 => plug t c0 = plug (value_to_term v) c
end.
Proof with auto.
induction c; simpl...
Qed.

Lemma dec_plug : forall c c0 t d, dec (plug t c) c0 d -> dec t (compose c c0) d.
Proof.
induction c; simpl; auto; intros c0 t0 d X; assert (hh := IHc _ _ _ X).
inversion hh; subst; inversion H; try discriminate; subst; auto.
Qed.

Lemma dec_plug_rev : forall c c0 t d, dec t (compose c c0) d -> dec (plug t c) c0 d.
Proof with auto.
induction c; simpl; auto; intros; apply IHc.
econstructor 3; eauto; simpl...
Qed.

End CallByName.

Module CBN_PEM := ProperPEMachine (CallByName).
Module CBN_Eval := Evaluator (CallByName).
Definition eval_CBN := CBN_Eval.eval.
Definition eval_CBN_PEM := CBN_PEM.REV.eval.

Lemma eval_equiv : forall t v, eval_CBN t v <-> eval_CBN_PEM t v.
Proof with eauto.
intros; split; intros; inversion_clear H; inversion_clear H0;
econstructor; try (econstructor; eauto; fail);
clear H; induction H1; try (constructor; fail);
inversion_clear H0; econstructor; eauto; constructor...
Qed.*)

Module KrivineMachineCallCC <: ABSTRACT_MACHINE.

Definition term := CallByName.term.
Definition value := CallByName.value.
Definition redex := CallByName.redex.
Definition context := CallByName.context.
Definition Var := CallByName.Var.
Definition Lam := CallByName.Lam.
Definition App := CallByName.App.
Definition A := CallByName.A.
Definition C := CallByName.C.
Definition vVar := CallByName.vVar.
Definition vLam := CallByName.vLam.
Definition rApp := CallByName.rApp.
Definition empty := CallByName.empty.
Definition ap_r := CallByName.ap_r.
Definition value_to_term : value -> term := CallByName.value_to_term.
Definition redex_to_term : redex -> term := CallByName.redex_to_term.
Coercion value_to_term : value >-> term.
Coercion redex_to_term : redex >-> term.

Definition contract := CallByName.contract.
Definition plug := CallByName.plug.
Definition compose := CallByName.compose.

Definition decomp := CallByName.decomp.
Definition d_val := CallByName.d_val.
Definition d_red := CallByName.d_red.

Definition configuration := CBNCC_PEM.configuration.
Definition c_init := CBNCC_PEM.c_init.
Definition c_eval := CBNCC_PEM.c_eval.
Definition c_final := CBNCC_PEM.c_final.
Notation " [I a ] " := (c_init a) (at level 40).
Notation " [E a , b ] " := (c_eval a b) (at level 40).
Notation " [F a ] " := (c_final a) (at level 40).

Definition fresh_var := CallByName.fresh_var.

Reserved Notation " c1 → c2 " (at level 30).

Inductive trans : configuration -> configuration -> Prop :=
| t_init : forall t:term, [I t] → [E t, empty]
| t_mt   : forall v:value, [E v:term, empty] → [F v]
| t_abort: forall (t : term) (c : context), [E (A t), c] → [E t, empty]
| t_call : forall (t : term) (c : context),
             let x := fresh_var tt in [E (C t), c] → [E (App t (Lam x (A (plug (Var x) c)))), empty]
| t_app  : forall (t s:term) (c:context),
             [E (App t s), c] → [E t, ap_r s :: c]
| t_val  : forall (v:value) (t0 t:term) (c : context)
             (CONTR : contract (rApp v t0) c = Some (t, c)),
             [E v:term, ap_r t0 :: c] → [E t, c]
where " c1 → c2 " := (trans c1 c2).
Definition transition := trans.

Inductive trans_close : configuration -> configuration -> Prop :=
| one_step   : forall (c0 c1 : configuration), transition c0 c1 -> trans_close c0 c1
| multi_step : forall (c0 c1 c2 : configuration), transition c0 c1 -> trans_close c1 c2 -> trans_close c0 c2.

Inductive eval : term -> value -> Prop :=
| e_intro : forall (t : term) (v : value), trans_close (c_init t) (c_final v) -> eval t v.

Notation " c1 →+ c2 " := (trans_close c1 c2) (at level 35).
Notation " c1 >> c2 " := (CBNCC_PEM.AM.transition c1 c2) (at level 30).
Notation " c1 >>+ c2 " := (CBNCC_PEM.AM.trans_close c1 c2) (at level 35).

Lemma trPE_K : forall c c0, c >> c0 -> c → c0.
Proof with auto.
intros c c0 H; inversion H; subst.
(* init *)
constructor.
(* red *)
destruct t; simpl; simpl in DT; inversion DT; subst;
clear DT; simpl in CONTR; inversion CONTR; subst; clear CONTR; constructor.
(* val -> final *)
destruct t; simpl; simpl in DT; inversion DT; subst;
[cutrewrite (CallByName.Var v0 = value_to_term (vVar v0)) |
cutrewrite (CallByName.Lam v0 t = value_to_term (vLam v0 t))]; auto; constructor.
(* val -> red *)
destruct t; simpl in DT; inversion DT;
destruct ec; simpl in DC; inversion DC; subst;
inversion CONTR; subst.
cutrewrite (CallByName.Lam v0 t = value_to_term (vLam v0 t)); auto; constructor...
(* val -> term, nonexistent *)
destruct ec; discriminate DC.
(* term *)
destruct t; inversion DT; subst; constructor.
Qed.
Hint Resolve trPE_K.

Lemma tcPE_K : forall c c0, c >>+ c0 -> c →+ c0.
Proof.
intros c c0 H; induction H; subst; [ constructor 1 | econstructor 2]; try apply trPE_K; eauto.
Qed.

Lemma evalPE_K : forall t v, CBNCC_PEM.AM.eval t v -> eval t v.
Proof.
intros t v H; inversion H; constructor; apply tcPE_K; auto.
Qed.
Hint Resolve evalPE_K.

Lemma trK_PE : forall c c0, c → c0 -> c >> c0.
Proof with eauto.
intros c c0 H; inversion H; subst; try (econstructor; simpl; eauto; fail);
[constructor | econstructor 4]; simpl...
Qed.
Hint Resolve trK_PE.

Lemma tcK_PE : forall c c0, c →+ c0 -> c >>+ c0.
Proof.
induction 1; [ constructor 1 | econstructor 2]; eauto.
Qed.

Lemma evalK_PE : forall t v, eval t v -> CBNCC_PEM.AM.eval t v.
Proof.
intros t v H; inversion H; constructor; apply tcK_PE; auto.
Qed.
Hint Resolve evalK_PE.

Theorem KrivineMachineCorrect : forall t v, CallByNameCCRefSem.RS.eval t v <-> eval t v.
Proof.
intros t v; rewrite CBNCC_PEM.push_enter_correct; split; auto.
Qed.

End KrivineMachineCallCC.


Set Implicit Arguments.

Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.Structures.Equalities.
Require Import PArith.BinPos.
Require Import NArith.BinNat.
Require Import Bag.TotalOrder.
Require Import Word.WordInterface.

Local Open Scope N_scope.

Module Make (Import W : MAKEWORD).

  Module Export Word := W.

  Lemma eq_dec : forall (m n : t), { m = n } + { m <> n }.
  Proof.
    intros.
    destruct m, n.
    assert ({v = v0} + {v <> v0}) as J.
    { apply N.eq_dec. }
    destruct J; subst.
    + left.
      f_equal.
      apply proof_irrelevance.
    + right.
      unfold not.
      intros.
      inversion H; subst.
      contradiction n.
      reflexivity.
  Qed.

  Definition le (x y : t) : Prop :=
    match (x, y) with
      | (Mk m _, Mk n _) => m <= n
    end.

  Lemma le_reflexivity : forall (x : t), le x x.
  Proof with auto.
    intros.
    destruct x...
    apply N.le_refl.
  Qed.

  Lemma le_antisymmetry : forall (x y : t), le x y -> le y x -> x = y.
  Proof with eauto.
    intros.
    destruct x, y.
    unfold le in *.
    apply N.lt_eq_cases in H.
    apply N.lt_eq_cases in H0.
    destruct H, H0...
    + assert (v < v). eapply N.lt_trans...
      apply N.lt_irrefl in H1. inversion H1.
    + subst...
      assert (l = l0). apply proof_irrelevance.
      subst...
    + subst...
      assert (l = l0). apply proof_irrelevance.
      subst...
    + clear H0; subst.
      assert (l = l0). apply proof_irrelevance.
      subst...
  Qed.

  Lemma le_transitivity : forall (x y z : t), le x y -> le y z -> le x z.
  Proof with eauto.
    intros.
    destruct x, y, z.
    unfold le in *.
    eapply N.le_trans...
  Qed.

  Lemma le_compare : forall (x y : t), { le x y } + { le y x }.
  Proof with eauto.
    intros.
    destruct x, y.
    unfold le in *.
    remember (N.compare v v0) as cmp eqn:J.
    symmetry in J.
    destruct cmp.
    + apply N.compare_eq_iff in J.
      subst.
      left...
      apply N.lt_eq_cases...
    + rewrite ->  N.compare_lt_iff in J.
      left.
      apply N.lt_eq_cases...
    + rewrite ->  N.compare_gt_iff in J.
      right.
      apply N.lt_eq_cases...
  Qed.

  Instance TotalOrder :  TotalOrder le := {
    reflexivity := le_reflexivity;
    antisymmetry := le_antisymmetry;
    transitivity := le_transitivity;
    compare := le_compare;
    eqdec := eq_dec
  }.

End Make.

Module Word8 := Make (Word8).
Module Word12 := Make (Word12).
Module Word16 := Make (Word16).
Module Word32 := Make (Word32).
Module Word48 := Make (Word48).
Module Word64 := Make (Word64).

Existing Instances Word8.TotalOrder Word16.TotalOrder Word12.TotalOrder
  Word32.TotalOrder Word48.TotalOrder Word64.TotalOrder.