(** * G2: Zippery, czyli łażenie po drzewach [TODO] *)

From Typonomikon Require Import D5.

(** * Predykaty na listach i drzewach - przypomnienie (TODO) *)

(** * Indeksowanie drzew (TODO) *)

(** Pamiętasz zapewne funkcję [nth] z rozdziału o listach, której
    celem było znalezienie [n]-tego elementu na liście [l]. Jeżeli
    twoja implementacja była poprawna i elegancka, to wyglądała
    zapewne jakoś tak: *)

Print nth.
(* ===> nth =
        fix nth (A : Type) (n : nat) (l : list A) {struct l} :
        option A :=
          match l with
          | [] => None
          | h :: t =>
            match n with
            | 0 => Some h
            | S n' => nth A n' t
            end
          end
             : forall A : Type, nat -> list A -> option A *)

(** Obraz wyłaniający się z tej definicji jest prosty:
    - w pustej liście nic nie znajdziemy
    - jeżeli lista jest niepusta, to przemierzamy ją, zerkając co i rusz
      na indeks [n]. [0] oznacza "już", zaś [S _] oznacza "jeszcze krok"

    Ma to sens, czyż nie? Zastanówmy się więc teraz, jak można
    indeksować inne struktury danych, takie jak wektory czy drzewa (co
    w zasadzie wyczerpuje pytanie, bo elementy każdego typu induktywnego
    to nic innego jak drzewa). *)

Definition nat' : Type := list unit.

(** Pierwsza rzecz, którą musimy zauważyć, to to, że liczby naturalne i
    listy [unit]ów to w zasadzie to samo. No bo pomyśl:
    - jest [0] i jest [nil]
    - jest [S 0] i jest [tt :: nil]
    - jest [S (S 0)] i jest [tt :: tt :: nil]
    - etc. *)

(** **** Ćwiczenie *)

(** Pokaż, że typy [nat] i [list unit] są izomorficzne. *)

(* begin hide *)
(* TODO *)
(* end hide *)

(** Podsumowując: listy indeksujemy liczbami naturalnymi, które są tym
    samym co listy [unit]ów. Przypadek? Nie sądzę. Można tę konstatację
    sparafrazować tak: [list A] indeksujemy za pomocą [list unit].

    Jest w tym sporo mądrości: [list A] to podłużny byt wypełniony
    elementami typu [A], zaś [list unit] to po prostu podłużny byt -
    jego zawartość jest nieistotna.

    ACHTUNG: to wszystko kłamstwa, sprawa jest skomplikowańsza niż
    myślałem. *)

Module BT.

(* 1 + A * X^2 *)
Inductive BT (A : Type) : Type :=
| E : BT A
| N : A -> BT A -> BT A -> BT A.

Arguments E {A}.
Arguments N {A} _ _ _.

(** Tutaj typ indeksów jest oczywisty: możemy iść do lewego albo prawego poddrzewa,
    co odpowiada konstruktorom [L] i [R], albo oznajmić, że już dotarliśmy do celu,
    co odpowiada konstruktorowi [here]. *)

(* 1 + 2 * X *)
Inductive IndexBT : Type :=
| here : IndexBT
| L : IndexBT -> IndexBT
| R : IndexBT -> IndexBT.

(** Najważniejszą operacją, jaką możemy wykonać mając typ indeksów, jest pójście
    do poddrzewa odpowiadającego temu indeksowi. *)

Fixpoint subtree {A : Type} (i : IndexBT) (t : BT A) : option (BT A) :=
match i, t with
| here, _ => Some t
| L _, E => None
| L i', N _ l _ => subtree i' l
| R _, E => None
| R i', N _ _ r => subtree i' r
end.

(** Znalezienie elementu trzymanego w korzeniu danego poddrzewa jest jedynie
    operacją pochodną. *)

Definition index {A : Type} (i : IndexBT) (t : BT A) : option A :=
match subtree i t with
| Some (N v _ _) => Some v
| _              => None
end.

(** Choć można oczywiście posłużyć się osobną implementacją, która jest równoważna
    powyższej. *)

Fixpoint index' {A : Type} (t : BT A) (i : IndexBT) {struct i} : option A :=
match t, i with
| E, _          => None
| N v _ _, here => Some v
| N _ l _, L i' => index' l i'
| N _ _ r, R i' => index' r i'
end.

Lemma index_index' :
  forall {A : Type} (i : IndexBT) (t : BT A),
    index i t = index' t i.
Proof.
  induction i; destruct t; cbn; intros.
    all: try reflexivity.
    apply IHi.
    apply IHi.
Qed.

End BT.

Module T.

(** Dla drzew z dowolnym rozgałęzieniem jest podobnie jak dla drzew binarnych. *)

(* 1 + A * X^I *)
Inductive T (I A : Type) : Type :=
| E : T I A
| N : A -> (I -> T I A) -> T I A.

Arguments E {I A}.
Arguments N {I A} _ _.

(** Indeksy: albo już doszliśmy ([here]), albo idziemy dalej ([there]). *)

(* 1 + I * X *)
Inductive Index (I : Type) : Type :=
| here : Index I
| there : I -> Index I -> Index I.

Arguments here {I}.
Arguments there {I} _ _.

Fixpoint subtree {I A : Type} (i : Index I) (t : T I A) : option (T I A) :=
match i, t with
| here      , _ => Some t
| there _ _ , E => None
| there j i', N _ f => subtree i' (f j)
end.

Definition index {I A : Type} (i : Index I) (t : T I A) : option A :=
match subtree i t with
| Some (N v _) => Some v
| _            => None
end.

(*
Fixpoint index {I A : Type} (t : T I A) (i : Index I) : option A :=
match t, i with
| E, _ => None
| N v _, here => Some v
| N _ f, there j i' => index (f j) i'
end.
*)
End T.

Module T2.

(** A teraz coś trudniejszego: są dwa konstruktory rekurencyjne o różnej
    liczbie argumentów. *)

(* 1 + A * X + B * X^2 *)
Inductive T (A B : Type) : Type :=
| E : T A B
| NA : A -> T A B -> T A B
| NB : B -> T A B -> T A B -> T A B.

Arguments E  {A B}.
Arguments NA {A B} _ _.
Arguments NB {A B} _ _ _.

(** Jedyny sensowny pomysł na typ indeksów jest taki, że odróżniamy
    [NA] od [NB] - jeżeli chcemy wejść do złego konstruktora, to się
    nam po prostu nie udaje. *)

Inductive Index : Type :=
| here : Index
| therea : Index -> Index
| thereb : bool -> Index -> Index.

(** Jak widać działa, ale co to za działanie. *)

Fixpoint subtree {A B : Type} (i : Index) (t : T A B) : option (T A B) :=
match i, t with
| here           , _           => Some t
| therea       i', (NA _ t')   => subtree i' t'
| thereb false i', (NB _ t' _) => subtree i' t'
| thereb true  i', (NB _ _ t') => subtree i' t'
| _              , _           => None
end.

(** [index] też działa, ale typ zwracany robi się skomplikowańszy. *)

Definition index
  {A B : Type} (i : Index) (t : T A B) : option (A + B) :=
match subtree i t with
| Some (NA a _)   => Some (inl a)
| Some (NB b _ _) => Some (inr b)
| _               => None
end.

End T2.

Module T3.

(** A teraz inny tłist: co jeżeli jest więcej [nil]i? *)

Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Reversible Pattern Implicit.

(* 1 + 1 + A * X * X *)
Inductive T (A : Type) : Type :=
| EL | ER
| N (a : A) (l : T A) (r : T A).

Arguments EL {A}.
Arguments ER {A}.

(** Typ indeksów jest łatwy. *)

Inductive Index : Type :=
| here : Index
| there : bool -> Index -> Index.

Fixpoint subtree {A : Type} (i : Index) (t : T A) : option (T A) :=
match i, t with
| here      , _         => Some t
| there b i', (N _ l r) => if b then subtree i' l else subtree i' r
| _         , _         => None
end.

Inductive Arg (A : Type) : Type :=
| BadIndex
| EmptyLeft
| EmptyRight
| Node (a : A).

Arguments BadIndex   {A}.
Arguments EmptyLeft  {A}.
Arguments EmptyRight {A}.

Definition index {A : Type} (i : Index) (t : T A) : Arg A :=
match subtree i t with
| None           => BadIndex
| Some EL        => EmptyLeft
| Some ER        => EmptyRight
| Some (N a _ _) => Node a
end.

End T3.

(** Przemyślenia: indeksowanie jest dużo bardziej związane z zipperami,
    niż mi się wydawało. Zipper pozwala sfokusować się na jakimś miejscu
    w strukturze i musimy pamiętać, jak do tego miejsca doszliśmy, tj.
    co pominęliśmy po drodze.

    Jeżeli zależy nam wyłącznie na tym, aby pokazać palcem na dane
    miejsce w strukturze, to nie musimy pamiętać, co pominęliśmy.
    Podsumowując: intuicja dotycząca typów indeksów oraz zipperów
    jest dość jasna, ale związki z różniczkowaniem są mocno pokrętne.

    Kwestią jest też jak przenieść te intuicje na indeksowane rodziny.
    Na pewno indeksami [Vec n] jest [Fin n], a skądinąd [Vec n] to
    [{n : nat & {l : list A | length l = n}}], zaś [Fin n] to [nat],
    tylko trochę ograniczone.

    Zapewne działa to bardzo dobrze... taki huj, jednak nie. *)

From Typonomikon Require Vec.

Module Vec'.

Set Warnings "-notation-overridden".
Import Vec.
Set Warnings "notation-overridden".

(** A teraz to samo dla rodzin indeksowanych. *)

Print vec.
(* ===> Inductive vec (A : Type) : nat -> Type :=
        | vnil : vec A 0
        | vcons : forall n : nat, A -> vec A n -> vec A (S n)
*)

Inductive Fin : nat -> Type :=
| FZ : forall n : nat, Fin (S n)
| FS : forall n : nat, Fin n -> Fin (S n).

Arguments FZ {n}.
Arguments FS {n} _.

Fixpoint index {A : Type} {n : nat} (i : Fin n) (v : vec A n) : A.
Proof.
  destruct i as [| n i'].
    inversion v. exact X.
    inversion v. exact (index _ _ i' X0).
Defined.

End Vec'.

Module hTree.

Inductive T (A : Type) : nat -> Type :=
| E : T A 0
| N : forall {n m : nat},
        A -> T A n -> T A m -> T A (S (max n m)).

(** To jednak działa inaczej niż myślałem. *)

End hTree.

From Typonomikon Require G1.

Module W.

Import G1.

Inductive IW {A : Type} (B : A -> Type) : Type :=
| here  : IW B
| there : forall x : A, B x -> IW B -> IW B.

Arguments here {A B}.
Arguments there {A B x} _.

Definition A (X : Type) : Type := unit + X.

Definition B {X : Type} (a : A X) : Type :=
match a with
| inl _ => False
| inr _ => unit
end.

Fixpoint nat_IW {X : Type} (n : nat) : (@IW (A X) (@B X)).
Proof.
  destruct n as [| n'].
    exact here.
    eapply there. Unshelve.
Abort.

End W.

(** * Zippery dla list - chodzenie po linie (TODO) *)

(** * Szukanie dziury w typie, czyli różniczkowanie (TODO) *)

(** * Zippery dla typów induktywnych (TODO) *)

(** * Zippery dla typów koinduktywnych (TODO) *)


Require Import Coq.Arith.Arith.
Require Import SfLib.
Require Import Imp.
Require Import Smallstep.

Hint Constructors multi.

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

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

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

Definition value t := bvalue t \/ nvalue t.

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

Fixpoint nat_to_tm (n : nat) : tm :=
  match n with
    | 0   => tzero
    | S n => tsucc (nat_to_tm n)
  end.

Fixpoint bool_to_tm (b : bool) : tm :=
  if b then ttrue else tfalse.

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

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

Hint Constructors step.

Notation step_normal_form := (normal_form step).

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

Hint Unfold stuck.

(* Exercise: 2 stars (some_term_is_stuck) *)

Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  exists (tsucc ttrue).
  split; intro contra; solve by inversion 3.
Qed.

(* END some_term_is_stuck. *)

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

Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  intros t [bval | nval]; intro contra; destruct contra.
  - solve by inversion 2.
  - generalize dependent x.
(*  induction t; inversion nval; intros; try solve by inversion.
    inversion H1; subst.
    apply IHt with t2; assumption.
Qed. *)
    induction nval; intros; inversion H; subst.
    apply IHnval with t2; assumption.
Qed.

(* END value_is_nf. *)

(* Exercise: 3 stars, optional (step_deterministic) *)

Lemma n_normal :
  forall n n', nvalue n -> (n ==> n' -> False).
Proof.
  intros. assert (value n) by (right; assumption).
  apply value_is_nf in H1. unfold normal_form in H1.
  apply H1. exists n'. assumption.
Qed.

Ltac nvalue_step :=
  match goal with
    H1 : nvalue ?E, H2 : ?E ==> ?F |- _ =>
        eapply n_normal in H1; eauto; contradiction
  end.

Ltac deterministic_tac :=
  match goal with
    H1 : ?R ?E ?F, H2 : forall e, ?R ?E e -> ?G = e |- _ =>
      solve [ apply H2 in H1; subst; trivial ]
  end
  || fail "is not a deterministic relation".

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
  unfold deterministic.
  intros.
  generalize dependent y2.
  induction H; intros; inversion H0; subst; try solve by inversion;
    try solve_by_inversion_step (try nvalue_step); trivial;
    try deterministic_tac.
Qed.

(* END step_deterministic. *)

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

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

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

Hint Constructors has_type.

(* Exercise: 1 star, optional (succ_hastype_nat__hastype_nat) *)

Example succ_hastype_nat__hastype_nat : forall t,
  |- tsucc t \in TNat ->
  |- t \in TNat.
Proof.
  intros. inversion H. assumption.
Qed.

(* END succ_hastype_nat__hastype_nat. *)

Lemma bool_canonical : forall t,
  value t -> (|- t \in TBool <-> bvalue t).
Proof.
  split; intros; inversion H0; subst; auto; inversion H; solve by inversion.
Qed.

Lemma nat_canonical : forall n,
  value n -> (|- n \in TNat <-> nvalue n).
Proof.
  split; intros.
  - inversion H; try assumption; solve by inversion 2.
  - induction H0; auto.
Qed.

(* Exercise: 3 stars (finish_progress) *)

Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t ==> t'.
Proof.
  intros.
  induction H; auto.
  - right. destruct IHhas_type1.
    + apply bool_canonical in H; try assumption.
      inversion H; subst; [ exists t2 | exists t3 ]; auto.
    + destruct H2. exists (tif x t2 t3). auto.
  - destruct IHhas_type.
    + left. right. constructor. apply nat_canonical; auto.
    + right. destruct H0. exists (tsucc x). auto.
  - right. destruct IHhas_type.
    + apply nat_canonical in H; try assumption. clear H0.
      inversion H; subst; [ exists tzero | exists t0 ]; auto.
    + destruct H0. exists (tpred x). auto.
  - right. destruct IHhas_type.
    + apply nat_canonical in H; try assumption; clear H0.
      inversion H; subst; [ exists ttrue | exists tfalse ]; auto.
    + destruct H0. exists (tiszero x). auto.
Qed.

(* END finish_progress. *)

(* Exercise: 3 stars, advanced (finish_progress_informal) *)

(*
If the last rule in the derivation is `tsucc t`, then either |- t \in Nat or
there exists t' such that t ==> t'. In the first case, `tsucc t` is a value by
nv_succ and the fact that `t` is an nvalue by nat_canonical. In the second,
there exists a step (t ==> t' -> tsucc t ==> tsucc t').

If the last rule is `tpred t`, then either |- t \in Nat or there exists t' such
that t ==> t. In all these cases there exists a next step. If |- t \in Nat,
then it is an nvalue and is thus either an tzero, applicable for
`tpred tzero ==> tzero`, or tsucc t' for some nvalue t', applicable for
`tpred (tsucc t') ==> t'`. If `t ==> t'`, then `tpred t ==> tpred t'`.

If the last rule is `tiszero t`, then either |- t \in Nat and t in an nvalue,
or `t ==> t'` for some t'. In the first case, t can be tzero or tsucc t' for
some t', the first stepping into ttrue, the second stepping into tfalse. In the
case where `t ==> t'`, `tzero t ==> tzero t'`.
*)

(* END finish_progress_informal. *)

(* Exercise: 1 star (step_review) *)

(*
 + Every well-typed normal form is a value.
 + Every value is a normal form.
 + The single-step reduction relation is a partial function
   (i.e., it is deterministic).
 - The single-step reduction relation is a total function.
*)

(* END step_review. *)

(* Exercise: 2 stars (finish_preservation) *)

Theorem preservation : forall t t' T,
  |- t  \in T ->
  t ==> t'   ->
  |- t' \in T.
Proof with auto.
  intros t t' T Htt Hst. generalize dependent t'.
  induction Htt; intros; inversion Hst; subst...
  inversion Htt...
Qed.

(* END finish_preservation. *)

(* Exercise: 3 stars (preservation_alternate_proof) *)

Theorem preservation' : forall t t' T,
  |- t  \in T ->
  t ==> t'   ->
  |- t' \in T.
Proof with eauto.
  intros t t' T Htt Hst. generalize dependent T.
  induction Hst; intros; inversion Htt...
  inversion H1...
Qed.

(* END preservation_alternate_proof. *)

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

(* Exercise: 1 star (normalize_ex) *)

Theorem normalize_ex : exists e',
  multi (astep empty_state) (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) e'.
Proof. eapply ex_intro. normalize. Qed.

(* END normalize_ex. *)

Hint Constructors astep aval.

(* Exercise: 1 star, optional (normalize_ex') *)

Theorem normalize_ex' : exists e',
  multi (astep empty_state) (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) e'.
Proof. apply ex_intro with (ANum 6). normalize. Qed.

(* END normalize_ex'. *)

(* Exercise: 2 stars, recommended (subject_expansion) *)

Theorem subject_expansion_not_holds :
 ~ (forall t t' T,
    t ==> t' ->
    |- t' \in T ->
    |- t  \in T).
Proof.
  assert (tif ttrue ttrue tzero ==> ttrue) by auto.
  assert (|- ttrue \in TBool) by auto.
  assert (~ |- tif ttrue ttrue tzero \in TBool).
  { intro contra. solve by inversion 2. }
  intro contra. apply H1. apply contra with ttrue; auto.
Qed.

(* END subject_expansion. *)

(* Exercise: 2 stars (variation1) *)

(*
      | T_SuccBool : ∀t,
           ⊢ t ∈ TBool →
           ⊢ tsucc t ∈ TBool

  + Determinism of step (step itself doesn't even change)
  - Progress (`tsucc ttrue` would have correct type but be stuck)
  + Preservation

*)

(* END variation1. *)

(* Exercise: 2 stars (variation2) *)

(*
       | ST_Funny1 : ∀t2 t3,
           (tif ttrue t2 t3) ⇒ t3

  - Determinism of step (`tif ttrue ttrue tfalse`
      could return both ttrue and tfalse)
  + Progress
  + Preservation

*)

(* END variation2. *)

(* Exercise: 2 stars, optional (variation3) *)

(*
       | ST_Funny2 : ∀t1 t2 t2' t3,
           t2 ⇒ t2' →
           (tif t1 t2 t3) ⇒ (tif t1 t2' t3)

  - Determinism of step (`tif tfalse (tiszero tzero) tfalse`
      could become `tfalse` or `tif tfalse ttrue tfalse`)
  + Progress
  + Preservation

*)

(* END variation3. *)

(* Exercise: 2 stars, optional (variation4) *)

(*
       | ST_Funny3 :
          (tpred tfalse) ⇒ (tpred (tpred tfalse))

  + Determinism of step
  + Progress
  + Preservation

*)

(* END variation4. *)

(* Exercise: 2 stars, optional (variation5) *)

(*

       | T_Funny4 :
            ⊢ tzero ∈ TBool

  + Determinism of step
  - Progress (`tif tzero ttrue ttrue` would stall even with a correct type)
  - Preservation (|- tpred tzero \in TNat ==> |- tzero \in TBool)

*)

(* END variation5. *)

(* Exercise: 2 stars, optional (variation6) *)

(*

       | T_Funny5 :
            ⊢ tpred tzero ∈ TBool

  + Determinism of step
  + Progress
  - Preservation (|- tpred tzero \in TBool ==> |- tzero \in TBool)

*)

(* END variation6. *)

(* Exercise: 1 star (remove_predzero) *)

(* Doing so would break the progress property since `tpred tzero` would be type
correct but stuck. *)

(* END remove_predzero. *)

(* Exercise: 4 stars, advanced (prog_pres_bigstep) *)

(* The analog of progress in big-step evaluation is always having a rule for
the next big step. For example, suppose we define a language

          -------
          C n ⇓ n

          t2 ⇓ n2
 ---------------------
 P (C n1) t2 ⇓ n1 + n2

This is a big-step notation, but the progress isn't being make in case of
`P (P (C 0) (C 2)) (C 3)`.

Now, there is no straightforward analog for preservation since there are no
steps through which the types must be preserved. Nevertheless, we are able to
define a type property such that all the programs that have it are either
looped or have a value. For this language, we can have

 ------------------
 |- (C n) \in Const

 |- c1 \in Const  |- t1 \in Exp
 ------------------------------
      |- P c1 t1 \in Exp

*)

(* END prog_pres_bigstep. *)


(* Steve Awodey's book on category theory *)
(******************************************************************************)
(* Chapter 1.3: Categories                                                    *)
(******************************************************************************)
(* @suharahiromichi *)

(*
(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

(*
(2) Proper関数の定義
A Gentle Introduction to Type Classes and Relations in Coq
*)

(*
(3) Setoid を使うようにし、Setsと(P,<=)のインスタンスをつくる。
http://www.iij-ii.co.jp/lab/techdoc/category/category1.html
 *)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import finset fintype.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Notations.
Require Import Morphisms.
Require Import Coq.Setoids.Setoid.

(*
Reserved Notation "x ~> y" (at level 51, left associativity).
*)
Reserved Notation "x \\o y" (at level 51, left associativity).
Reserved Notation "x === y" (at level 71, left associativity).

Generalizable Variables a b c d e.

Class Setoid :=
  {
    carrier : Type;
    eqv : carrier -> carrier -> Prop;
    eqv_equivalence : Equivalence eqv
  }.
Coercion carrier : Setoid >-> Sortclass.
Notation "x === z" := (eqv x z).

Class Category (Obj : Type) (Hom : Obj -> Obj -> Setoid) :=
  {
    hom := Hom where "a ~> b" := (hom a b);
    ob  := Obj;
    id   : forall {a : Obj}, (a ~> a);
    comp : forall {a b c : Obj},
             (a ~> b) -> (b ~> c) -> (a ~> c)
                                       where "f \\o g" := (comp f g);
    comp_respects   : forall {a b c : Obj},
                        Proper (@eqv (a ~> b) ==> @eqv (b ~>c) ==> @eqv (a ~> c)) comp;
    left_identity   : forall `(f : a ~> b), id \\o f === f;
    right_identity  : forall `(f : a ~> b), f \\o id === f;
    associativity   : forall `(f : a ~> b) `(g : b ~> c) `(h : c ~> d),
                        f \\o g \\o h === f \\o (g \\o h)
}.
Coercion ob : Category >-> Sortclass.

Notation "a ~> b"       := (hom a b).
Notation "f === g"      := (eqv f g).
Notation "f \\o g"      := (comp f g).
(* Notation "a ~~{ C }~~> b" := (@hom _ _ C a b). *)

Generalizable Variables Obj Hom Prod.

(* eqv が、Reflexive と Symmetric と Transitive とを満たす。 *)
Instance category_eqv_Equiv `(C : Category Obj) (a b : Obj) :
  Equivalence (@eqv (a ~> b)).
Proof.
  by apply eqv_equivalence.
Qed.

(* comp は eqv について固有関数である。 *)
Instance category_comp_Proper `(C : Category Obj) (a b c : Obj) :
  Proper (@eqv (a ~> b) ==> @eqv (b ~>c) ==> @eqv (a ~> c)) comp.
Proof.
  by apply comp_respects.
Qed.

(* 可換性についての定理を証明する。 *)
Lemma juggle1 : forall `{C : Category}
                       `(f : a ~> b) `(g : b ~> c) `(h : c ~> d) `(k : d ~> e),
                  f \\o g \\o h \\o k === f \\o (g \\o h) \\o k.
Proof.
  intros.
  Check associativity f g h.
  rewrite <- associativity.
  reflexivity.
Defined.

Lemma juggle2 : forall `{C : Category}
                       `(f : a ~> b) `(g : b ~> c) `(h : c ~> d) `(k : d ~> e),
                  f \\o (g \\o (h \\o k)) === f \\o (g \\o h) \\o k.
Proof.
  intros.
  do ! rewrite <- associativity.
  reflexivity.
Defined.

Lemma juggle3 : forall `{C : Category}
                       `(f : a ~> b) `(g : b ~> c) `(h : c ~> d) `(k : d ~> e),
                  f \\o g \\o (h \\o k) === f \\o (g \\o h) \\o k.
Proof.
  intros.
  do ! rewrite <- associativity.
  reflexivity.
Defined.

Reserved Notation "x &&& y" (at level 50, left associativity).

(* 直積 *)
Class Product `{CP : Category Obj}
      `(proj1 : forall {a b : Obj}, (Prod a b) ~> a)
      `(proj2 : forall {a b : Obj}, (Prod a b) ~> b) :=
  {
    (* 仲介射 *)
    mediating : forall {a b x : Obj},
                  (x ~> a) -> (x ~> b) -> (x ~> (Prod a b))
                                            where "f &&& g" := (mediating f g);

    med_commute1 : forall (a b x : Obj) (f : x ~> a) (g : x ~> b),
                     (f &&& g) \\o proj1 === f;
    med_commute2 : forall (a b x : Obj) (f : x ~> a) (g : x ~> b),
                     (f &&& g) \\o proj2 === g;
    med_unique : forall (a b x : Obj) (f : x ~> a) (g : x ~> b) (h : x ~> (Prod a b)),
                   h \\o proj1 === f ->
                   h \\o proj2 === g ->
                   h === (f &&& g)
  }.

(* **** *)
(* Sets *)
(* **** *)
Instance EquivExt : forall (A B : Set), Equivalence (@eqfun A B) := (* notu *)
  {
    Equivalence_Reflexive := @frefl A B;
    Equivalence_Symmetric := @fsym A B;
    Equivalence_Transitive := @ftrans A B
  }.

Instance EqMor : forall (A B : Set), Setoid :=
  {
    carrier := A -> B;
    eqv := @eqfun B A
  }.

Check @Category Set : (Set → Set → Setoid) → Type.
Check EqMor : Set -> Set -> Setoid.
Check @Category Set EqMor : Type.

Program Instance Sets : @Category Set EqMor.
Obligation 3.
Proof.
  rewrite /Sets_obligation_2.
  move=> homab homab' Hhomab hombc hombc' Hhombc.
  move=> x //=.
  rewrite Hhomab.
  rewrite Hhombc.
    by [].
Qed.

(*
Instance Prod : Product prod :=
  {
    proj1 A B := @fst A B;
    proj2 A B := @snd A B ;
    mediating A B X := fun f g x => (f x, g x)
  }.
Proof.
  - by rewrite //=.
       - by rewrite //=.
            - rewrite /commute /= /eqfun.
    move=> A B X f g h H H0 x.
    rewrite -H -H0.
        by apply surjective_pairing.
  Qed.
*)

(* **** *)
(* P,<= *)
(* **** *)
Open Scope coq_nat_scope.
Search "_ <= _".
Check 0 <= 0 : Prop.

Definition eq_le m n (p q : m <= n) := True.

Instance EquivGeq : forall m n, Equivalence (@eq_le m n). (* notu *)
Proof.
    by [].
Qed.

Instance EqLe : forall m n, Setoid :=
  {
    carrier := m <= n;
    eqv := @eq_le m n
  }.

Check @Category nat : (nat → nat → Setoid) → Type.
Check EqLe : nat → nat → Setoid.
Check @Category nat EqLe.

Program Instance P_LE : @Category nat EqLe.
Obligation 2.
Proof.
    by apply (@Le.le_trans a b c).
Defined.
Obligation 3.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  move=> homab homab' Hhomab hombc hombc' Hhombc.
  by rewrite /eq_le.
Defined.
Obligation 4.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.
Obligation 5.
Proof.
  rewrite /P_LE_obligation_1.
  rewrite /P_LE_obligation_2.
  by rewrite /eq_le.
Defined.

(* END *)


From Hammer Require Import Hammer.

Section Relations.
Variable U : Type.

Definition Relation := U -> U -> Prop.
Variable R : Relation.

Definition Reflexive : Prop := forall x : U, R x x.

Definition Transitive : Prop := forall x y z : U, R x y -> R y z -> R x z.

Definition Antisymmetric : Prop := forall x y : U, R x y /\ R y x -> x = y.

Definition Order : Prop := (Reflexive /\ Transitive) /\ Antisymmetric.

Definition Symmetric : Prop := forall x y : U, R x y -> R y x.

Definition Equivalence : Prop := (Reflexive /\ Symmetric) /\ Transitive.

Definition PER : Prop := Symmetric /\ Transitive.

End Relations.
Hint Unfold Reflexive.
Hint Unfold Transitive.
Hint Unfold Antisymmetric.
Hint Unfold Order.
Hint Unfold Symmetric.
Hint Unfold Equivalence.
Hint Unfold PER.

Theorem sym_not_P :
forall (U : Type) (P : Relation U) (x y : U),
Symmetric U P -> ~ P x y -> ~ P y x.
Proof. hammer_hook "Relations" "Relations.sym_not_P".
intros U P x y H' H'0; unfold not at 1 in |- *; intro H'1.
apply H'0; apply H'; auto.
Qed.

Theorem Equiv_from_order :
forall (U : Type) (R : Relation U),
Order U R -> Equivalence U (fun x y : U => R x y /\ R y x).
Proof. hammer_hook "Relations" "Relations.Equiv_from_order".
intros U R H'; red in |- *.
elim H'; intros H'0 H'1; elim H'0; intros H'2 H'3; clear H' H'0.
split; [ split; red in |- * | red in |- * ].
intro x; split; try exact (H'2 x).
intros x y H'; elim H'; intros H'0 H'4; clear H'; auto.
intros x y z H' H'0; elim H'0; intros H'4 H'5; clear H'0; elim H';
intros H'6 H'7; clear H'.
red in H'3.
split; apply H'3 with y; auto.
Qed.
Hint Resolve Equiv_from_order.


Require Import Coq.ZArith.ZArith.
Require Import coqutil.Z.Lia.
Require Import Coq.btauto.Btauto.

Local Open Scope Z_scope.
Local Open Scope bool_scope.

Module Z.

  Lemma testbit_minus1 i (H:0<=i) :
    Z.testbit (-1) i = true.
  Proof.
    destruct i; try blia; exact eq_refl.
  Qed.

  Lemma testbit_mod_pow2 a n i (H:0<=n) :
    Z.testbit (a mod 2 ^ n) i = (i <? n) && Z.testbit a i.
  Proof.
    destruct (Z.ltb_spec i n); rewrite
      ?Z.mod_pow2_bits_low, ?Z.mod_pow2_bits_high by auto; auto.
  Qed.

  Lemma testbit_ones n i (H : 0 <= n) :
    Z.testbit (Z.ones n) i = (0 <=? i) && (i <? n).
  Proof.
    destruct (Z.leb_spec 0 i), (Z.ltb_spec i n); cbn;
      rewrite ?Z.testbit_neg_r, ?Z.ones_spec_low, ?Z.ones_spec_high by blia; trivial.
  Qed.

  Lemma testbit_ones_nonneg n i (Hn : 0 <= n) (Hi: 0 <= i) :
    Z.testbit (Z.ones n) i = (i <? n).
  Proof.
    rewrite testbit_ones by blia.
    destruct (Z.leb_spec 0 i); cbn; solve [trivial | blia].
  Qed.

  Lemma shiftl_spec': forall a n m : Z,
      Z.testbit (Z.shiftl a n) m = negb (m <? 0) && Z.testbit a (m - n).
  Proof.
    intros.
    destruct (Z.ltb_spec m 0).
    - rewrite Z.testbit_neg_r; trivial.
    - apply Z.shiftl_spec. assumption.
  Qed.

  Lemma shiftr_spec': forall a n m : Z,
      Z.testbit (Z.shiftr a n) m = negb (m <? 0) && Z.testbit a (m + n).
  Proof.
    intros.
    destruct (Z.ltb_spec m 0).
    - rewrite Z.testbit_neg_r; trivial.
    - apply Z.shiftr_spec. assumption.
  Qed.

  Lemma lnot_spec' : forall a n : Z,
      Z.testbit (Z.lnot a) n = negb (n <? 0) && negb (Z.testbit a n).
  Proof.
    intros.
    destruct (Z.ltb_spec n 0).
    - rewrite Z.testbit_neg_r; trivial.
    - apply Z.lnot_spec. assumption.
  Qed.

  Lemma div_pow2_bits' : forall a n m : Z,
      0 <= n ->
      Z.testbit (a / 2 ^ n) m = negb (m <? 0) && Z.testbit a (m + n).
  Proof.
    intros.
    destruct (Z.ltb_spec m 0).
    - rewrite Z.testbit_neg_r; trivial.
    - apply Z.div_pow2_bits; trivial.
  Qed.

  Lemma bits_opp' : forall a n : Z,
      Z.testbit (- a) n = negb (n <? 0) && negb (Z.testbit (Z.pred a) n).
  Proof.
    intros.
    destruct (Z.ltb_spec n 0).
    - rewrite Z.testbit_neg_r; trivial.
    - apply Z.bits_opp; trivial.
  Qed.

  Lemma testbit_ones_nonneg' : forall n i : Z,
      0 <= n ->
      Z.testbit (Z.ones n) i = negb (i <? 0) && (i <? n).
  Proof.
    intros.
    destruct (Z.ltb_spec i 0).
    - rewrite Z.testbit_neg_r; trivial.
    - apply testbit_ones_nonneg; trivial.
  Qed.

  Lemma testbit_minus1' : forall i : Z,
      Z.testbit (-1) i = negb (i <? 0).
  Proof.
    intros.
    destruct (Z.ltb_spec i 0).
    - rewrite Z.testbit_neg_r; trivial.
    - apply testbit_minus1; trivial.
  Qed.

  Lemma or_to_plus: forall a b,
      Z.land a b = 0 ->
      Z.lor a b = a + b.
  Proof.
    intros.
    rewrite <- Z.lxor_lor by assumption.
    symmetry. apply Z.add_nocarry_lxor. assumption.
  Qed.

  (* 3 kinds of rewrite lemmas to turn (Z.testbit (Z.some_op ...)) into a boolean expression: *)

  (* 1) lemmas without any hypotheses (these are our favorites) *)
  #[global]
  Hint Rewrite
       Z.lor_spec
       Z.lxor_spec
       Z.land_spec
       Z.ldiff_spec
       Z.testbit_0_l
    : z_bitwise_no_hyps.
  #[global]
  Hint Rewrite <-Z.ones_equiv : z_bitwise_no_hyps.

  (* 2) lemmas which have linear arithmetic hypotheses (good if we can solve the hypotheses) *)
  #[global]
  Hint Rewrite
       Z.shiftl_spec_low
       Z.shiftl_spec_alt
       Z.shiftl_spec
       Z.shiftr_spec_aux
       Z.lnot_spec
       Z.shiftr_spec
       Z.ones_spec_high
       Z.ones_spec_low
       Z.div_pow2_bits
       Z.pow2_bits_eqb
       Z.bits_opp
       Z.testbit_mod_pow2
       Z.testbit_ones_nonneg
       Z.testbit_minus1
       using solve [auto with zarith]
    : z_bitwise_with_hyps.

  (* 3) lemmas where we move some or all linear algebra preconditions into the conclusion
     by turning them into a boolean test
     (used as a fallback to make sure the bitblaster knows that it's worth case-destructing) *)
  #[global]
  Hint Rewrite
       Z.shiftl_spec'
       Z.shiftr_spec'
       Z.lnot_spec'
       Z.div_pow2_bits'
       Z.bits_opp'
       Z.testbit_ones_nonneg'
       Z.testbit_minus1'
       using solve [auto with zarith]
    : z_bitwise_forced_no_hyps.

  Ltac rewrite_bitwise :=
    repeat (autorewrite with z_bitwise_no_hyps;
            autorewrite with z_bitwise_with_hyps);
    autorewrite with z_bitwise_forced_no_hyps.

  Ltac destruct_ltbs :=
    repeat match goal with
           | |- context [ ?a <? ?b ] => destruct (Z.ltb_spec a b)
           end.

  Ltac discover_equal_testbit_indices :=
    repeat match goal with
           | |- context [Z.testbit _ ?i] =>
             assert_fails (is_var i);
             let l := fresh "l" in remember i as l
           end;
    repeat match goal with
           | i: Z, j: Z |- _ => replace i with j in * by blia; clear i
           end.

  Ltac bitblast_core :=
    rewrite_bitwise;
    discover_equal_testbit_indices;
    destruct_ltbs;
    try (exfalso; blia);
    try btauto.

  (* Note: The Coq Standard library already provides a tactic called "Z.bitwise", but
     it's less powerful because it does no splitting *)
  Ltac bitblast := eapply Z.bits_inj'; intros ?i ?Hi; bitblast_core.

End Z.

Goal forall v i j k,
    0 <= i ->
    i <= j ->
    j <= k ->
    Z.land (Z.shiftl (v / 2 ^ i) i) (Z.ones j) +
    Z.land (Z.shiftl (v / 2 ^ j) j) (Z.ones k) =
    Z.land (Z.shiftl (v / 2 ^ i) i) (Z.ones k).
Proof.
  intros. rewrite <- Z.or_to_plus; Z.bitblast.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library 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 library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Arith.
Require Import Compare.
Require Export Nk_ind.
Require Export Npow.
Require Export Ndiv.
Open Scope nat_scope.

(** * Definition of a finite product on [nat] with an index starting from 0 *)
Fixpoint Nfinite_prod_0_n (n:nat) (f:nat -> nat) {struct n} : nat :=
match n with
| 0 => f 0
| S n' => (Nfinite_prod_0_n n' f) * (f n)
end.

(** * Properties of finite product *)
(** Compatibility with equality (limited equality) *)
Lemma Nfinite_prod_subtle_eq_compat : forall n f g,
  (forall k, k <= n -> f k = g k) -> Nfinite_prod_0_n n  f= Nfinite_prod_0_n n g.
Proof.
induction n.
compute. intros.
apply H. trivial.
intros.
unfold Nfinite_prod_0_n. fold Nfinite_prod_0_n.
rewrite (IHn f g).
rewrite (H (S n)).
reflexivity.
trivial.
intros.
apply H.
auto with arith.
Qed.

(** Compatibility with equality (unlimited equality) *)
Lemma Nfinite_prod_eq_compat : forall n f g,
  (forall k, f k = g k) -> Nfinite_prod_0_n n f = Nfinite_prod_0_n n g.
Proof.
intros.
apply Nfinite_prod_subtle_eq_compat.
intros.
apply H.
Qed.

(** One term, upper splitting of finite product *)
Lemma Nfinite_prod_split_upper : forall n f,
  Nfinite_prod_0_n (S n) f = (Nfinite_prod_0_n n f) * (f (S n)).
Proof.
unfold Nfinite_prod_0_n. fold Nfinite_prod_0_n.
reflexivity.
Qed.

(** One term, lower splitting of finite product *)
Lemma Nfinite_prod_split_lower : forall n f,
  Nfinite_prod_0_n (S n) f = (f 0) * (Nfinite_prod_0_n n (fun k => f (S k))).
Proof.
induction n.
intros.
unfold Nfinite_prod_0_n.
reflexivity.
intros.
rewrite Nfinite_prod_split_upper.
rewrite IHn.
rewrite Nfinite_prod_split_upper.
ring.
Qed.

(** Compatibility with multiplication *)
Lemma Nfinite_prod_mult_compat : forall n f a g,
  (forall k, k <= n -> f k = a * g k) -> Nfinite_prod_0_n n f = a^(S n) * Nfinite_prod_0_n n g.
Proof.
induction n.
intros.
unfold Nfinite_prod_0_n.
unfold Npower. unfold iter_nat.
rewrite mult_1_r.
apply H.
auto with arith.
intros.
rewrite Nfinite_prod_split_upper.
rewrite Nfinite_prod_split_upper.
rewrite H.
rewrite IHn with f a g.
rewrite Npower_succ.
rewrite Npower_succ.
rewrite Npower_succ.
ring.
intros.
apply H.
auto with arith.
auto with arith.
Qed.

(** 0 is absorbant *)
Lemma Nfinite_prod_0_absord : forall n f k,
  k <= n -> f k = 0 -> Nfinite_prod_0_n n f = 0.
Proof.
induction n.
intros.
compute.
apply le_n_O_eq in H.
rewrite <- H in H0.
exact H0.

intros.
rewrite Nfinite_prod_split_upper.
apply le_le_S_eq in H.
destruct H.
rewrite IHn with f k.
ring.
auto with arith.
exact H0.
rewrite <- H.
rewrite H0.
ring.
Qed.

(** Factorial is a finite product *)
Lemma Nfactorial_is_finite_prod : forall n,
  fact (S n) = Nfinite_prod_0_n n (fun k => S k).
Proof.
induction n.
compute. reflexivity.
assert (fact (S(S n))=S(S n)*fact(S n)).
compute. reflexivity.
rewrite H. clear H.
rewrite Nfinite_prod_split_upper.
rewrite IHn.
ring.
Qed.

(** Index reversal *)
Lemma Nfinite_prod_index_reversal : forall n f,
  Nfinite_prod_0_n n f = Nfinite_prod_0_n n (fun k => f(n - k)).
Proof.
induction n.
compute. reflexivity.
intros.
rewrite Nfinite_prod_split_upper.
rewrite Nfinite_prod_split_lower.
rewrite IHn.
rewrite <- minus_n_O.
assert (Nfinite_prod_0_n n (fun k : nat => f (S n - S k)) =
  Nfinite_prod_0_n n (fun k : nat => f (n - k))).
apply Nfinite_prod_subtle_eq_compat.
intros.
assert (S n-S k=n-k).
auto with arith.
rewrite H0. reflexivity.
rewrite H.
ring.
Qed.

(** Divisibility of finite product *)
Lemma Nfinite_prod_div : forall n f k p,
  k <= n -> (p | f k) -> (p | Nfinite_prod_0_n n f).
Proof.
induction n.
intros.
inversion H.
rewrite H1 in * |- *.
simpl. auto.
intros.
apply le_le_S_eq in H.
destruct H.
apply le_S_n in H.
simpl.
apply Ndiv_mult_compat.
apply IHn with k.
auto. auto.
simpl.
rewrite mult_comm.
apply Ndiv_mult_compat.
rewrite <- H.
auto.
Qed.