(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose:    Matrix implemented with Inductive List
  author:     ZhengPu Shi
  date:       2021.12

  remark:
  1. use Coq.Vectors.Vector
*)

Require Export MatrixTheory.
Require Import DepList.Matrix.

(* ######################################################################### *)
(** * Basic matrix theory implemented with Dependent List *)
Module BasicMatrixTheoryDL (E : ElementType) <: BasicMatrixTheory E.

  (** Basic library *)
  Export BasicConfig TupleExt SetoidListListExt HierarchySetoid.

  (** Vector and List usually conflicted with same name and same notations *)
  Export List ListNotations.
  Export Vector VectorNotations.

  (* ==================================== *)
  (** ** Matrix element type *)
  Export E.

  Infix "==" := (eqlistA Aeq) : list_scope.
  Infix "==" := (eqlistA (eqlistA Aeq)) : dlist_scope.

  Open Scope nat_scope.
  Open Scope A_scope.
  Open Scope list_scope.
  Open Scope dlist_scope.
  Open Scope vector_scope.
  Open Scope mat_scope.

  (* ==================================== *)
  (** ** Matrix type and basic operations *)

  Definition mat r c := @mat A r c.

  (** matrix equality *)
  Definition meq {r c : nat} := @meq A Aeq r c.
  Infix "==" := meq : mat_scope.

  Lemma meq_equiv r c : Equivalence (@meq r c).
  Proof.
    apply meq_equiv.
  Qed.
  Global Existing Instance meq_equiv.

  (** Get n-th element of a matrix *)
  Definition mnth {r c} (m : mat r c) (ri ci : nat) :=
    mnthNat m ri ci (A0:=A0).
  Notation "m ! i ! j" := (mnth m i j).

  (** meq and mnth should satisfy this constraint *)
  Lemma meq_iff_mnth : forall {r c : nat} (m1 m2 : mat r c),
    m1 == m2 <-> (forall ri ci, ri < r -> ci < c -> (m1!ri!ci == m2!ri!ci)%A).
  Proof.
    intros. apply meq_iff_mnthNat.
  Qed.

  (** linear matrix arithmetic tactic for equation: split goal to every element *)
  Ltac lma :=
    cbv; repeat constructor;
    try ring; try easy.

  (* ==================================== *)
  (** ** Convert between list list and matrix *)

  (** *** list list to mat *)

  Definition l2m {r c} (dl : list (list A)) : mat r c := l2m A0 dl r c.

  (** l2m is a proper morphism *)
  Lemma l2m_aeq_mor : forall r c, Proper (eqlistA (eqlistA Aeq) ==> meq) (@l2m r c).
  Proof.
    Admitted.

  Global Existing Instance l2m_aeq_mor.

  Lemma l2m_inj : forall {r c} (d1 d2 : list (list A)),
    length d1 = r -> width d1 c ->
    length d2 = r -> width d2 c ->
    ~(d1 == d2)%dlist -> ~(@l2m r c d1 == l2m d2).
  Proof.
    intros. apply l2m_inj; auto.
  Qed.

  Lemma l2m_surj : forall {r c} (m : mat r c),
    (exists d, l2m d == m).
  Proof.
    intros. apply l2m_surj.
  Qed.

  (** *** mat to list list *)

  Definition m2l {r c} (m : mat r c) : list (list A) := m2l m.

  (** m2l is a proper morphism *)
  Lemma m2l_aeq_mor : forall r c, Proper (meq ==> eqlistA (eqlistA Aeq)) (@m2l r c).
  Proof.
    Admitted.

  Global Existing Instance m2l_aeq_mor.

  Lemma m2l_length : forall {r c} (m : mat r c), length (m2l m) = r.
  Proof.
    intros. induction m; simpl in *; auto.
  Qed.
  Global Hint Resolve m2l_length : mat.

  Lemma m2l_width : forall {r c} (m : mat r c), width (m2l m) c.
  Proof.
    intros. unfold m2l. induction m; simpl; auto; constructor; auto.
    apply v2l_length.
  Qed.
  Global Hint Resolve m2l_width : mat.

  Lemma m2l_l2m_id : forall {r c} (dl : list (list A)) (H1 : length dl = r)
    (H2 : width dl c), (@m2l r c (l2m dl) == dl)%dlist.
  Proof.
    intros. apply m2l_l2m_id; auto.
  Qed.

  Lemma l2m_m2l_id : forall {r c} (m : mat r c), l2m (m2l m) == m.
  Proof.
    intros. apply l2m_m2l_id; auto.
  Qed.

  Lemma m2l_inj : forall {r c} (m1 m2 : mat r c),
    ~(m1 == m2) -> ~(m2l m1 == m2l m2)%dlist.
  Proof.
    intros. apply m2l_inj. auto.
  Qed.

  Lemma m2l_surj : forall {r c} (d : list (list A)),
    length d = r -> width d c ->
    (exists m, @m2l r c m == d)%dlist.
  Proof.
    intros. apply (m2l_surj (A0:=A0)); auto.
  Qed.

  (* ==================================== *)
  (** ** Specific matrix *)

  Definition mk_mat_1_1 (a11 : A) : mat 1 1 := [[a11]].
  Definition mk_mat_3_1 (a1 a2 a3 : A) : mat 3 1
    := [[a1];[a2];[a3]].
  Definition mk_mat_3_3 (a11 a12 a13 a21 a22 a23 a31 a32 a33 : A) : mat 3 3
    := [[a11;a12;a13];[a21;a22;a23];[a31;a32;a33]].
  Definition mk_mat_2_2 (a11 a12 a21 a22 : A) : mat 2 2
    := [[a11;a12];[a21;a22]].

  (* ==================================== *)
  (** ** Convert between tuples and matrix *)

  (** tuple_3x3 -> mat_3x3 *)
  Definition t2m_3x3 (t : @T_3x3 A) : mat 3 3.
  Proof.
    destruct t as ((t1,t2),t3).
    destruct t1 as ((a11,a12),a13).
    destruct t2 as ((a21,a22),a23).
    destruct t3 as ((a31,a32),a33).
    exact (mk_mat_3_3 a11 a12 a13 a21 a22 a23 a31 a32 a33).
  Defined.

  (** mat_3x3 -> tuple_3x3 *)
  Definition m2t_3x3 (m : mat 3 3) : @T_3x3 A.
    set (l1 := hd m).
    set (l2 := hd (tl m)).
    set (l3 := hd (tl (tl m))).
    set (t1 := (hd l1, hd (tl l1), hd (tl (tl l1)))).
    set (t2 := (hd l2, hd (tl l2), hd (tl (tl l2)))).
    set (t3 := (hd l3, hd (tl l3), hd (tl (tl l3)))).
    exact (t1, t2, t3).
  Defined.

  (** mat_1x2 -> A *)
  Definition scalar_of_mat (m : mat 1 1) := mnth m 0 0.

  (* ==================================== *)
  (** ** Matrix transposition *)

  Definition mtrans {r c} (m : mat r c): mat c r :=
    @mtrans A r c m.

  Notation "m \T" := (mtrans m) : mat_scope.

  Lemma mtrans_trans : forall {r c} (m : mat r c), mtrans (mtrans m) == m.
  Proof.
    apply @mtrans_trans. apply Equiv_Aeq.
  Qed.

  (* ==================================== *)
  (** ** Mapping of matrix *)

  (** Mapping of a matrix *)
  Definition mmap {r c} (f : A -> A) (m : mat r c) : mat r c := mmap m f.

  (** Mapping of two matrices *)
  Definition mmap2 {r c} (f : A -> A -> A) (m1  m2 : mat r c) : mat r c :=
    mmap2 f m1 m2.

  Lemma mmap2_comm : forall {r c} (f : A -> A -> A)
    (f_comm : forall a b : A, (f a b == f b a)%A) (m1 m2 : mat r c),
    mmap2 f m1 m2 == mmap2 f m2 m1.
  Proof.
    intros. apply @mmap2_comm. apply Equiv_Aeq. constructor; auto.
  Qed.

  Lemma mmap2_assoc : forall {r c} (f : A -> A -> A)
    (f_assoc : forall a b c, (f (f a b) c == f a (f b c))%A) (m1 m2 m3 : mat r c),
    mmap2 f (mmap2 f m1 m2) m3 == mmap2 f m1 (mmap2 f m2 m3).
  Proof.
    intros. apply @mmap2_assoc. apply Equiv_Aeq. constructor; auto.
  Qed.

End BasicMatrixTheoryDL.

(* ######################################################################### *)
(** * Decidable matrix theory implemented with Dependent List *)

Module DecidableMatrixTheoryDL (E : DecidableElementType) <: DecidableMatrixTheory E.

  (* Export E. *)
  Include BasicMatrixTheoryDL E.

  (** the equality of two matrices is decidable *)
  Lemma meq_dec : forall {r c}, Decidable (meq (r:=r) (c:=c)).
  Proof.
    intros. apply meq_dec. apply Dec_Aeq.
  Qed.

End DecidableMatrixTheoryDL.

(* ######################################################################### *)
(** * Ring matrix theory implemented with Dependent List *)

Module RingMatrixTheoryDL (E : RingElementType) <: RingMatrixTheory E.

  (* Export E. *)
  Include BasicMatrixTheoryDL E.

  Add Ring ring_thy_inst : Ring_thy.

  (** Zero matrix *)
  Definition mat0 r c : mat r c := mat0 r c (A0:=A0).

  (** Unit matrix *)
  Definition mat1 n : mat n n := mat1 n (A0:=A0)(A1:=A1).

  (** *** Addition of matrix *)
  Definition madd {r c} := @madd A Aadd r c.
  Global Infix "+" := madd : mat_scope.

  (** m1 + m2 = m2 + m1 *)
  Lemma madd_comm : forall {r c} (m1 m2 : mat r c), m1 + m2 == m2 + m1.
  Proof.
    intros. apply madd_comm.
  Qed.

  (** (m1 + m2) + m3 = m1 + (m2 + m3) *)
  Lemma madd_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 + m2) + m3 == m1 + (m2 + m3).
  Proof.
    intros. apply madd_assoc.
  Qed.

  (** 0 + m = m *)
  Lemma madd_0_l : forall {r c} (m : mat r c), (mat0 r c) + m == m.
  Proof.
    intros. apply madd_0_l.
  Qed.

  (** m + 0 = m *)
  Lemma madd_0_r : forall {r c} (m : mat r c), m + (mat0 r c) == m.
  Proof.
    intros. apply madd_0_r.
  Qed.

  (** *** Opposite of matrix *)
  Definition mopp {r c} (m : mat r c) : mat r c :=
    @mopp A Aopp r c m.
  Global Notation "- m" := (mopp m) : mat_scope.

  (** - - m = m *)
  Lemma mopp_opp : forall {r c} (m : mat r c), - - m == m.
  Proof.
    intros. apply mopp_mopp.
  Qed.

  (** m + (-m) = 0 *)
  Lemma madd_opp : forall {r c} (m : mat r c), m + (-m) == mat0 r c.
  Proof.
    intros. apply madd_mopp.
  Qed.

  (** *** Subtraction of matrix *)
  Definition msub {r c} (m1 m2 : mat r c) : mat r c :=
    @msub A Aadd Aopp r c m1 m2.
  Global Infix "-" := msub : mat_scope.

  (** m1 - m2 = - (m2 - m1) *)
  Lemma msub_comm : forall {r c} (m1 m2 : mat r c), m1 - m2 == - (m2 - m1).
  Proof.
    intros. apply msub_comm.
  Qed.

  (** (m1 - m2) - m3 = m1 - (m2 + m3) *)
  Lemma msub_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 - m2) - m3 == m1 - (m2 + m3).
  Proof.
    intros. apply msub_assoc.
  Qed.

  (** 0 - m = - m *)
  Lemma msub_0_l : forall {r c} (m : mat r c), (mat0 r c) - m == - m.
  Proof.
    intros. apply msub_0_l.
  Qed.

  (** m - 0 = m *)
  Lemma msub_0_r : forall {r c} (m : mat r c), m - (mat0 r c) == m.
  Proof.
    intros. apply msub_0_r.
  Qed.

  (** m - m = 0 *)
  Lemma msub_self : forall {r c} (m : mat r c), m - m == (mat0 r c).
  Proof.
    intros. apply msub_self.
  Qed.

  (** *** Scalar multiplication of matrix *)

  (** Left scalar multiplication of matrix *)
  Definition mcmul {r c} (a : A) (m : mat r c) : mat r c :=
    @mcmul A Amul r c a m.

  (** Right scalar multiplication of matrix *)
  Definition mmulc {r c} (m : mat r c) (a : A) : mat r c :=
    @mmulc A Amul r c m a.

  Global Notation "a c* m" := (mcmul a m) : mat_scope.
  Global Notation "m *c a" := (mmulc m a) : mat_scope.

  (** m * a = a * m *)
  Lemma mmulc_eq_mcmul : forall {r c} (a : A) (m : mat r c), m *c a == a c* m.
  Proof.
    intros. apply mmulc_eq_mcmul.
  Qed.

  (** a * (b * m) = (a * b) * m *)
  Lemma mcmul_assoc : forall {r c} (a b : A) (m : mat r c), a c* (b c* m) == (a * b)%A c* m.
  Proof.
    intros. apply mcmul_assoc.
  Qed.

  (** a * (b * m) = b * (a * m) *)
  Lemma mcmul_perm : forall {r c} (a b : A) (m : mat r c), a c* (b c* m) == b c* (a c* m).
  Proof.
    intros. apply mcmul_perm.
  Qed.

  (** a * (m1 + m2) = (a * m1) + (a * m2) *)
  Lemma mcmul_add_distr_l : forall {r c} (a : A) (m1 m2 : mat r c),
      a c* (m1 + m2) == (a c* m1) + (a c* m2).
  Proof.
    intros. apply mcmul_distr_l.
  Qed.

  (** (a + b) * m = (a * m) + (b * m) *)
  Lemma mcmul_add_distr_r : forall {r c} (a b : A) (m : mat r c),
      (a + b)%A c* m == (a c* m) + (b c* m).
  Proof.
    intros. apply mcmul_distr_r.
  Qed.

  (** 0 * m = 0 *)
  Lemma mcmul_0_l : forall {r c} (m : mat r c), A0 c* m == mat0 r c.
  Proof.
    intros. apply mcmul_0_l.
  Qed.

  (** 1 * m = m *)
  Lemma mcmul_1_l : forall {r c} (m : mat r c), A1 c* m == m.
  Proof.
    intros. apply mcmul_1_l.
  Qed.

  (** *** Multiplication of matrix *)
  Definition mmul {r c s} (m1 : mat r c) (m2 : mat c s) : mat r s :=
    @mmul A Aadd A0 Amul r c s m1 m2.

  Global Infix "*" := mmul : mat_scope.

  (** m1 * (m2 + m3) = (m1 * m2) + (m1 * m3) *)
  Lemma mmul_add_distr_l : forall {r c A} (m1 : mat r c) (m2 m3 : mat c A),
    m1 * (m2 + m3) == m1 * m2 + m1 * m3.
  Proof.
    intros. apply mmul_madd_distr_l.
  Qed.

  (** (m1 + m2) * m3 = (m1 * m3) + (m2 * m3) *)
  Lemma mmul_add_distr_r : forall {r c s} (m1 m2 : mat r c) (m3 : mat c s),
    (m1 + m2) * m3 == (m1 * m3) + (m2 * m3).
  Proof.
    intros. apply mmul_madd_distr_r.
  Qed.

  (** (m1 * m2) * m3 = m1 * (m2 * m3) *)
  Lemma mmul_assoc : forall {r c s A} (m1 : mat r c) (m2 : mat c s) (m3 : mat s A),
    (m1 * m2) * m3 == m1 * (m2 * m3).
  Proof.
    intros. apply mmul_assoc.
  Qed.

  (** mat0 * m = mat0 *)
  Lemma mmul_0_l : forall {r c A} (m : mat c A), (mat0 r c) * m == mat0 r A.
  Proof.
    intros. apply mmul_0_l.
  Qed.

  (** m * mat0 = mat0 *)
  Lemma mmul_0_r : forall {r c A} (m : mat r c), m * (mat0 c A) == mat0 r A.
  Proof.
    intros. apply mmul_0_r.
  Qed.

  (** mat1 * m = m *)
  Lemma mmul_1_l : forall {r c} (m : mat r c), (mat1 r) * m == m.
  Proof.
    intros. apply mmul_1_l.
  Qed.

  (** m * mat1 = m *)
  Lemma mmul_1_r : forall {r c} (m : mat r c), m * (mat1 c) == m.
  Proof.
    intros. apply mmul_1_r.
  Qed.

End RingMatrixTheoryDL.

(* ######################################################################### *)
(** * Decidable Field matrix theory implemented with Dependent List *)

Module DecidableFieldMatrixTheoryDL (E : DecidableFieldElementType)
<: DecidableFieldMatrixTheory E.

  (* Export E. *)
  Include RingMatrixTheoryDL E.
  Module Export DecMT := DecidableMatrixTheoryDL E.

  (** meq is decidable *)
  Lemma meq_dec : forall (r c : nat), Decidable (meq (r:=r) (c:=c)).
  Proof.
    intros. apply meq_dec.
  Qed.

  (** ** matrix theory *)

  (** k * m = 0 -> (m = 0) \/ (k = 0) *)
  Lemma mcmul_eq0_imply_m0_or_k0 : forall {r c} (m : mat r c) k,
      let m0 := mat0 r c in
      (k c* m == m0) -> (m == m0) \/ (k == A0)%A.
  Proof.
    intros.
    (* apply mcmul_eq0_imply_m0_or_k0. auto. Qed. *)
  Admitted.

  (** (m <> 0 \/ k * m = 0) -> k = 0 *)
  Lemma mcmul_mnonzero_eq0_imply_k0 : forall {r c} (m : mat r c) k,
      let m0 := mat0 r c in
      ~(m == m0) -> k c* m == m0 -> (k == A0)%A.
  Proof.
    intros.
    (* apply mcmul_mnonzero_eq0_imply_k0 with (m:=m); auto. Qed. *)
  Admitted.

  (** k * m = m -> k = 1 \/ m = 0 *)
  Lemma mcmul_same_imply_coef1_or_mzero : forall {r c} k (m : mat r c),
      k c* m == m -> (k == A1)%A \/ (m == mat0 r c).
  Proof.
    intros.
    (* apply mcmul_same_imply_coef1_or_mzero. auto. Qed. *)
  Admitted.

  (** (m1 <> 0 /\ m2 <> 0 /\ k * m1 = m2) -> k <> 0 *)
  Lemma mcmul_eq_mat_implfy_not_k0 : forall {r c} (m1 m2 : mat r c) k,
      let m0 := mat0 r c in
      ~(m1 == m0) -> ~(m2 == m0) -> k c* m1 == m2 -> ~(k == A0)%A.
  Proof.
    intros.
    (* apply mcmul_eq_mat_implfy_not_k0 with m1 m2; auto. Qed. *)
  Admitted.

End DecidableFieldMatrixTheoryDL.

(** * Extra Properties *)
Module ExtraMatrixTheoryDL (E : DecidableFieldElementType).

  (* Export E. *)
  Include (DecidableFieldMatrixTheoryDL E).

  (** ** Other OPs and PROPs *)

  (** get / set an element of a matrix *)
  Definition mget := @mget A.
  Definition mset := @mset A.

End ExtraMatrixTheoryDL.


(* Make [lia] work for [N] *)

Require Import Arith Lia NArith.

Local Open Scope N_scope.

#[global] Hint Rewrite Nplus_0_r nat_of_Nsucc nat_of_Nplus nat_of_Nminus
  N_of_nat_of_N nat_of_N_of_nat: N.

Theorem nat_of_N_eq : forall n m,
  nat_of_N n = nat_of_N m
  -> n = m.
  intros ? ? H; apply (f_equal N_of_nat) in H;
    autorewrite with N in *; assumption.
Qed.

Theorem Nneq_in : forall n m,
  nat_of_N n <> nat_of_N m
  -> n <> m.
  congruence.
Qed.

Theorem Nneq_out : forall n m,
  n <> m
  -> nat_of_N n <> nat_of_N m.
  intuition idtac.
  match goal with H0 : _ |- _ => apply nat_of_N_eq in H0; tauto end.
Qed.

Theorem Nlt_out : forall n m, n < m
  -> (nat_of_N n < nat_of_N m)%nat.
  unfold N.lt; intros ?? H.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_Lt_lt; assumption.
Qed.

Theorem Nlt_in : forall n m, (nat_of_N n < nat_of_N m)%nat
  -> n < m.
  unfold N.lt; intros.
  rewrite nat_of_Ncompare.
  apply (proj1 (nat_compare_lt _ _)); assumption.
Qed.

Theorem Nge_out : forall n m, n >= m
  -> (nat_of_N n >= nat_of_N m)%nat.
  unfold N.ge; intros ?? H.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_ge; assumption.
Qed.

Theorem Nge_in : forall n m, (nat_of_N n >= nat_of_N m)%nat
  -> n >= m.
  unfold N.ge; intros.
  rewrite nat_of_Ncompare.
  apply nat_compare_ge; assumption.
Qed.

Ltac nsimp H := simpl in H; repeat progress (autorewrite with N in H; simpl in H).

Ltac pre_nlia :=
  try (apply nat_of_N_eq || apply Nneq_in || apply Nlt_in || apply Nge_in); simpl;
    repeat (progress autorewrite with N; simpl);
    repeat match goal with
             | [ H : _ <> _ |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ = _ -> False |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ |- _ ] => (apply (f_equal nat_of_N) in H
               || apply Nlt_out in H || apply Nge_out in H); nsimp H
           end.

Ltac nlia := pre_nlia; lia || (unfold nat_of_P in *; simpl in *; lia).


(**************************************************************************
* TLC: A library for Coq                                                  *
* Variable names, and freshness properties                                *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibList LibLogic LibNat LibEpsilon LibReflect.
From TLC Require Export LibFset.

(* ********************************************************************** *)
(** * Abstract Definition of Variables *)

Module Type VariablesType.

(** We leave the type of variables abstract. *)

Parameter var : Set.

(** This type is inhabited. *)

Parameter Inhab_var : Inhab var.

(** This type is comparable. *)

Parameter var_compare : var -> var -> bool.

Parameter var_compare_eq : forall (x y:var),
  var_compare x y = isTrue (x = y).

  (* DEPRECATED
  Parameter var_comp : Comparable var.
  Instance var_comparable : Comparable var := var_comp.
  *)

(** We can build sets of variables. *)

Definition vars := fset var.

(** Finally, we have a means of generating fresh variables. *)

Parameter var_gen : vars -> var.
Parameter var_gen_spec : forall E, (var_gen E) \notin E.
Parameter var_fresh : forall (L : vars), { x : var | x \notin L }.

End VariablesType.

(* ********************************************************************** *)
(** * Concrete Implementation of Variables *)

Module Export Variables : VariablesType.

Definition var := nat.

Lemma Inhab_var : Inhab var.
Proof using. apply (Inhab_of_val 0). Qed.

(* --LATER: reuse nat_compare *)
Fixpoint var_compare (x y : nat) :=
  match x, y with
  | O, O => true
  | S x', S y' => var_compare x' y'
  | _, _ => false
  end.

Lemma var_compare_eq : forall (x y:var),
  var_compare x y = isTrue (x = y).
Proof using.
  unfold var. intros x; induction x; intros y; destruct y;
   simpl; rew_bool_eq; try nat_math.
  rewrite IHx. rew_bool_eq. nat_math.
Qed.

  (* DEPRECATED
  Lemma var_comp : Comparable var.
  Proof using. apply nat_comparable. Qed.

  Instance var_comparable : Comparable var := var_comp.
  *)

Definition vars := fset var.

Definition var_gen_list (l : list nat) :=
  1 + fold_right plus O l.

Lemma var_gen_list_spec : forall n l,
  n \in from_list l -> n < var_gen_list l.
Proof using.
  unfold var_gen_list. induction l; introv I.
  rewrite from_list_nil in I. false (in_empty_inv I).
  rewrite from_list_cons in I. rew_listx.
   rewrite in_union in I. destruct I as [H|H].
     rewrite in_singleton in H. subst. nat_math.
     specializes IHl H. nat_math.
Qed.

Definition var_gen (E : vars) : var :=
  var_gen_list (epsilon (fun l => E = from_list l)).

Lemma var_gen_spec : forall E, (var_gen E) \notin E.
Proof using.
  intros. unfold var_gen. epsilon l. applys fset_finite.
  intros Hl. rewrite Hl. introv H.
  forwards M: var_gen_list_spec H. nat_math.
Qed.

Lemma var_fresh : forall (L : vars), { x : var | x \notin L }.
Proof using. intros L. exists (var_gen L). apply var_gen_spec. Qed.

End Variables.

(* ********************************************************************** *)
(** ** Lists of variables of given length and given freshness *)

(** Freshness of n variables from a set L and from one another. *)

Fixpoint fresh (L : vars) (n : nat) (xs : list var) {struct xs} : Prop :=
  match xs, n with
  | nil, O => True
  | x::xs', S n' => x \notin L /\ fresh (L \u \{x}) n' xs'
  | _,_ => False
  end.

Hint Extern 1 (fresh _ _ _) => simpl.

(* It is possible to build a list of n fresh variables. *)

Lemma var_freshes : forall L n,
  { xs : list var | fresh L n xs }.
Proof using.
  intros. gen L. induction n; intros L.
  exists* (nil : list var).
  destruct (var_fresh L) as [x Fr].
   destruct (IHn (L \u \{x})) as [xs Frs].
   exists* (x::xs).
Qed.

(* ********************************************************************** *)
(** ** Picking fresh names *)

(** [gather_vars_for_type T F] return the union of all the finite sets
  of variables [F x] where [x] is a variable from the context such that
  [F x] type checks. In other words [x] has to be of the type of the
  argument of [F]. The resulting union of sets does not contain any
  duplicated item. This tactic is an extreme piece of hacking necessary
  because the tactic language does not support a "fold" operation on
  the context. *)

Ltac gather_vars_with F :=
  let rec gather V :=
    match goal with
    | H: ?S |- _ =>
      let FH := constr:(F H) in
      match V with
      | \{} => gather FH
      | context [FH] => fail 1
      | _ => gather (FH \u V)
      end
    | _ => V
    end in
  let L := gather (\{}:vars) in eval simpl in L.

(** [beautify_fset V] assumes that [V] is built as a union of finite
  sets and return the same set cleaned up: empty sets are removed and
  items are laid out in a nicely parenthesized way *)

Ltac beautify_fset V :=
  let rec go Acc E :=
     match E with
     | ?E1 \u ?E2 => let Acc1 := go Acc E1 in
                     go Acc1 E2
     | \{}  => Acc
     | ?E1 => match Acc with
              | \{} => E1
              | _ => constr:(Acc \u E1)
              end
     end
  in go (\{}:vars) V.

(** [pick_fresh_gen L Y] expects [L] to be a finite set of variables
  and adds to the context a variable with name [Y] and a proof that
  [Y] is fresh for [L]. *)

Ltac pick_fresh_gen L Y :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (var_fresh L) as [Y Fr]).

(** [pick_fresh_gens L n Y] expects [L] to be a finite set of variables
  and adds to the context a list of variables with name [Y] and a proof
  that [Y] is of length [n] and contains variable fresh for [L] and
  distinct from one another. *)

Ltac pick_freshes_gen L n Y :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (var_freshes L n) as [Y Fr]).

(* ********************************************************************** *)
(** ** Tactics for [notin] *)

Implicit Types x : var.

(** For efficiency, we avoid rewrites by splitting equivalence. *)

Lemma notin_singleton_r : forall x y,
  x \notin \{y} -> x <> y.
Proof using. intros. rewrite~ <- notin_singleton. Qed.

Lemma notin_singleton_l : forall x y,
  x <> y -> x \notin \{y}.
Proof using. intros. rewrite~ notin_singleton. Qed.

Lemma notin_singleton_swap : forall x y,
  x \notin \{y} -> y \notin \{x}.
Proof using.
  intros. apply notin_singleton_l.
  apply sym_not_eq. apply~ notin_singleton_r.
Qed.

Lemma notin_union_r : forall x E F,
  x \notin (E \u F) -> (x \notin E) /\ (x \notin F).
Proof using. intros. rewrite~ <- notin_union. Qed.

Lemma notin_union_r1 : forall x E F,
  x \notin (E \u F) -> (x \notin E).
Proof using. introv. rewrite* notin_union. Qed.

Lemma notin_union_r2 : forall x E F,
  x \notin (E \u F) -> (x \notin F).
Proof using. introv. rewrite* notin_union. Qed.

Lemma notin_union_l : forall x E F,
  x \notin E -> x \notin F -> x \notin (E \u F).
Proof using. intros. rewrite~ notin_union. Qed.

Lemma notin_var_gen : forall E F,
  (forall x, x \notin E -> x \notin F) ->
  (var_gen E) \notin F.
Proof using. intros. autos~ var_gen_spec. Qed.

Arguments notin_singleton_r [x] [y].
Arguments notin_singleton_l [x] [y].
Arguments notin_singleton_swap [x] [y].
Arguments notin_union_r [x] [E] [F].
Arguments notin_union_r1 [x] [E] [F].
Arguments notin_union_r2 [x] [E] [F].
Arguments notin_union_l [x] [E] [F].

(** Tactics to deal with notin.  *)

Ltac notin_solve_target_from x E H :=
  match type of H with
  | x \notin E => constr:(H)
  | x \notin (?F \u ?G) =>
     let H' :=
        match F with
        | context [E] => constr:(notin_union_r1 H)
        | _ => match G with
          | context [E] => constr:(notin_union_r2 H)
          | _ => fail 20
          end
        end in
     notin_solve_target_from x E H'
  end.

Ltac notin_solve_target x E :=
  match goal with
  | H: x \notin ?L |- _ =>
    match L with context[E] =>
      let F := notin_solve_target_from x E H in
      apply F
    end
  | H: x <> ?y |- _ =>
     match E with \{y} =>
       apply (notin_singleton_l H)
     end
  end.

Ltac notin_solve_one :=
  match goal with
  | |- ?x \notin \{?y} =>
     apply notin_singleton_swap;
     notin_solve_target y (\{x})
  | |- ?x \notin ?E =>
    notin_solve_target x E
  end.
  (*
    LATER: add support for these special cases
      | |- ?x \notin ?E =>
            progress (unfold x); notin_simpl
      | |- (var_gen ?x) \notin _ =>
            apply notin_var_gen; intros; notin_simpl
  *)
  (* Remark: if x is an evar, we could try to instantiate it.
     But, problem: it might loop !
    | |- ?x \notin ?E =>
       match goal with y:var |- _ =>
         match y with
         | x => fail 1
         | _ =>
           let H := fresh in cuts H: (y \notin E);
           [ apply H | notin_solve_target y E ]
          end
       end
  *)

Ltac notin_simpl :=
  match goal with
  | |- _ \notin (_ \u _) => apply notin_union_l; notin_simpl
  | |- _ \notin (\{}) => apply notin_empty; notin_simpl
  | |- ?x <> ?y => apply notin_singleton_r; notin_simpl
  | |- _ => idtac
  end.

Ltac notin_solve_false :=
  match goal with
  | H: ?x \notin ?E |- _ =>
    match E with context[x] =>
      apply (@notin_same _ x);
      let F := notin_solve_target_from x (\{x}) H in
      apply F
    end
  | H: ?x <> ?x |- _ => apply H; reflexivity
  end.

Ltac notin_false :=
  match goal with
  | |- False => notin_solve_false
  | _ => intros_all; false; notin_solve_false
  end.

Ltac notin_of_fresh_in_context :=
  repeat (match goal with H: fresh _ _ _ |- _ =>
    progress (simpl in H; destructs H) end).

Ltac notin_solve :=
  notin_of_fresh_in_context;
  first [ notin_simpl; try notin_solve_one
        | notin_false ].

Hint Extern 1 (_ \notin _) => notin_solve.
Hint Extern 1 (_ <> _ :> var) => notin_solve.
Hint Extern 1 ((_ \notin _) /\ _) => splits.

(* ********************************************************************** *)
(** ** Tactics for [fresh] *)

(* --TODO: cleanup proofs of fresh using calc_fset *)

Lemma fresh_union_r : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L1 n xs /\ fresh L2 n xs.
Proof using.
  induction xs; simpl; intros; destruct n;
  tryfalse*. auto.
  destruct H. split; split; auto.
  forwards*: (@IHxs (L1 \u \{a}) L2 n).
   rewrite union_comm.
   rewrite union_comm_assoc.
   rewrite* union_assoc.
  forwards*: (@IHxs L1 (L2 \u \{a}) n).
   rewrite* union_assoc.
Qed.

Lemma fresh_union_r1 : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L1 n xs.
Proof using. intros. forwards*: fresh_union_r. Qed.

Lemma fresh_union_r2 : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L2 n xs.
Proof using. intros. forwards*: fresh_union_r. Qed.

Lemma fresh_union_l : forall xs L1 L2 n,
  fresh L1 n xs -> fresh L2 n xs -> fresh (L1 \u L2) n xs.
Proof using.
  induction xs; simpl; intros; destruct n; tryfalse*. auto.
  destruct H. destruct H0. split~.
  forwards~ K: (@IHxs (L1 \u \{a}) (L2 \u \{a}) n).
  rewrite <- (union_same \{a}).
  rewrite union_assoc.
  rewrite <- (union_assoc L1).
  rewrite (union_comm L2).
  rewrite (union_assoc L1).
  rewrite* <- union_assoc.
Qed.

Lemma fresh_empty : forall L n xs,
  fresh L n xs -> fresh \{} n xs.
Proof using.
  intros. rewrite <- (union_empty_r L) in H.
  destruct* (fresh_union_r _ _ _ _ H).
Qed.

Lemma fresh_length : forall L n xs,
  fresh L n xs -> n = length xs.
Proof using.
  intros. gen n L. induction xs; simpl; intros n L Fr;
    destruct n; tryfalse*.
  auto.
  rew_list. rewrite* <- (@IHxs n (L \u \{a})).
Qed.

Lemma fresh_resize : forall L n xs,
  fresh L n xs -> forall m, m = n -> fresh L m xs.
Proof using.
  introv Fr Eq. subst~.
Qed.

Lemma fresh_resize_length : forall L n xs,
  fresh L n xs -> fresh L (length xs) xs.
Proof using.
  introv Fr. rewrite* <- (fresh_length _ _ _ Fr).
Qed.

Arguments fresh_union_r [xs] [L1] [L2] [n].
Arguments fresh_union_r1 [xs] [L1] [L2] [n].
Arguments fresh_union_r2 [xs] [L1] [L2] [n].
Arguments fresh_union_l [xs] [L1] [L2] [n].
Arguments fresh_empty [L] [n] [xs].
Arguments fresh_length [L] [n] [xs].
Arguments fresh_resize [L] [n] [xs].
Arguments fresh_resize_length [L] [n] [xs].

Lemma fresh_single_notin : forall x xs n,
  fresh \{x} n xs ->
  x \notin from_list xs.
Proof using.
  induction xs; destruct n; introv F; simpl in F; tryfalse.
  rewrite~ from_list_nil.
  destruct F as [Fr F']. lets [? ?]: (fresh_union_r F').
   specializes IHxs n. rewrite~ from_list_cons.
Qed.

Ltac fresh_solve_target_from E n xs H :=
  match type of H with
  | fresh E n xs => constr:(H)
  | fresh E ?m xs =>
      match n with
      | length xs => constr:(fresh_resize_length H)
      | _ =>
         match goal with
         | Eq: m = n |- _ => constr:(fresh_resize H _ (sym_eq Eq))
         | Eq: n = m |- _ => constr:(fresh_resize H _ Eq)
         end
      end
  | fresh (?F \u ?G) ?m xs =>
     let H' :=
        match F with
        | context [E] => constr:(fresh_union_r1 H)
        | _ => match G with
          | context [E] => constr:(fresh_union_r2 H)
          | _ => fail 20
          end
        end in
     fresh_solve_target_from E n xs H'
  end.

Ltac fresh_solve_target E n xs :=
  match goal with H: fresh ?L _ xs |- _ =>
    match L with context[E] =>
      let F := fresh_solve_target_from E n xs H in
      apply F
    end
  end.

Ltac fresh_solve_one :=
  match goal with
  | |- fresh ?E ?n ?xs =>
    fresh_solve_target E n xs
  | |- fresh \{} ?n ?xs =>
    match goal with H: fresh ?F ?m xs |- _ =>
      apply (fresh_empty H);
      fresh_solve_target F n xs
    end
  end.

Ltac fresh_simpl :=
  try match goal with |- fresh (_ \u _) _ _ =>
    apply fresh_union_l; fresh_simpl end.

Ltac fresh_solve_by_notins :=
  simpl; splits; try notin_solve.

Ltac fresh_solve :=
  fresh_simpl;
  first [ fresh_solve_one
        | fresh_solve_by_notins
        | idtac ].

Hint Extern 1 (fresh _ _ _) => fresh_solve.

(* --LATER: more automation of fresh_length properties *)


Require Import Coq.Setoids.Setoid.
Require Import msl.Extensionality.

(******************************************

Copied From Coq.Logic.JMeq.

No longer involving JMeq_eq, which is potentially inconsistenty with homotopy
type theory.

TODO: let reflexivity, symmetry and transitivity work again.

******************************************)

Definition JMeq {A:Type} (x:A) {B:Type} (y: B): Prop :=
  {H: A = B | eq_rect A (fun T: Type => T) x B H = y}.

Lemma JMeq_refl: forall {A: Type} (x: A), JMeq x x.
Proof.
  intros.
  exists eq_refl.
  rewrite <- eq_rect_eq.
  auto.
Qed.
Hint Resolve JMeq_refl.

Lemma JMeq_sym : forall {A B:Type} {x:A} {y:B}, JMeq x y -> JMeq y x.
Proof.
destruct 1; trivial.
subst.
trivial.
Qed.
Hint Immediate JMeq_sym.

Lemma JMeq_trans :
 forall {A B C:Type} {x:A} {y:B} {z:C}, JMeq x y -> JMeq y z -> JMeq x z.
Proof.
destruct 2; trivial.
subst.
auto.
Qed.

Lemma JMeq_eq : forall (A:Type) (x y:A), JMeq x y -> x = y.
Proof.
  intros.
  destruct H.
  rewrite <- eq_rect_eq in e.
  auto.
Qed.

Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'.
inversion H'.
subst.
 case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_rect : forall (A:Type) (x:A) (P:A->Type),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_rec_r : forall (A:Type) (x:A) (P:A -> Set),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_rect_r : forall (A:Type) (x:A) (P:A -> Type),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_congr :
 forall (A:Type) (x:A) (B:Type) (f:A->B) (y:A), JMeq x y -> f x = f y.
Proof.
intros A x B f y H; case JMeq_eq with (1 := H); trivial.
Qed.

(** [JMeq] is equivalent to [eq_dep Type (fun X => X)] *)

Require Import Coq.Logic.Eqdep.

Lemma JMeq_eq_dep_id :
 forall (A B:Type) (x:A) (y:B), JMeq x y -> eq_dep Type (fun X => X) A x B y.
Proof.
destruct 1.
subst.
rewrite <- eq_rect_eq.
apply eq_dep_intro.
Qed.

Lemma eq_dep_id_JMeq :
 forall (A B:Type) (x:A) (y:B), eq_dep Type (fun X => X) A x B y -> JMeq x y.
Proof.
destruct 1.
apply JMeq_refl.
Qed.

(** [eq_dep U P p x q y] is strictly finer than [JMeq (P p) x (P q) y] *)

Lemma eq_dep_JMeq :
 forall U P p x q y, eq_dep U P p x q y -> JMeq x y.
Proof.
destruct 1.
apply JMeq_refl.
Qed.

Lemma eq_dep_strictly_stronger_JMeq :
 exists U P p q x y, JMeq x y /\ ~ eq_dep U P p x q y.
Proof.
exists bool. exists (fun _ => True). exists true. exists false.
exists I. exists I.
split.
trivial.
intro H.
assert (true=false) by (destruct H; reflexivity).
discriminate.
Qed.

(** However, when the dependencies are equal, [JMeq (P p) x (P q) y]
    is as strong as [eq_dep U P p x q y] (this uses [JMeq_eq]) *)

Lemma JMeq_eq_dep :
  forall U (P:U->Prop) p q (x:P p) (y:P q),
  p = q -> JMeq x y -> eq_dep U P p x q y.
Proof.
intros.
destruct H.
apply JMeq_eq in H0 as ->.
reflexivity.
Qed.

(* Compatibility *)
Notation sym_JMeq := JMeq_sym (only parsing).
Notation trans_JMeq := JMeq_trans (only parsing).

(******************************************

The following is the original floyd/jmeq_lemmas.v

******************************************)

Lemma eq_rect_JMeq: forall (A:Type) (x y: A) F (v: F x) (H: x = y), JMeq (eq_rect x F v y H) v.
Proof.
  intros.
  subst.
  rewrite <- eq_rect_eq.
  apply JMeq_refl.
Qed.

Lemma eq_rect_r_JMeq: forall (A:Type) (x y: A) F (v: F x) (H: y = x), JMeq (eq_rect_r F v H) v.
Proof.
  intros.
  subst.
  unfold eq_rect_r; rewrite <- eq_rect_eq.
  apply JMeq_refl.
Qed.

Lemma JMeq_sumtype_ll: forall A B C D x y, A = C -> B = D ->
  (@JMeq (A + B) (inl x) (C + D) (inl y)) ->
  JMeq x y.
Proof.
  unfold not.
  intros.
  subst.
  inversion H1.
  apply JMeq_eq in H1.
  inversion H1.
  apply JMeq_refl.
Qed.

Lemma JMeq_sumtype_rr: forall A B C D x y, A = C -> B = D ->
  (@JMeq (A + B) (inr x) (C + D) (inr y)) ->
  JMeq x y.
Proof.
  unfold not.
  intros.
  subst.
  apply JMeq_eq in H1.
  inversion H1.
  apply JMeq_refl.
Qed.

Lemma JMeq_sumtype_lr: forall A B C D x y, A = C -> B = D -> ~ (@JMeq (A + B) (inl x) (C + D) (inr y)).
Proof.
  unfold not.
  intros.
  subst.
  apply JMeq_eq in H1.
  inversion H1.
Qed.

Lemma JMeq_sumtype_rl: forall A B C D x y, A = C -> B = D -> ~ (@JMeq (A + B) (inr x) (C + D) (inl y)).
Proof.
  unfold not.
  intros.
  subst.
  apply JMeq_eq in H1.
  inversion H1.
Qed.

Ltac solve_JMeq_sumtype H :=
  match type of H with
  | JMeq ?x ?y =>
    destruct x; destruct y;
     [apply JMeq_sumtype_ll in H; auto
     |apply JMeq_sumtype_lr in H; auto; inversion H
     |apply JMeq_sumtype_rl in H; auto; inversion H
     |apply JMeq_sumtype_rr in H; auto]
  end.

Lemma JMeq_inl: forall A B C D (x: A) (y: C), A = C -> B = D -> JMeq x y -> @JMeq (A + B) (inl x) (C + D) (inl y).
Proof.
  intros.
  subst.
  apply JMeq_eq in H1.
  subst.
  apply JMeq_refl.
Qed.

Lemma JMeq_inr: forall A B C D (x: B) (y: D), A = C -> B = D -> JMeq x y -> @JMeq (A + B) (inr x) (C + D) (inr y).
Proof.
  intros.
  subst.
  apply JMeq_eq in H1.
  subst.
  apply JMeq_refl.
Qed.

Lemma JMeq_fst: forall A B C D (x: A*B) (y: C*D), A = C -> B = D -> JMeq x y -> JMeq (fst x) (fst y).
Proof.
  intros.
  subst.
  apply JMeq_eq in H1.
  subst.
  apply JMeq_refl.
Qed.

Lemma JMeq_snd: forall A B C D (x: A*B) (y: C*D), A = C -> B = D -> JMeq x y -> JMeq (snd x) (snd y).
Proof.
  intros.
  subst.
  apply JMeq_eq in H1.
  subst.
  apply JMeq_refl.
Qed.

Lemma JMeq_pair: forall A B C D (a: A) (b: B) (c: C) (d: D), JMeq a b -> JMeq c d -> JMeq (a, c) (b, d).
Proof.
  intros.
  inversion H; subst.
  inversion H0; subst.
  apply JMeq_refl.
Qed.

Lemma eq_rect_r_eq_rect_r_eq_sym: forall {T} {A B: T} F x (H: A = B),
  eq_rect_r F (eq_rect_r F x H) (eq_sym H) = x.
Proof.
  intros.
  apply JMeq_eq.
  apply JMeq_sym.
  apply @JMeq_sym; eapply JMeq_trans.
  + apply eq_rect_r_JMeq.
  + apply eq_rect_r_JMeq.
Qed.

Lemma eq_rect_r_eq_rect_r_eq_sym': forall {T} {A B: T} F x (H: B = A),
  eq_rect_r F (eq_rect_r F x (eq_sym H)) H = x.
Proof.
  intros.
  apply JMeq_eq.
  apply JMeq_sym.
  apply @JMeq_sym; eapply JMeq_trans.
  + apply eq_rect_r_JMeq.
  + apply eq_rect_r_JMeq.
Qed.

Lemma JMeq_func: forall A B C D (f: A -> B) (g: C -> D) x y,
  A = C -> B = D ->
  JMeq x y -> JMeq f g -> JMeq (f x) (g y).
Proof.
  intros.
  subst.
  apply JMeq_eq in H1.
  apply JMeq_eq in H2.
  subst.
  apply JMeq_refl.
Qed.

Lemma eq_JMeq: forall A (x y: A), x=y -> JMeq x y.
Proof. intros. subst. apply JMeq_refl.
Qed.

Lemma list_func_JMeq: forall {A B C} (a: list A) (b: list B) (f: forall X, list X -> C), A = B -> JMeq a b -> f A a = f B b.
Proof.
  intros; subst.
  apply JMeq_eq in H0.
  subst.
  auto.
Qed.

Lemma JMeq_sigT: forall {A B} (a: A), A = B -> {b: B | JMeq a b}.
Proof.
  intros.
  subst.
  exists a.
  apply JMeq_refl.
Qed.

Arguments JMeq_eq {A} {x y} _.


(*
  Exercises for <Software Foundations> V2 CH9.
  Author : Brethland, Early 2020.
*)

Set Warnings "-notation-overridden,-parsing".
Require Import Strings.String.
Add LoadPath "C:\Users\ycy12\Documents\Workspace\LEARNING-STUFF\Coq".
(* Load Coq31. *)
Require Import Unicode.Utf8.

Section MoreSTLC.
  Inductive ty : Type :=
  | Arrow : ty → ty → ty
  | Nat : ty
  | Sum : ty → ty → ty
  | List : ty → ty
  | Unit : ty
  | Prod : ty → ty → ty.
Inductive tm : Type :=
  (* pure STLC *)
  | var : string → tm
  | app : tm → tm → tm
  | abs : string → ty → tm → tm
  (* numbers *)
  | const : nat → tm
  | scc : tm → tm
  | prd : tm → tm
  | mlt : tm → tm → tm
  | test0 : tm → tm → tm → tm
  (* sums *)
  | tinl : ty → tm → tm
  | tinr : ty → tm → tm
  | tcase : tm → string → tm → string → tm → tm
          (* i.e., case t0 of inl x1 ⇒ t1 | inr x2 ⇒ t2 *)
  (* lists *)
  | tnil : ty → tm
  | tcons : tm → tm → tm
  | tlcase : tm → tm → string → string → tm → tm
           (* i.e., lcase t1 of | nil ⇒ t2 | x::y ⇒ t3 *)
  (* unit *)
  | unit : tm

  (* You are going to be working on the following extensions: *)

  (* pairs *)
  | pair : tm → tm → tm
  | fst : tm → tm
  | snd : tm → tm
  (* let *)
  | tlet : string → tm → tm → tm
         (* i.e., let x = t1 in t2 *)
  (* fix *)
  | tfix : tm → tm.

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  (* pure STLC *)
  | var y =>
      if eqb x y then s else t
  | abs y T t1 =>
      abs y T (if eqb x y then t1 else (subst x s t1))
  | app t1 t2 =>
      app (subst x s t1) (subst x s t2)
  (* numbers *)
  | const n =>
      const n
  | scc t1 =>
      scc (subst x s t1)
  | prd t1 =>
      prd (subst x s t1)
  | mlt t1 t2 =>
      mlt (subst x s t1) (subst x s t2)
  | test0 t1 t2 t3 =>
      test0 (subst x s t1) (subst x s t2) (subst x s t3)
  (* sums *)
  | tinl T t1 =>
      tinl T (subst x s t1)
  | tinr T t1 =>
      tinr T (subst x s t1)
  | tcase t0 y1 t1 y2 t2 =>
      tcase (subst x s t0)
         y1 (if eqb x y1 then t1 else (subst x s t1))
         y2 (if eqb x y2 then t2 else (subst x s t2))
  (* lists *)
  | tnil T =>
      tnil T
  | tcons t1 t2 =>
      tcons (subst x s t1) (subst x s t2)
  | tlcase t1 t2 y1 y2 t3 =>
      tlcase (subst x s t1) (subst x s t2) y1 y2
        (if eqb x y1 then
           t3
         else if eqb x y2 then t3
              else (subst x s t3))
  (* unit *)
  | unit => unit
  | pair t1 t2 => pair (subst x s t1) (subst x s t2)
  | fst t1 => fst (subst x s t1)
  | snd t1 => snd (subst x s t1)
  | tlet y t1 t2 => tlet y (if eqb x y then t1 else (subst x s t1))
                         (if eqb x y then t2 else (subst x s t2))
  | tfix t1 => tfix (subst x s t1)
  end.
Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

Inductive value : tm → Prop :=
  (* In pure STLC, function abstractions are values: *)
  | v_abs : ∀x T11 t12,
      value (abs x T11 t12)
  (* Numbers are values: *)
  | v_nat : ∀n1,
      value (const n1)
  (* A tagged value is a value:  *)
  | v_inl : ∀v T,
      value v →
      value (tinl T v)
  | v_inr : ∀v T,
      value v →
      value (tinr T v)
  (* A list is a value iff its head and tail are values: *)
  | v_lnil : ∀T, value (tnil T)
  | v_lcons : ∀v1 vl,
      value v1 →
      value vl →
      value (tcons v1 vl)
  (* A unit is always a value *)
  | v_unit : value unit
  (* A pair is a value if both components are: *)
  | v_pair : ∀v1 v2,
      value v1 →
      value v2 →
      value (pair v1 v2).
Hint Constructors value.
Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm → tm → Prop :=
  (* pure STLC *)
  | ST_AppAbs : ∀x T11 t12 v2,
         value v2 →
         (app (abs x T11 t12) v2) --> [x:=v2]t12
  | ST_App1 : ∀t1 t1' t2,
         t1 --> t1' →
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : ∀v1 t2 t2',
         value v1 →
         t2 --> t2' →
         (app v1 t2) --> (app v1 t2')
  (* numbers *)
  | ST_Succ1 : ∀t1 t1',
       t1 --> t1' →
       (scc t1) --> (scc t1')
  | ST_SuccNat : ∀n1,
       (scc (const n1)) --> (const (S n1))
  | ST_Pred : ∀t1 t1',
       t1 --> t1' →
       (prd t1) --> (prd t1')
  | ST_PredNat : ∀n1,
       (prd (const n1)) --> (const (pred n1))
  | ST_Mult1 : ∀t1 t1' t2,
       t1 --> t1' →
       (mlt t1 t2) --> (mlt t1' t2)
  | ST_Mult2 : ∀v1 t2 t2',
       value v1 →
       t2 --> t2' →
       (mlt v1 t2) --> (mlt v1 t2')
  | ST_Mulconsts : ∀n1 n2,
       (mlt (const n1) (const n2)) --> (const (mult n1 n2))
  | ST_Test01 : ∀t1 t1' t2 t3,
       t1 --> t1' →
       (test0 t1 t2 t3) --> (test0 t1' t2 t3)
  | ST_Test0Zero : ∀t2 t3,
       (test0 (const 0) t2 t3) --> t2
  | ST_Test0Nonzero : ∀n t2 t3,
       (test0 (const (S n)) t2 t3) --> t3
  (* sums *)
  | ST_Inl : ∀t1 t1' T,
        t1 --> t1' →
        (tinl T t1) --> (tinl T t1')
  | ST_Inr : ∀t1 t1' T,
        t1 --> t1' →
        (tinr T t1) --> (tinr T t1')
  | ST_Case : ∀t0 t0' x1 t1 x2 t2,
        t0 --> t0' →
        (tcase t0 x1 t1 x2 t2) --> (tcase t0' x1 t1 x2 t2)
  | ST_CaseInl : ∀v0 x1 t1 x2 t2 T,
        value v0 →
        (tcase (tinl T v0) x1 t1 x2 t2) --> [x1:=v0]t1
  | ST_CaseInr : ∀v0 x1 t1 x2 t2 T,
        value v0 →
        (tcase (tinr T v0) x1 t1 x2 t2) --> [x2:=v0]t2
  (* lists *)
  | ST_Cons1 : ∀t1 t1' t2,
       t1 --> t1' →
       (tcons t1 t2) --> (tcons t1' t2)
  | ST_Cons2 : ∀v1 t2 t2',
       value v1 →
       t2 --> t2' →
       (tcons v1 t2) --> (tcons v1 t2')
  | ST_Lcase1 : ∀t1 t1' t2 x1 x2 t3,
       t1 --> t1' →
       (tlcase t1 t2 x1 x2 t3) --> (tlcase t1' t2 x1 x2 t3)
  | ST_LcaseNil : ∀T t2 x1 x2 t3,
       (tlcase (tnil T) t2 x1 x2 t3) --> t2
  | ST_LcaseCons : ∀v1 vl t2 x1 x2 t3,
       value v1 →
       value vl →
       (tlcase (tcons v1 vl) t2 x1 x2 t3)
         --> (subst x2 vl (subst x1 v1 t3))
  | ST_Pair1 : forall t1 t1' t2,
      t1 --> t1' -> pair t1 t2 --> pair t1' t2
  | ST_Pair2 : forall v t t',
      value v -> t --> t' -> pair v t --> pair v t'
  | ST_Fst1 : forall t t',
      t --> t' -> fst t --> fst t'
  | ST_FstPair : forall v1 v2,
      value v1 -> value v2 -> fst (pair v1 v2) --> v1
  | ST_Snd1 : forall t t',
      t --> t' -> snd t --> snd t'
  | ST_SndPair : forall v1 v2,
      value v1 -> value v2 -> snd (pair v1 v2) --> v2
  | ST_Let1 : forall x t1 t1' t2,
      t1 --> t1' -> tlet x t1 t2 --> tlet x t1' t2
  | ST_LetValue : forall x v t2,
      value v -> tlet x v t2 --> subst x v t2
  | ST_Fix1 : forall t1 t1',
      t1 --> t1' -> tfix t1 --> tfix t1'
  | ST_FixAbs : forall xf T1 t2,
      tfix (abs xf T1 t2) --> subst xf (tfix (abs xf T1 t2)) t2

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

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : ∀(x : X), multi R x x
  | multi_step : ∀(x y z : X),
                    R x y →
                    multi R y z →
                    multi R x z.

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

Definition context := partial_map ty.

Reserved Notation "Gamma '⊢' t '∈' T" (at level 40).
Inductive has_type : context → tm → ty → Prop :=
  | T_Var : ∀Gamma x T,
      Gamma x = Some T →
      Gamma ⊢ (var x) ∈ T
  | T_Abs : ∀Gamma x T11 T12 t12,
      (update Gamma x T11) ⊢ t12 ∈ T12 →
      Gamma ⊢ (abs x T11 t12) ∈ (Arrow T11 T12)
  | T_App : ∀T1 T2 Gamma t1 t2,
      Gamma ⊢ t1 ∈ (Arrow T1 T2) →
      Gamma ⊢ t2 ∈ T1 →
      Gamma ⊢ (app t1 t2) ∈ T2
  | T_Nat : ∀Gamma n1,
      Gamma ⊢ (const n1) ∈ Nat
  | T_Succ : ∀Gamma t1,
      Gamma ⊢ t1 ∈ Nat →
      Gamma ⊢ (scc t1) ∈ Nat
  | T_Pred : ∀Gamma t1,
      Gamma ⊢ t1 ∈ Nat →
      Gamma ⊢ (prd t1) ∈ Nat
  | T_Mult : ∀Gamma t1 t2,
      Gamma ⊢ t1 ∈ Nat →
      Gamma ⊢ t2 ∈ Nat →
      Gamma ⊢ (mlt t1 t2) ∈ Nat
  | T_Test0 : ∀Gamma t1 t2 t3 T1,
      Gamma ⊢ t1 ∈ Nat →
      Gamma ⊢ t2 ∈ T1 →
      Gamma ⊢ t3 ∈ T1 →
      Gamma ⊢ (test0 t1 t2 t3) ∈ T1
  | T_Inl : ∀Gamma t1 T1 T2,
      Gamma ⊢ t1 ∈ T1 →
      Gamma ⊢ (tinl T2 t1) ∈ (Sum T1 T2)
  | T_Inr : ∀Gamma t2 T1 T2,
      Gamma ⊢ t2 ∈ T2 →
      Gamma ⊢ (tinr T1 t2) ∈ (Sum T1 T2)
  | T_Case : ∀Gamma t0 x1 T1 t1 x2 T2 t2 T,
      Gamma ⊢ t0 ∈ (Sum T1 T2) →
      (update Gamma x1 T1) ⊢ t1 ∈ T →
      (update Gamma x2 T2) ⊢ t2 ∈ T →
      Gamma ⊢ (tcase t0 x1 t1 x2 t2) ∈ T
  | T_Nil : ∀Gamma T,
      Gamma ⊢ (tnil T) ∈ (List T)
  | T_Cons : ∀Gamma t1 t2 T1,
      Gamma ⊢ t1 ∈ T1 →
      Gamma ⊢ t2 ∈ (List T1) →
      Gamma ⊢ (tcons t1 t2) ∈ (List T1)
  | T_Lcase : ∀Gamma t1 T1 t2 x1 x2 t3 T2,
      Gamma ⊢ t1 ∈ (List T1) →
      Gamma ⊢ t2 ∈ T2 →
      (update (update Gamma x2 (List T1)) x1 T1) ⊢ t3 ∈ T2 →
      Gamma ⊢ (tlcase t1 t2 x1 x2 t3) ∈ T2
  | T_Unit : ∀Gamma,
      Gamma ⊢ unit ∈ Unit
  | T_Let : forall Gamma, t1 T1 x t2 T2,
    Gamma |- t1 ∈ T1 -> (update Gamma x T1) |- t2 ∈ T2 ->
                                               Gamma |- tlet x t1 t2 ∈ T2
  | T_Pair : forall Gamma t1 T1 t2 T2,
    Gamma |- t1 ∈ T1 -> Gamma |- t2 ∈ T2 -> Gamma |- (pair t1 t2) ∈ Prod T1 T2
  | T_Fst : forall Gamma t T1 T2,
      Gamma |- t ∈ Prod T1 T2 -> fst t ∈ T1
  | T_Snd : forall Gamma t T1 T2,
      Gamma |- t ∈ Prod T1 T2 -> snd t ∈ T2
  | T_Fix : forall Gamma t1 T1,
      Gamma |- t1 ∈ (Arrow T1 T1) -> Gamma |- tfix t1 ∈ T1
  where "Gamma '⊢' t '∈' T" := (has_type Gamma t T).
Hint Constructors has_type.


(* GITCRC *)

Require Import ZArith.

Section binop.
(**
A Gentle Introduction to Type Classes and Relations in Coq
の
Chapter 3.9.2 Operational Type Classes の前半から
*)

  Set Implicit Arguments.
  Open Scope Z_scope.

  (* Operational Type Classes:  *)
  Class monoid_binop (A : Type) := monoid_op : A -> A -> A.
  Notation "x \* y" := (monoid_op x y) (at level 40, left associativity).

  Instance Z_mult_op : monoid_binop Z | 1 := Zmult. (* monoid_binop の優先順位 1 *)
  Instance Z_plus_op : monoid_binop Z | 2 := Zplus. (* monoid_binop の優先順位 2 *)

  (* monoid_binop の優先度の高い、数字が若い、ほうが使われる。 *)
  Compute 2 \* 5.                              (* 7 or 10 *)
End binop.

(* TCfM *)

Require Import Morphisms Program Unicode.Utf8.

Definition Value := nat.
Definition Vars V := V → Value.

Lemma sum_assoc {A B C} : (A + B) + C → A + (B + C).
  intuition.
Defined.

Lemma bla {A B C} : (A + B) → A + (B + C).
  intuition.
Defined.

Lemma monkey {A B} : False  +  A → A  +  B.
  intuition.
Defined.

Inductive Expr (V : Type) :=
| Mult (a b : Expr V)
| Zero
| Var (v : V).

Implicit Arguments Var [[V]].
Implicit Arguments Zero [[V]].
Implicit Arguments Mult [[V]].

Fixpoint eval {V} (vs : Vars V) (e : Expr V) : Value :=
  match e with
  | Zero => 0
  | Mult a b => eval vs a * eval vs b
  | Var v => vs v
  end.

Instance eval_proper V : Proper (pointwise_relation _ eq ==> eq ==> eq) (@eval V).
Proof.
 repeat intro. subst.
 induction y0; simpl.
 - congruence.
 - reflexivity.
 - now apply H.
Qed.

(* Some simple combinators for variable packs : *)

Definition novars : Vars False := False_rect _.
Variable paradox : False.
Check novars paradox : nat.
Compute novars.
Compute novars paradox.                     (* nat 型の void を返す。 *)

Definition singlevar (x : Value) : Vars unit := fun _ => x.
Check singlevar 0 tt : nat.
Compute singlevar 0.
Compute singlevar 0 tt.                     (* 0 : nat *)

Definition merge {A B} (a : Vars A) (b : Vars B) : Vars (A + B) :=
  fun i => match i with
           | inl j => a j
           | inr j => b j
           end.
Check merge (singlevar 0) novars : Vars (() + False). (* () = unit *)
Compute merge novars (singlevar 0).
Compute merge novars (singlevar 0) (inl paradox). (* void *)
Compute merge novars (singlevar 0) (inr tt).      (* 0 *)

Section Lookup.
  (* Given a heap and value, Lookup instances give the value's index in the heap: *)
  Class Lookup {A} (x : Value) (f : Vars A) :=
    {
      lookup : A;
      lookup_correct : f lookup = x
    }.

  Global Implicit Arguments lookup [[A] [Lookup]].

  Context (x : Value) {A B} (va : Vars A) (vb : Vars B).

  (* If the heap is a merge of two heaps and we can find the value's
  index in the left heap, we can access it by indexing the merged
  heap: *)

  Global Instance lookup_left `{!Lookup x va} : Lookup x (merge va vb) :=
    {
      lookup := inl (lookup x va)
    }.
  Proof.
    simpl.
    Check @lookup_correct A x va Lookup0.
    apply (@lookup_correct _ x _ _).
  Defined.

  (*                                   f             lookup              = x *)
  Goal forall (Lookup0 : Lookup x va), (merge va vb) (inl (lookup x va)) = x.
  Proof.
    intros.
    simpl.
    apply lookup_correct.
  Qed.

  Global Instance lookup_right `{!Lookup x vb} : Lookup x (merge va vb) :=
    {
      lookup := inr (lookup x vb)
    }.
  Proof.
    apply lookup_correct.
  Defined.

  (* If the heap is just a singlevar, we can easily index it. *)

  Global Program Instance lookup_single : Lookup x (singlevar x) :=
    {
      lookup := tt
    }.

End Lookup.

Check novars      : Vars False.
Check singlevar 0 : Vars unit.
Check merge novars (singlevar 0) : Vars (False + unit).

Check lookup 0 novars.
Check @lookup False  0 novars _.
Compute lookup 0 novars.                    (* void *)

Check lookup 0 (singlevar 0).
Check @lookup unit 0 (singlevar 0) (lookup_single 0).
Compute lookup 0 (singlevar 0).             (* tt *)

Check lookup 0 (merge novars (singlevar 0)) : False + unit.
Check @lookup_right 0 False unit novars  (singlevar 0) (lookup_single 0).
Check @lookup (False + unit) 0 (merge novars (singlevar 0)).
(* : Lookup 0 (merge novars (singlevar 0)) → False + () *)
Check @lookup (False + unit) 0 (merge novars (singlevar 0))
      (@lookup_right 0 False unit novars  (singlevar 0) (lookup_single 0)).
Compute lookup 0 (merge novars (singlevar 0)). (* inr tt *)

Check lookup 0 (merge (singlevar 0) (singlevar 0)) : unit + unit.
Compute lookup 0 (merge (singlevar 0) (singlevar 0)). (* inr tt *)

Check lookup 0 (merge (singlevar 0) (singlevar 1)) : unit + unit.
Compute lookup 0 (merge (singlevar 0) (singlevar 1)). (* inl tt *)

Check lookup 0 (merge (singlevar 1) (singlevar 1)) : unit + unit.
Compute lookup 0 (merge (singlevar 1) (singlevar 1)). (* void *)

Check lookup 0 (merge novars (merge (singlevar 0) (singlevar 0))) : False + (unit + unit).
Compute lookup 0 (merge novars (merge (singlevar 0) (singlevar 0))). (* inr (inr tt) *)

Check lookup 0 (merge novars (merge (singlevar 0) (singlevar 1))) : False + (unit + unit).
Compute lookup 0 (merge novars (merge (singlevar 0) (singlevar 1))). (* inr (inl tt) *)

Check lookup 0 (merge novars (merge (singlevar 1) (singlevar 1))) : False + (unit + unit).
Compute lookup 0 (merge novars (merge (singlevar 1) (singlevar 1))). (* void *)

Section Test.
Variable x y : Value.
Compute lookup x (merge novars (merge (singlevar 1) (singlevar 1))). (* void *)
Compute lookup x (merge novars (merge (singlevar 1) (singlevar x))). (* inr (inr ()) *)

Compute Lookup 1 (merge novars (merge (singlevar 1) (singlevar 1))).
Compute Lookup x (merge novars (merge (singlevar 1) (singlevar x))).

Check Lookup x
      (λ x0 : False + (() + ()), match x0 with
                                  | inl x => match x return nat with
                                             end
                                  | inr (inl _) => 1
                                  | inr (inr _) => x
                                  end).

Check lookup_correct : novars (lookup 0 novars) = 0.
Check lookup_correct : singlevar 0 (lookup 0 (singlevar 0)) = 0.
Check lookup_correct :
  merge novars (singlevar 0) (lookup 0 (merge novars (singlevar 0))) = 0.

Check lookup_correct :
  merge novars (merge (singlevar 1) (singlevar x))
        (lookup x (merge novars (merge (singlevar 1) (singlevar x)))) = x.
Compute (lookup x (merge novars (merge (singlevar 1) (singlevar x)))). (* inr (inr ()) *)
End Test.

Check @lookup_correct False 0 novars _ : novars (lookup 0 novars) = 0.
Check @lookup_correct unit 0 (singlevar 0) (lookup_single 0) :
  singlevar 0 (lookup 0 (singlevar 0)) = 0.

Check @lookup_right 0 False unit novars (singlevar 0) (lookup_single 0).
(*
  ∀ Lookup : Lookup 0 (merge novars (singlevar 0)),
  merge novars (singlevar 0)
  (lookup 0 (merge novars (singlevar 0)))
  = 0
*)
Check @lookup_correct (False + unit) 0 (merge novars (singlevar 0))
      (@lookup_right 0 False unit novars (singlevar 0) (lookup_single 0)) :
  merge novars (singlevar 0) (lookup 0 (merge novars (singlevar 0))) = 0.

Definition map_var {V W : Type} (f : V → W) : Expr V → Expr W :=
  fix F (e : Expr V) : Expr W :=
    match e with
    | Mult a b => Mult (F a) (F b)
    | Zero => Zero
    | Var v => Var (f v)
    end.

(* An obvious identity is : *)

Lemma eval_map_var {V W} (f : V → W) v e :
  eval v (map_var f e) = eval (v ∘ f) e.
Proof.
 induction e; simpl; try reflexivity.
 rewrite IHe1, IHe2.
 reflexivity.
Qed.

(* Finally, Quote itself : *)

Section Quote.

  Class Quote {V} (l : Vars V) (n : Value) {V'} (r : Vars V') :=
    {
      quote : Expr (V + V');
      eval_quote : @eval (V + V') (merge l r) quote = n
    }.

  Implicit Arguments quote [[V] [l] [V'] [r] [Quote]].

  Global Program Instance quote_zero V (v : Vars V) : Quote v 0 novars :=
    {
      quote := Zero
    }.

  Global Program Instance quote_mult V (v : Vars V) n
         V' (v' : Vars V') m V'' (v'' : Vars V'')
         `{!Quote v n v'}
         `{!Quote (merge v v') m v''} : Quote v (n * m) (merge v' v'') :=
    {
      quote := Mult (map_var bla (quote n)) (map_var sum_assoc (quote m))
    }.
  Next Obligation.
  Proof.
    destruct Quote0, Quote1.
    subst. simpl.
    do 2 rewrite eval_map_var.
    f_equal; apply eval_proper; auto; intro; intuition.
  Qed.

  Global Program Instance quote_old_var V (v : Vars V) x {i : Lookup x v} :
    Quote v x novars | 8 :=                 (* 8 *)
    {
      quote := Var (inl (lookup x v))
    }.
  Next Obligation.
  Proof.
    apply lookup_correct.
  Qed.

  Global Program Instance quote_new_var V (v : Vars V) x :
    Quote v x (singlevar x) | 9 :=          (* 9 *)
    {
      quote := Var (inr tt)
    }.

End Quote.

Check @quote : ∀ (V : Type) (l : Vars V) (n : Value) (V' : Type) (r : Vars V'),
    Quote l n r → Expr (V + V').

Check @eval_quote : ∀ (V : Type) (l : Vars V) (n : Value) (V' : Type) (r : Vars V')
                       (Quote : Quote l n r), eval (merge l r) quote = n.

(* When quoting something from scratch we will want to start with an empty heap.
   To avoid having to mention this, we define quote' and eval_quote': *)

(*
Definition quote': ∀ x {V'} {v: Vars V'} {d: Quote novars x v}, Expr _ := @quote _ _.
 *)
Definition quote' x {V'} {v : Vars V'} {d : Quote novars x v} :
  Expr (False + V').
Proof.
  destruct d.
  easy.
Defined.

(*
Definition eval_quote': ∀ x {V'} {v: Vars V'} {d: Quote novars x v},
  eval (merge novars v) quote = x
    := @eval_quote _ _ .
*)
Definition eval_quote' x {V'} {v : Vars V'} {d : Quote novars x v} :
    eval (merge novars v) quote = x.
Proof.
  intros.
  destruct d.
  unfold quote.
  easy.
Defined.

Implicit Arguments quote' [[V'] [v] [d]].
Implicit Arguments eval_quote' [[V'] [v] [d]].

(* Time for some tests! *)

Goal ∀ x y (P : Value → Prop), P ((x * y) * (x * 0)).
  intros.
  (*
    @eval_quote
    : ∀ (V : Type) (l : Vars V) (n : Value) (V' : Type) (r : Vars V')
     (Quote : Quote l n r), eval (merge l r) quote = n
   *)

  Check eval_quote'.
  (* rewrite <- eval_quote. *)
  (*
    10, 9 のときエラーになる。
  Error: Cannot infer the implicit parameter l of eval_quote whose type is
  "Vars ?V" in environment:
  x, y : nat
  P : Value → Prop
  *)

  rewrite <- (eval_quote' _).
    (* turns the goal into
         P (eval some_variable_pack_composed_from_combinators quote)
    *)
  simpl quote.
Admitted.

(* We can also inspect quotations more directly : *)

Section inspect.
  Variables x y : Value.

  Eval compute in quote.                    (* Zero *)

  Check @quote _     _      x _ _ _ : Expr (() + False). (* これはだめとする。 *)
  Check @quote False novars x _ _ _ : Expr (False + ()).
  Check quote' x                    : Expr (False + ()).

  Compute @quote _     _      x _ _ _.      (* = Var (inl ()) *)
  Compute @quote False novars x _ _ _.      (* = Var (inr ()) *)
  Compute quote' x.                         (* = Var (inr ()) *)

  Check quote' 0 : Expr (False + False).
  Check quote' x : Expr (False + ()).
  Check quote' y : Expr (False + ()).
  Check quote' (x * 0) : Expr (False + (() + False)).
  Check quote' (x * y) : Expr (False + (() + ())).
  Check quote' ((x * y) * (x * 0)) : Expr (False + (() + () + (False + False))).

  Check @quote False novars ((x * y) * (x * 0)) _ _ _ : Expr (False + (() + () + (False + False))).

  Eval compute in quote' 0.       (* = Zero *)
  Eval compute in quote' x.       (* = Var (inr tt) *)
  Eval compute in quote' y.       (* = Var (inr tt) *)
  Eval compute in quote' (x * 0). (* = Mult (Var (inr (inl tt))) Zero *)
  Eval compute in quote' (x * y). (* = Mult (Var (inr (inl tt))) (Var (inr (inr tt))) *)
  Eval compute in quote' ((x * y) * (x * 0)).
  (* = Mult (Mult (Var (inr (inl (inl ())))) (Var (inr (inl (inr ())))))
     (Mult (Var (inr (inl (inl ())))) Zero) *)

  Check @eval_quote False novars 0 _ _ _ : eval (merge novars novars) quote = 0.
  Check eval_quote' 0 : eval (merge novars novars) quote = 0.

  (* 10,9 のとき、未定変数が残る。 *)
  Check @eval_quote _     _      x _ _ _ : eval (merge _      (singlevar x)) quote = x.
  (* 8,9 のとき、値が決まる。 *)
  Check @eval_quote _     _      x _ _ _ : eval (merge (singlevar x) novars) quote = x.

  (* ↑×とする。 *)
  Check @eval_quote False novars x _ _ _ : eval (merge novars (singlevar x)) quote = x.
  Check eval_quote' x : eval (merge novars (singlevar x)) quote = x.

  Compute @eval_quote _     _      x _ _ _.
  (* ↑×とする。 *)
  Compute @eval_quote False novars x _ _ _.
  Compute eval_quote' x.

  Check eval_quote' y : eval (merge novars (singlevar y)) quote = y.
  Check eval_quote' (x * 0) :
    eval (merge novars (merge (singlevar x) novars)) quote = x * 0.
  Check eval_quote' (x * y) :
    eval (merge novars (merge (singlevar x) (singlevar y))) quote = x * y.
  Check eval_quote' ((x * y) * (x * 0)) :
    eval
      (merge novars
             (merge (merge (singlevar x) (singlevar y)) (merge novars novars))) quote =
    x * y * (x * 0).

  (* ひとつの _ が決まると、すべて決まる。 *)
  Check eval_quote' _ : eval _ (quote' _) = _.
  Check @eval_quote _ _ _ _ _ _ : eval _ (@quote _ _ _ _ _ _) = _.

  (* みっつのバリエーション *)
  Check eval_quote' x : eval _ (quote' x) = x.
  (*
     eval_quote' x : eval (merge novars (singlevar x)) (quote' x) = x
     : eval (merge novars (singlevar x)) (quote' x) = x
   *)
  Check @eval_quote _ _ x _ _ _ : eval _ (@quote _ _ x _ _ _) = x.
  (*
     8,9 のとき、
     eval_quote : eval (merge (singlevar x) novars) quote = x
     : eval (merge (singlevar x) novars) quote = x

     10,9 のとき、
     eval_quote : eval (merge ?l (singlevar x)) quote = x
     : eval (merge ?l (singlevar x)) quote = x
   *)
  (* @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ *)

  (* The second occurrence of (Var (inr (inl (inl ())))) means
   the quoting has successfully noticed that it's the same
   expression. *)

  (* The two units in the generated variable index type reflect the
   fact that the expression contains two variables. *)

  (* I think adding some additional Quote instances might let us
   get rid of the False's, but at the moment I see little reason to. *)
End inspect.

(* If we want to quote an equation between two expressions we should make
 sure that the both sides refer to the same variable pack, and for that we write a
 little utility function. It does the same kind of shuffling that the mult
 Quote instance did. *)

Lemma quote_equality {V} {v : Vars V} {V'} {v' : Vars V'} (l r : Value) `{!Quote novars l v} `{!Quote v r v'} :
  let heap := (merge v v') in
  eval heap (map_var monkey quote) = eval heap quote → l = r.
Proof with intuition.
 destruct Quote0 as [lq []].
 destruct Quote1 as [rq []].
 intros heap H.
 subst heap. simpl in H.
 rewrite <- H, eval_map_var.
 apply eval_proper... intro...
Qed.

Goal ∀ x y, x * y = y * x.
 intros.
 apply (quote_equality _ _).
 simpl quote.
 unfold map_var, monkey, sum_rect.
Admitted.

End with_vars.

(* END *)


Require Export AppearsInKVL.
Require Export InductiveDataTypes.
Require Export BPlusTree.
Require Export ValidBPlusTree.
Require Export SortingProofs.
Require Export FindSubtreeProofs.

Lemma kv_appears_in_split_node_appears_in_lists: forall {X: Type} b k v n left right,
  kvl_sorted (left ++ right) ->
  key_at_index 0 right = Some n ->
  kv_appears_in_kvl k v left \/ kv_appears_in_kvl k v right ->
  kv_appears_in_tree k v (bptNode b X [(0, bptLeaf b X left), (n, bptLeaf b X right)]).
Proof.
  intros. destruct H1.
  Case "Left hand side".
    apply kv_ait_node_here. apply kv_ait_leaf. assumption. destruct right.
    simpl in H0. inversion H0. inversion H0. destruct p. inversion H3. subst.
    apply kv_appears_in_kvl_app in H1. do 2 destruct H1. subst.
    rewrite <- app_assoc in H. apply kvl_sorted_app with (l1:=witness) in H. destruct H.
    apply kvl_sorted_key_across_app in H1. omega.
  Case "Right hand side".
    apply kv_ait_node_last. apply kv_ait_leaf. assumption.
    SCase "n <=".
      inversion H0. destruct right. inversion H3. destruct p. inversion H3. subst. remember (beq_nat n k).
      destruct b0. symmetry in Heqb0. apply beq_nat_true in Heqb0. subst. omega.
      apply kv_appears_cons in H1. apply kv_appears_in_kvl_app in H1. do 2 destruct H1. subst.
      apply kvl_sorted_app with (l1:=left) in H. inversion H.
      apply kvl_sorted_key_across_app in H2.  omega. symmetry in Heqb0.
      apply beq_nat_false in Heqb0. omega.
Qed.

Lemma kv_appears_in_tree_when_appears_in_subtree: forall (X: Type) (b k k1 k2: nat) (v: X) (t1 t2: bplustree b X) (l1 l2: list (nat * bplustree b X)),
  kv_appears_in_tree k v t1 ->
  k1 <= k < k2 ->
  kvl_sorted (l1 ++ (k1, t1) :: (k2, t2)::l2) ->
  kv_appears_in_tree k v (bptNode b X (l1 ++ (k1, t1) :: (k2, t2)::l2)).
Proof.
  intros.
  induction l1.
  Case "l1 = []".
    simpl.
   apply kv_ait_node_here; assumption.
     destruct a. rewrite <- app_comm_cons.
     destruct l1.
       simpl.
       apply kv_ait_node_later. apply IHl1.
         simpl. simpl in H1. apply list_tail_is_sorted in H1. apply H1.
         omega.
       rewrite <- app_comm_cons. destruct p.
       destruct l1.
         simpl. apply kv_ait_node_later. simpl in IHl1. apply IHl1.
           simpl in H1. apply list_tail_is_sorted in H1. apply H1.
           simpl in H1. inversion H1. inversion H4.
           apply blt_nat_true in H15. omega.

         rewrite <- app_comm_cons. destruct p.
         apply kv_ait_node_later. apply IHl1.
           apply list_tail_is_sorted in H1. apply H1.
           simpl in H1.
           inversion H1.
           apply kvl_sorted_key_across_app with (l1 := ((n1,b2)::l1)) in H4.
           omega.
Qed.

Lemma kv_appears_in_tree_when_appears_in_last_subtree: forall (X: Type) (b k k1 k2: nat) (v: X) (t1 t2: bplustree b X) (l1: list (nat * bplustree b X)),
  kv_appears_in_tree k v t1 ->
  k1 <= k ->
  kvl_sorted ((k2,t2)::l1 ++ [(k1, t1)]) ->
  kv_appears_in_tree k v (bptNode b X ((k2,t2)::l1 ++ [(k1, t1)])).
Proof.
  intros. generalize dependent k2. generalize dependent t2.
  induction l1.
  Case "l1 = []".
    intros.
    simpl.
    apply kv_ait_node_last; assumption.
  Case "l1 = a::l1". destruct a.
    intros.
    destruct l1.
      simpl.
      apply kv_ait_node_later. apply kv_ait_node_last; assumption.
      simpl in H1.
      inversion H1. inversion H4.
      apply blt_nat_true in H15. omega.
      destruct p.
      repeat rewrite <- app_comm_cons.
      apply kv_ait_node_later.
      apply IHl1.
      simpl in H1. simpl. apply list_tail_is_sorted in H1. apply H1.

      simpl in H1. apply list_tail_is_sorted in H1.
      apply kvl_sorted_key_across_app with (l1 := ((n0, b1)::l1)) in H1.
      omega.
Qed.

Lemma kv_appears_in_known_subtree: forall {X:Type} b n1 k v n2 t1 t2 kpl kpl',
  kpl = bptNode b X ((n1, t1) :: (n2, t2) :: kpl') ->
  n1 <= k < n2 ->
  kv_appears_in_tree k v kpl ->
  kv_appears_in_tree k v t1.
Proof.
  intros. induction H1; inversion H; subst; try (exfalso; omega).
  Case "ait_here".
    assumption.
Qed.

Lemma kv_appears_in_later_subtree: forall {X:Type} b n1 k v n2 n3 t1 t2 t3 kpl kpl',
  kpl = bptNode b X ((n1, t1) :: (n2, t2) :: (n3, t3) :: kpl') ->
  kvl_sorted ((n1, t1) :: (n2, t2) :: (n3, t3) :: kpl') ->
  k >= n2 ->
  kv_appears_in_tree k v kpl ->
  kv_appears_in_tree k v (bptNode b X ((n2, t2) :: (n3, t3) :: kpl')).
Proof.
  intros. induction H2; inversion H; subst; try (exfalso; omega).
  assumption.
Qed.

Lemma kv_appears_in_tree_before_kpl_start_false: forall {X:Type} b n k v t kpl,
  n > k ->
  kvl_sorted ((n, t) :: kpl) ->
  kv_appears_in_tree k v (bptNode b X ((n, t) :: kpl)) ->
  False.
Proof.
  intros. remember (bptNode b X ((n, t) :: kpl)). destruct H1; inversion Heqb0; subst.
  apply kvl_sorted_key_across_app with (l1:=[])(l2:=[]) in H0. omega. omega.
  apply kvl_sorted_key_across_app with (k1:=n)(v1:=t)(k2:=k1)(v2:=v1)(l1:=[])(l2:=(k2, v2)::l) in H0.
  omega.
Qed.

Lemma kv_appears_in_tree_two_last: forall {X: Type} b n1 n2 t1 t2 k v,
  k >= n2 ->
  kv_appears_in_tree k v (bptNode b X [(n1, t1), (n2, t2)]) ->
  kv_appears_in_tree k v t2.
Proof.
  intros. remember (bptNode b X [(n1, t1), (n2, t2)]). destruct H0. inversion Heqb0.
  inversion Heqb0. subst. assumption. inversion Heqb0. subst. exfalso. omega.
  inversion Heqb0.
Qed.

(* Informal: We know k appears in the parent tree, and we know that find_subtree
 * returns the subtree when searching for k, so hence k must also appear in the
 * subtree *)
Lemma kv_appears_in_subtree_when_appears_in_tree_and_found:
    forall (X: Type) (b k key: nat) (v: X)
    (subtree: bplustree b X) (kpl: list (nat * bplustree b X)),

  kvl_sorted kpl ->
  kv_appears_in_tree k v (bptNode b X kpl) ->
  find_subtree k kpl = Some (key, subtree) ->

  kv_appears_in_tree k v subtree.
Proof.
  intros. induction kpl.
  Case "kpl = []".
	  simpl in H0. inversion H0.
  Case "kpl = a :: kpl".
  	  destruct a. destruct kpl.
  	    inversion H0.
  	    destruct p. remember (ble_nat n k && blt_nat k n0) as loc. destruct loc.
  	      unfold find_subtree in H1. rewrite <- Heqloc in H1. inversion H1.
	      symmetry in Heqloc. unfold andb in Heqloc.
	      apply ble_and_blt_true in Heqloc. eapply kv_appears_in_known_subtree in H0.
	      apply H0. rewrite H4. reflexivity. assumption.
	  symmetry in Heqloc. apply ble_and_blt_false in Heqloc.
	  destruct kpl.
	  SCase "kpl = []".
	    destruct Heqloc.
	    apply kv_appears_in_tree_before_kpl_start_false in H0. inversion H0.
	    assumption. assumption.
	    apply kv_appears_in_tree_two_last in H0.  apply find_subtree_later in H1.
	    apply find_subtree_one_impl_found in H1. destruct H1. rewrite <- H3. assumption.
	    right. assumption. right. assumption. assumption. assumption.
	  SCase "kpl = p :: kpl".
	    destruct p.
	    apply IHkpl. apply list_tail_is_sorted in H. assumption.
	    destruct Heqloc.
	      apply kv_appears_in_tree_before_kpl_start_false in H0; try assumption. inversion H0.
	      eapply kv_appears_in_later_subtree in H0. apply H0. reflexivity.  assumption. assumption.
	    eapply find_subtree_later in Heqloc. apply Heqloc. apply H. apply H1.
Qed.

(* Informal: We know k appears in the subtree that find_subtree returns, so
   * when appears_in_tree k parent tries to identify the subtree, it will find
   * the same as find_subtree, and because it exists in the subtree, it must also
   * exists in the parent tree *)
Lemma kv_appears_in_tree_when_appears_in_subtree_and_found: forall (X: Type) (b k key: nat) (v: X) (parent subtree: bplustree b X) (kpl: list (nat * bplustree b X)),
  2 <= length kpl ->
  kvl_sorted kpl ->
  parent = bptNode b X kpl ->
  find_subtree k kpl = Some (key, subtree) ->
  kv_appears_in_tree k v subtree ->

  kv_appears_in_tree k v parent.
Proof.
  intros.
  rewrite H1.
  assert (key <= k).
    apply find_subtree_returns_a_lesser_key in H2; try assumption.
    omega.
  apply find_subtree_impl_kpl_app in H2.
  do 2 destruct H2.
  inversion H2. clear H2.
  destruct witness0.
  Case "witness0 = []".
    destruct witness.
    SCase "witness = []".
      simpl in H5. rewrite H5 in H. simpl in H. exfalso. omega.
    SCase "witness = p::witness".
      destruct p.
      rewrite <- app_comm_cons in H5.
      rewrite H5.
      rewrite H5 in H0.
      apply kv_appears_in_tree_when_appears_in_last_subtree; assumption.
  Case "witness = p::witness".
    destruct p.
    inversion H6. inversion H2.
    do 3 destruct H2.
    inversion H2. clear H2. inversion H7. subst.
    apply kv_appears_in_tree_when_appears_in_subtree; try assumption.
      omega.
Qed.


Require Import init.

Require Export category_functor.

Class NatTransformation `{C1 : Category, C2 : Category}
    `(F : @Functor C1 C2, G : @Functor C1 C2) :=
{
    nat_trans_f : ∀ A,
        cat_morphism C2 (F A) (G A);
    nat_trans_commute : ∀ {A B} (f : cat_morphism C1 A B),
        nat_trans_f B ∘ (⌈F⌉ f) = (⌈G⌉ f) ∘ nat_trans_f A;
}.

Arguments nat_trans_f {C1 C2 F G} NatTransformation.
Arguments nat_trans_commute {C1 C2 F G} NatTransformation {A B}.

Coercion nat_trans_f : NatTransformation >-> Funclass.
(** So nat_trans_commute says:
    [(α B) ∘ (⌈F⌉ f) = (⌈G⌉ f) ∘ (α A)]
*)

(* begin show *)
Local Program Instance id_nat_transformation `{C1 : Category, C2 : Category}
    `(F : @Functor C1 C2) : NatTransformation F F :=
{
    nat_trans_f A := 𝟙
}.
(* end show *)
Next Obligation.
    rewrite cat_lid.
    rewrite cat_rid.
    reflexivity.
Qed.

Notation "'𝕀'" := (id_nat_transformation _).

(* begin show *)
Local Program Instance vcompose_nat_transformation `{C1 : Category, C2 : Category}
    `{F : @Functor C1 C2, G : @Functor C1 C2, H : @Functor C1 C2}
    `(α : @NatTransformation C1 C2 G H, β : @NatTransformation C1 C2 F G)
    : NatTransformation F H :=
{
    nat_trans_f A := α A ∘ β A
}.
(* end show *)
Next Obligation.
    rewrite cat_assoc.
    rewrite <- cat_assoc.
    rewrite nat_trans_commute.
    rewrite cat_assoc.
    rewrite nat_trans_commute.
    reflexivity.
Qed.

(* begin show *)
Local Program Instance hcompose_nat_transformation
    `{C1 : Category, C2 : Category, C3 : Category}
    `{F' : @Functor C2 C3, G' : @Functor C2 C3}
    `{F : @Functor C1 C2, G : @Functor C1 C2}
    `(β : @NatTransformation C2 C3 F' G', α : @NatTransformation C1 C2 F G)
    : NatTransformation (F' ○ F) (G' ○ G) :=
{
    nat_trans_f A := β (G A) ∘ (⌈F'⌉ (α A))
}.
(* end show *)
Next Obligation.
    rewrite nat_trans_commute.
    rewrite <- cat_assoc.
    rewrite nat_trans_commute.
    rewrite cat_assoc.
    rewrite <- functor_compose.
    rewrite nat_trans_commute.
    rewrite functor_compose.
    rewrite <- cat_assoc.
    rewrite nat_trans_commute.
    reflexivity.
Qed.

Notation "α □ β" := (vcompose_nat_transformation α β) (at level 20, left associativity).
Notation "α ⊡ β" := (hcompose_nat_transformation α β) (at level 20, left associativity).
Global Remove Hints id_nat_transformation vcompose_nat_transformation hcompose_nat_transformation : typeclass_instances.

Theorem nat_trans_compose_eq `{C1 : Category, C2 : Category}
    `{F : @Functor C1 C2, G : @Functor C1 C2, H : @Functor C1 C2} :
    ∀ (α : NatTransformation G H) (β : NatTransformation F G),
    ∀ A, (α □ β) A = α A ∘ β A.
Proof.
    intros α β A.
    cbn.
    reflexivity.
Qed.

Theorem nat_trans_eq `{C1 : Category, C2 : Category}
    `{F : @Functor C1 C2, G : @Functor C1 C2} :
    ∀ (α β : NatTransformation F G), (∀ A, α A = β A) → α = β.
Proof.
    intros [f1 commute1] [f2 commute2] H.
    cbn in *.
    assert (f1 = f2) as eq.
    {
        apply functional_ext.
        exact H.
    }
    subst f2; clear H.
    rewrite (proof_irrelevance commute2 commute1).
    reflexivity.
Qed.

Theorem nat_trans_interchange `{C1 : Category, C2 : Category, C3 : Category}
    `{F  : @Functor C1 C2, G  : @Functor C1 C2, H  : @Functor C1 C2}
    `{F' : @Functor C2 C3, G' : @Functor C2 C3, H' : @Functor C2 C3} :
    ∀ (α  : NatTransformation F  G ) (β  : NatTransformation G  H)
      (α' : NatTransformation F' G') (β' : NatTransformation G' H'),
    (β' □ α') ⊡ (β □ α) = (β' ⊡ β) □ (α' ⊡ α).
Proof.
    intros α β α' β'.
    apply nat_trans_eq.
    intros A.
    cbn.
    do 2 rewrite <- cat_assoc.
    apply lcompose.
    rewrite functor_compose.
    do 2 rewrite cat_assoc.
    apply rcompose.
    apply nat_trans_commute.
Qed.

Theorem nat_trans_id_interchange `{C1 : Category, C2 : Category, C3 : Category}
    `{F : @Functor C2 C3, G : @Functor C1 C2} :
    (id_nat_transformation F) ⊡ (id_nat_transformation G) =
    id_nat_transformation (F ○ G).
Proof.
    apply nat_trans_eq.
    intros A.
    cbn.
    rewrite cat_lid.
    apply functor_id.
Qed.

Theorem nat_trans_lid `{C1 : Category, C2 : Category}
    `{F : @Functor C1 C2, G : @Functor C1 C2} :
    ∀ (α : NatTransformation F G), 𝕀 □ α = α.
Proof.
    intros α.
    apply nat_trans_eq.
    intros A.
    cbn.
    apply cat_lid.
Qed.
Theorem nat_trans_rid `{C1 : Category, C2 : Category}
    `{F : @Functor C1 C2, G : @Functor C1 C2} :
    ∀ (α : NatTransformation F G), α □ 𝕀 = α.
Proof.
    intros α.
    apply nat_trans_eq.
    intros A.
    cbn.
    apply cat_rid.
Qed.
Theorem nat_trans_assoc `{C1 : Category, C2 : Category}
    `{F : @Functor C1 C2, G : @Functor C1 C2,
      H : @Functor C1 C2, I : @Functor C1 C2} :
    ∀ (α : NatTransformation H I)
      (β : NatTransformation G H)
      (γ : NatTransformation F G),
      α □ (β □ γ) = (α □ β) □ γ.
Proof.
    intros α β γ.
    apply nat_trans_eq.
    intros A.
    cbn.
    apply cat_assoc.
Qed.

(* begin show *)
Local Program Instance FUNCTOR `(C1 : Category, C2 : Category) : Category := {
    cat_U := Functor C1 C2;
    cat_morphism F G := NatTransformation F G;
    cat_compose {A B C} α β := α □ β;
    cat_id F := id_nat_transformation F;
}.
(* end show *)
Next Obligation.
    apply nat_trans_assoc.
Qed.
Next Obligation.
    apply nat_trans_lid.
Qed.
Next Obligation.
    apply nat_trans_rid.
Qed.
Global Remove Hints FUNCTOR : typeclass_instances.

Definition nat_isomorphism `{C1 : Category, C2 : Category}
    `{F : @Functor C1 C2, G : @Functor C1 C2} `(α : @NatTransformation C1 C2 F G)
    := isomorphism (C0 := FUNCTOR C1 C2) α.

Theorem nat_isomorphism_A `{C1 : Category, C2 : Category}
    `{F : @Functor C1 C2, G : @Functor C1 C2} : ∀ α : NatTransformation F G,
    nat_isomorphism α ↔ (∀ A, isomorphism (α A)).
Proof.
    intros α.
    split.
    -   intros α_iso A.
        destruct α_iso as [β [β_eq1 β_eq2]].
        cbn in *.
        exists (β A).
        do 2 rewrite <- nat_trans_compose_eq.
        rewrite β_eq1, β_eq2.
        cbn.
        split; reflexivity.
    -   intros all_iso.
        pose (β_f A := ex_val (all_iso A)).
        assert (∀ {A B} (f : cat_morphism C1 A B),
            β_f B ∘ (⌈G⌉ f) = (⌈F⌉ f) ∘ β_f A) as β_commute.
        {
            intros A B f.
            unfold β_f.
            rewrite_ex_val A' [A'_eq1 A'_eq2].
            rewrite_ex_val B' [B'_eq1 B'_eq2].
            apply rcompose with (⌈F⌉ f) in A'_eq2.
            rewrite cat_lid in A'_eq2.
            rewrite <- cat_assoc in A'_eq2.
            rewrite nat_trans_commute in A'_eq2.
            apply rcompose with B' in A'_eq2.
            do 2 rewrite <- cat_assoc in A'_eq2.
            rewrite B'_eq1 in A'_eq2.
            rewrite cat_rid in A'_eq2.
            exact A'_eq2.
        }
        pose (β := {|nat_trans_commute := β_commute|}).
        exists β.
        cbn.
        split.
        +   apply nat_trans_eq.
            intros A.
            cbn.
            unfold β_f.
            rewrite_ex_val B [B_eq1 B_eq2].
            exact B_eq1.
        +   apply nat_trans_eq.
            intros A.
            cbn.
            unfold β_f.
            rewrite_ex_val B [B_eq1 B_eq2].
            exact B_eq2.
Qed.

Definition nat_isomorphic `{C1 : Category, C2 : Category}
    `(F : @Functor C1 C2, G : @Functor C1 C2)
    := isomorphic (C0 := FUNCTOR C1 C2) F G.

Theorem nat_isomorphic_wd `{C1 : Category, C2 : Category, C3 : Category} :
    ∀ (F G : Functor C2 C3) (H I : Functor C1 C2),
    nat_isomorphic F G → nat_isomorphic H I →
    nat_isomorphic (F ○ H) (G ○ I).
Proof.
    intros F G H I [α [α' [α_eq1 α_eq2]]] [β [β' [β_eq1 β_eq2]]].
    cbn in *.
    exists (α ⊡ β).
    exists (α' ⊡ β').
    cbn.
    split.
    -   rewrite <- nat_trans_interchange.
        rewrite α_eq1, β_eq1.
        apply nat_trans_id_interchange.
    -   rewrite <- nat_trans_interchange.
        rewrite α_eq2, β_eq2.
        apply nat_trans_id_interchange.
Qed.

Theorem lnat_iso `{C1 : Category, C2 : Category, C3 : Category} :
    ∀ {F G : Functor C1 C2} (H : Functor C2 C3),
    isomorphic (C0 := FUNCTOR C1 C2) F G →
    isomorphic (C0 := FUNCTOR C1 C3) (H ○ F) (H ○ G).
Proof.
    intros F G H eq.
    pose proof (isomorphic_refl (C0:= FUNCTOR C2 C3) H) as eq2.
    exact (nat_isomorphic_wd _ _ _ _ eq2 eq).
Qed.
Theorem rnat_iso `{C1 : Category, C2 : Category, C3 : Category} :
    ∀ {F G : Functor C2 C3} (H : Functor C1 C2),
    isomorphic (C0 := FUNCTOR C2 C3) F G →
    isomorphic (C0 := FUNCTOR C1 C3) (F ○ H) (G ○ H).
Proof.
    intros F G H eq.
    pose proof (isomorphic_refl (C0:= FUNCTOR C1 C2) H) as eq2.
    exact (nat_isomorphic_wd _ _ _ _ eq eq2).
Qed.


Section Approx2.

Variable Model : Type.

Definition BoolF : Type := Model -> bool.

Definition unsat (x : BoolF) : Prop :=
    forall m, ~ eq_true (x m)
    .

(* We approximate an element as:
    p - condition under which the element is known.
    a - value of the element when known.
    b - value of the element when unknown.
*)
Definition approx (T : Type) (x : Model -> T) (p : BoolF) (a : Model -> T) (b : Model -> T) : Prop
    := (forall t, x t = if p t then a t else b t)
    .

Theorem approx_useful_sat : forall x xp xa xb m,
    approx x xp xa xb ->
    eq_true (andb (xp m) (xa m)) ->
    eq_true (x m)
    .

Theorem approx_useful_unsat : forall x xp xa xb,
    approx x xp xa xb ->
    unsat

Lemma i_implies_o : forall xi xo xx,
    approx xi xo xx ->
    forall m, eq_true (xi m) -> eq_true (xo m)
    .
Proof.
  intros xi xo xx Ha m Hxi.
  unfold approx in Ha.
  decompose [and] Ha.
  specialize H with m.
  specialize H0 with m.
  exact (H0 (H Hxi)).
Qed.

(* An approximation for something known completely *)
Theorem approx_known : forall x,
    approx x x x
    .
Proof.
  intros x.
  unfold approx.
  split ; intros ; assumption.
Qed.

(* An approximation for something completely unknown *)
Theorem approx_unknown : forall x,
    approx (fun _ => false) (fun _ => true) x
    .
Proof.
  intros x.
  unfold approx.
  split.
   intros m Habsurd. inversion Habsurd.
   split.
Qed.

Theorem approx_not : forall xi xo x,
    approx xi xo x ->
    approx (fun m => negb (xo m)) (fun m => negb (xi m)) (fun m => negb (x m))
    .
Proof.
  intros xi xo x Happrox.
  unfold approx in *.
  decompose [and] Happrox.
  unfold not in *.
  split.
   intros m Ho. specialize H0 with m. destruct (x m).
    set (Hno := H0 is_eq_true). destruct (xo m) ; assumption.
    simpl. exact is_eq_true.

   intros m Hx. specialize H with m. destruct (xi m).
    set (Hnx := H is_eq_true). destruct (x m) ; assumption.
    exact is_eq_true.
Qed.

Theorem approx_and : forall xi xo xx yi yo yy,
    approx xi xo xx ->
    approx yi yo yy ->
    approx (fun m => andb (xi m) (yi m)) (fun m => andb (xo m) (yo m)) (fun m => andb (xx m) (yy m))
    .
Proof.
  intros xi xo xx yi yo yy Hax Hay.
  unfold approx in *.
  split.
   intros m His.
    decompose [and] Hax.
    specialize H with m.
    decompose [and] Hay.
    specialize H1 with m.
    destruct (xx m).
    destruct (yy m).
     exact (is_eq_true).
     destruct (yi m).
     exact (H1 is_eq_true).
     destruct (xi m).
     simpl in His. elim His. exact is_eq_true.
     simpl in His. elim His. exact is_eq_true.
    simpl.
    destruct (xi m).
     exact (H is_eq_true).
     apply His.

   intros m Hxy.
   decompose [and] Hax.
   specialize H0 with m.
   decompose [and] Hay.
   specialize H2 with m.
   destruct (xo m).
    destruct (yo m).
     exact (is_eq_true).
     apply H2. destruct (yy m).
      exact is_eq_true.
      destruct (xx m) ; apply Hxy.
    destruct (xx m).
     exact (H0 is_eq_true).
     apply Hxy.
Qed.

(* Approximation of if then else *)
Theorem approx_ite : forall pi po p xi xo x yi yo y,
    approx pi po p ->
    approx xi xo x ->
    approx yi yo y ->
    approx (fun m => orb (andb (pi m) (xi m)) (andb (negb (po m)) (yi m)))
           (fun m => orb (andb (po m) (xo m)) (andb (negb (pi m)) (yo m)))
           (fun m => if p m then x m else y m)
    .
Proof.
  intros pi po p xi xo x yi yo y Hap Hax Hay.
  unfold approx in *.
  split.
   intros m Htr.
   decompose [and] Hap.
   decompose [and] Hax.
   decompose [and] Hay.
   specialize H with m.
   specialize H0 with m.
   specialize H1 with m.
   specialize H3 with m.
   destruct (pi m), (po m), (p m), (xi m), (xo m), (x m), (yi m), (yo m), (y m) ; auto.

   intros m Htr.
   decompose [and] Hap.
   decompose [and] Hax.
   decompose [and] Hay.
   specialize H with m.
   specialize H0 with m.
   specialize H2 with m.
   specialize H4 with m.
   destruct (pi m), (po m), (p m), (xi m), (xo m), (x m), (yi m), (yo m), (y m) ; auto.
Qed.

Variable Elem : Type.
Definition ElemF : Type := Model -> Elem.

(* We approximate an assignment-parameterized element x using:
    p - a predicate determining when the approximation is exact
    a - the approximation.
*)
Definition eapprox (p : BoolF) (a : ElemF) (x : ElemF) : Prop
    := forall m, eq_true (p m) -> a(m) = x(m)
    .

Theorem eapprox_known : forall x,
    eapprox (fun _ => true) x x
    .
Proof.
  intros x m Hp. reflexivity.
Qed.

Theorem eapprox_unknown : forall x bot,
    eapprox (fun _ => false) bot x
    .
Proof.
  intros x bot m Hp.
  inversion Hp.
Qed.

Theorem approx_unary : forall f xp xa xx,
    eapprox xp xa xx ->
    approx (fun m => andb (xp m) (f (xa m)))
           (fun m => orb (negb (xp m)) (f (xa m)))
           (fun m => f (xx m))
    .
  intros f xp xa xx Hax.
  split.
  unfold eapprox in Hax.
  intro m.
  specialize Hax with m.
  destruct (xp m).
   simpl.
   rewrite (Hax is_eq_true).
   trivial.

   simpl.
   intro Hsilly.
   inversion Hsilly.

  intros m Htr.
  unfold eapprox in Hax.
  specialize Hax with m.
  destruct (xp m).
   rewrite (Hax is_eq_true).
   trivial.

   exact (is_eq_true).
Qed.

Theorem approx_binary : forall f xp xa xx yp ya yy,
    eapprox xp xa xx ->
    eapprox yp ya yy ->
    approx (fun m => andb (xp m) (andb (yp m) (f (xa m) (ya m))))
           (fun m => orb (negb (xp m)) (orb (negb (yp m)) (f (xa m) (ya m))))
           (fun m => f (xx m) (yy m))
    .
Proof.
  intros f xp xa xx yp ya yy Hax Hay.
  split ; intros m H; unfold eapprox in *;
          specialize Hax with m; specialize Hay with m ;
          destruct (xp m), (yp m) ; simpl in H.
    rewrite <- (Hax is_eq_true).
    rewrite <- (Hay is_eq_true).
    assumption.

    inversion H.
    inversion H.
    inversion H.

    rewrite (Hax is_eq_true).
    rewrite (Hay is_eq_true).
    assumption.

    exact (is_eq_true).
    exact (is_eq_true).
    exact (is_eq_true).
Qed.

Theorem eapprox_unary : forall f xp xa xx,
    eapprox xp xa xx ->
    eapprox xp (fun m => f (xa m)) (fun m => f (xx m))
    .
Proof.
  intros f xp xa xx Hax.
  unfold eapprox in *.
  intros m Heq.
  specialize Hax with m.
  rewrite (Hax Heq).
  reflexivity.
Qed.

Theorem eapprox_binary : forall f xp xa xx yp ya yy,
    eapprox xp xa xx ->
    eapprox yp ya yy ->
    eapprox (fun m => andb (xp m) (yp m)) (fun m => f (xa m) (ya m)) (fun m => f (xx m) (yy m))
    .
Proof.
  intros f xp xa xx yp ya yy Hax Hay.
  unfold eapprox in *.
  intros m Heq.
  specialize Hax with m.
  specialize Hay with m.
  destruct (xp m), (yp m).
  rewrite (Hax is_eq_true).
  rewrite (Hay is_eq_true).
  reflexivity.
  inversion Heq.
  inversion Heq.
  inversion Heq.
Qed.

Theorem eapprox_ite : forall pi po pp xp xa xx yp ya yy,
    approx pi po pp ->
    eapprox xp xa xx ->
    eapprox yp ya yy ->
    eapprox (fun m => orb (andb (pi m) (xp m)) (andb (negb (po m)) (yp m)))
            (fun m => if pi m then xa m else ya m)
            (fun m => if pp m then xx m else yy m)
    .
Proof.
  intros pi po pp xp xa xx yp ya yy Hap Hax Hay m H.
  unfold approx in Hap.
  decompose [and] Hap.
  unfold eapprox in *.
  specialize H0 with m.
  specialize H1 with m.
  specialize Hax with m.
  specialize Hay with m.
  destruct (pi m), (pp m), (xp m).
  rewrite (Hax is_eq_true) ; reflexivity.
  destruct (po m).
  inversion H.
  rewrite (Hax (H1 is_eq_true)) ; reflexivity.
  set (Hsilly := H0 is_eq_true).
  inversion Hsilly.
  set (Hsilly := H0 is_eq_true) ; inversion Hsilly.
  destruct (po m).
  inversion H.
  set (Hsilly := H1 is_eq_true) ; inversion Hsilly.
  destruct (po m).
  inversion H.
  set (Hsilly := H1 is_eq_true) ; inversion Hsilly.
  destruct (yp m).
  exact (Hay is_eq_true).
  destruct (po m) ; inversion H.
  destruct (yp m).
  exact (Hay is_eq_true).
  destruct (po m) ; inversion H.
Qed.

End Approx2.