(** Numbers up to @n@ **)
Require Coq.Lists.List.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.EqDep.
Require Import ExtLib.Tactics.Injection.

Set Implicit Arguments.
Set Strict Implicit.
Set Asymmetric Patterns.

(** `fin n` corresponds to "naturals less than `n`",
 ** i.e. a finite set of size n
 **)
Inductive fin : nat -> Type :=
| F0 : forall {n}, fin (S n)
| FS : forall {n}, fin n -> fin (S n).

Fixpoint fin_all (n : nat) : list (fin n) :=
  match n as n return list (fin n) with
    | 0 => nil
    | S n => @F0 n :: List.map (@FS _) (fin_all n)
  end%list.

Theorem fin_all_In : forall {n} (f : fin n),
  List.In f (fin_all n).
Proof.
  induction n; intros.
  inversion f.
  remember (S n). destruct f.
  simpl; firstorder.
  inversion Heqn0. subst.
  simpl. right. apply List.in_map. auto.
Qed.

Theorem fin_case : forall n (f : fin (S n)),
  f = F0 \/ exists f', f = FS f'.
Proof.
  intros. generalize (fin_all_In f). intros.
  destruct H; auto.
  eapply List.in_map_iff in H. right. destruct H.
  exists x. intuition.
Qed.

Definition fin0_elim (f : fin 0) : forall T, T :=
  match f in fin n return match n with
                            | 0 => forall T, T
                            | _ => unit
                          end with
    | F0 _ => tt
    | FS _ _ => tt
  end.

Fixpoint pf_lt (n m : nat) : Prop :=
  match n , m with
    | 0 , S _ => True
    | S n , S m => pf_lt n m
    | _ , _ => False
  end.

Fixpoint make (m n : nat) {struct m} : pf_lt n m -> fin m :=
  match n as n , m as m return pf_lt n m -> fin m with
    | 0 , 0 => @False_rect _
    | 0 , S n => fun _ => F0
    | S n , 0 => @False_rect _
    | S n , S m => fun pf => FS (make m n pf)
  end.

Notation "'##' n" := (@make _ n I) (at level 0).

Global Instance Injective_FS {n : nat} (a b : fin n)
  : Injective (FS a = FS b) :=
{ result := a = b }.
abstract (intro ; inversion H ; eapply inj_pair2 in H1 ; assumption).
Defined.

Fixpoint fin_eq_dec {n} (x : fin n) {struct x} : fin n -> bool :=
  match x in fin n' return fin n' -> bool with
    | F0 _ => fun y => match y with
                         | F0 _ => true
                         | _ => false
                       end
    | FS n' x' => fun y : fin (S n') =>
      match y in fin n'' return (match n'' with
                                   | 0 => unit
                                   | S n'' => fin n''
                                 end -> bool) -> bool with
        | F0 _ => fun _ => false
        | FS _ y' => fun f => f y'
      end (fun y => fin_eq_dec x' y)
    end.

Global Instance RelDec_fin_eq (n : nat) : RelDec (@eq (fin n)) :=
{ rel_dec := fin_eq_dec }.

Global Instance RelDec_Correct_fin_eq (n : nat)
  : RelDec_Correct (RelDec_fin_eq n).
Proof.
  constructor.
  induction x. simpl.
  intro. destruct (fin_case y) ; subst.
  intuition.
  destruct H ; subst.
  intuition ; try congruence.
(*  inversion H.*)
  intro ; destruct (fin_case y) ; subst ; simpl.
  intuition ; try congruence.
  inversion H.
  destruct H ; subst.
  split ; intro.
  f_equal ; eauto.
  eapply IHx.
  eapply H.
  inv_all ; subst.
  apply IHx. reflexivity.
Qed.


(*|
################
Subset parameter
################

:Link: https://stackoverflow.com/q/5194117
|*)

(*|
Question
********

I have a set as a parameter:
|*)

Parameter Q : Set.

(*|
Now I want to define another parameter that is a subset of ``Q``.
Something like:

.. code-block:: coq

    Parameter F : subset Q.

How I can define that? I guess I can add the restriction later as an
axiom, but seems more natural to express it directly in the type of
``F``.
|*)

(*|
Answer
******

You can't express it directly.

It's misleading to think of objects in ``Set`` as mathematical sets.
``Set`` is the sort of datatypes, the same kinds of types that you
find in programming languages (except that Coq's types are very
powerful).

Coq doesn't have subtyping [1]_. If the two types ``F`` and ``Q`` are
distinct, then they are disjoint, as far as the mathematical model is
concerned.

The usual approach is to declare ``F`` as a completely related set,
and declare a canonical injection from ``F`` to ``Q``. You'll want to
specify any interesting property of that injection, beyond the
obvious.
|*)

Reset Initial. (* .none *)
Parameter Q : Set.
Parameter F : Set.
Parameter inj_F_Q : F -> Q.
Axiom inj_F_Q_inj : forall x y : F, inj_F_Q x = inj_F_Q y -> x = y.
Coercion inj_F_Q : F >-> Q.

(*|
That last line declares a coercion from ``F`` to ``Q``. That lets you
put an object of type ``F`` wherever the context requires the type
``Q``. The type inference engine will insert a call to ``inj_F_Q``.
You will need to write the coercion explicitly occasionally, since the
type inference engine, while very good, is not perfect (perfection
would be mathematically impossible). There is a chapter on coercions
in the Coq reference manual; you should at least skim through it.

Another approach is to define your subset with an extensional
property, i.e. declare a predicate ``P`` on the set (the type) ``Q``
and define ``F`` from ``P``.
|*)

Reset Initial. (* .none *)
Parameter Q : Set.
Parameter P : Q -> Prop.
Definition G := sig P.
Definition inj_G_Q : G -> Q := @proj1_sig Q P.
Coercion inj_G_Q : G >-> Q.

(*|
``sig`` is a specification, i.e. a weak sum type, i.e. a pair
consisting of an object and a proof that said object has a certain
property. ``sig P`` is eta-equivalent to ``{x | P x}`` (which is
syntactic sugar ``sig (fun x => P x)``). You have to decide whether
you prefer the short or the long form (you need to be consistent). The
``Program`` vernacular is often useful when working with weak sums.

.. [1] There is subtyping in the module language, but that's not
   relevant here. And coercions fake subtyping well enough for many
   uses, but they're not the real thing.
|*)


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

(**************************************************************************
* TLC: A library for Coq                                                  *
* Sets                                                                    *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import Coq.Classes.Morphisms. (* for [Proper] instances *)
From SLF Require Import LibTactics LibLogic LibReflect LibList
  LibOperation LibMonoid LibInt LibNat
  LibEpsilon LibRelation LibMin.
From SLF Require Export LibContainer.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Construction of sets as predicates *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Basic definitions *)

Definition set (A : Type) := A -> Prop.

Section Operations.
Variables (A B : Type).
Implicit Types x : A.
Implicit Types E F G : set A.

Definition set_st (P:A->Prop) : set A :=
  P.

Definition empty_impl : set A :=
  (fun _ => False).

Definition full_impl : set A :=
  (fun _ => True).

Definition single_impl x :=
  (= x).

Definition in_impl x E :=
  E x.

Definition compl_impl : set A -> set A :=
  @pred_not A. (* -- TODO: as typeclass? *)

Definition union_impl : set A -> set A -> set A :=
  @pred_or A.

Definition inter_impl : set A -> set A -> set A :=
  @pred_and A.

Definition remove_impl : set A -> set A -> set A :=
  fun E F x => E x /\ ~ F x.

Definition incl_impl : set A -> set A -> Prop :=
  @pred_incl A.

Definition disjoint_impl : set A -> set A -> Prop :=
  fun E F : set A => inter_impl E F = empty_impl.

Definition list_repr_impl (E:set A) (l:list A) :=
  noduplicates l /\ forall x, mem x l <-> E x.

Definition to_list (E:set A) :=
  epsilon (list_repr_impl E).

Definition to_set (xs : list A) : set A :=
  set_st (fun x => mem x xs).

Definition list_covers_impl (E:set A) L :=
  forall x, E x -> mem x L.

Definition finite (E:set A) :=
  exists L, list_covers_impl E L.

Definition card_impl (E:set A) : nat :=
  mmin le (fun n => exists L, list_covers_impl E L /\ n = length L).

Definition fold_impl (m:monoid_op B) (f:A->B) (E:set A) :=
  LibList.fold_right (fun x acc => monoid_oper m (f x) acc)
    (monoid_neutral m) (to_list E).

End Operations.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Notations to help the typechecker *)

Notation "x \indom E" := (x \in (dom E : set _))
  (at level 39) : container_scope.

Notation "x \notindom E" := (x \notin ((dom E) : set _))
  (at level 39) : container_scope.

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

Instance Inhab_set : forall A, Inhab (set A).
Proof using. intros. apply (Inhab_of_val (@empty_impl A)). Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Notation through typeclasses *)

Lemma in_inst : forall A, BagIn A (set A).
Proof using. constructor. exact (@in_impl A). Defined.

Hint Extern 1 (BagIn _ (set _)) => apply in_inst : typeclass_instances.
(* -- LATER: could this be an instance like all others ? *)

Instance empty_inst : forall A, BagEmpty (set A).
  constructor. apply (@empty_impl A). Defined.

Instance single_inst : forall A, BagSingle A (set A).
  constructor. rapply (@single_impl A). Defined.

Instance union_inst : forall A, BagUnion (set A).
  constructor. rapply (@union_impl A). Defined.

Instance inter_inst : forall A, BagInter (set A).
  constructor. rapply (@inter_impl A). Defined.

Instance remove_inst : forall A, BagRemove (set A) (set A).
  constructor. rapply (@remove_impl A). Defined.

Instance incl_inst : forall A, BagIncl (set A).
  constructor. rapply (@incl_impl A). Defined.

Instance disjoint_inst : forall A, BagDisjoint (set A).
  constructor. rapply (@disjoint_impl A). Defined.

Instance fold_inst : forall A B, BagFold B (A->B) (set A).
  constructor. rapply (@fold_impl A B). Defined.

Instance card_inst : forall A, BagCard (set A).
  constructor. rapply (@card_impl A). Defined.

Global Opaque set finite in_inst empty_inst single_inst union_inst inter_inst
  remove_inst incl_inst disjoint_inst card_inst fold_inst.

(* ----------------------------------------------------------------------

    Exposed definitions for list coverage *)

(** [list_repr E L] asserts that elements of [E] are exactly
    the elements from the list [L]. *)

Definition list_repr A (E:set A) (L:list A) :=
  noduplicates L /\ (forall x, mem x L <-> x \in E).

(** [list_covers E L] asserts that all elements of [E] all
    belong to the list [L]. *)

Definition list_covers A (E:set A) (L:list A) :=
  forall x, x \in E -> mem x L.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Notations for building sets *)

(** DISCLAIMER: these definitions are experimental, they'll probably change *)

Declare Scope set_scope.

Notation "\set{ x | P }" := (@set_st _ (fun x => P))
 (at level 0, x ident, P at level 200) : set_scope.
Notation "\set{ x : A | P }" := (@set_st A (fun x => P))
 (at level 0, x ident, P at level 200) : set_scope.
Notation "\set{ x '\in' E | P }" := (@set_st _ (fun x => x \in E /\ P))
 (at level 0, x ident, P at level 200) : set_scope.

Notation "\set{= e | x '\in' E }" :=
 (@set_st _ (fun a => exists_ x \in E, a = e ))
 (at level 0, x ident, E at level 200) : set_scope.
Notation "\set{= e | x '\in' E , y ''\in' F }" :=
 (@set_st _ (fun a => exists_ x \in E, exists_ y \in F, a = e ))
 (at level 0, x ident, F at level 200) : set_scope.
Notation "\set{= e | x y '\in' E }" :=
 (@set_st _ (fun a => exists_ x y \in E, a = e ))
 (at level 0, x ident, y ident, E at level 200) : set_scope.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Properties of sets *)

Section Instances.
Variables (A:Type).
Implicit Types E F : set A.

Transparent set finite empty_inst single_inst single_impl in_inst
  incl_inst inter_inst union_inst card_inst fold_inst remove_inst
  disjoint_inst.
Hint Constructors mem.

(** Local tactic to help unfolding all intermediate definitions *)

Ltac set_unf := unfold finite,
  card_inst, card_impl, card,
  to_list,
  disjoint_impl, disjoint_inst, disjoint,
  incl_inst, incl_impl,
  empty_inst, empty_impl, empty,
  single_inst, single_impl, single,
  in_inst, in_impl, is_in,
  incl_inst, incl_impl, incl,
  compl_impl, pred_not,
  inter_inst, inter_impl, inter, pred_and,
  union_inst, union_impl, union, pred_or,
  remove_inst, remove_impl, remove,
  fold_inst, fold_impl, fold in *.

(* ----------------------------------------------------------------------

    Reformulation *)

Lemma disjoint_eq_inter_empty : forall E F,
  (E \# F) = (E \n F = \{}).
Proof using. auto. Qed.

(* ----------------------------------------------------------------------

    set_st and double inclusion *)

Lemma in_set_st_eq : forall (P:A->Prop) x,
  x \in set_st P = P x.
Proof using. intros. apply* prop_ext. Qed.

Lemma set_ext_eq : forall E F,
  (E = F) = (forall (x:A), x \in E <-> x \in F).
Proof using.
  intros. apply prop_ext. iff H. subst*. extens*.
Qed.

Lemma set_ext : forall E F,
  (forall (x:A), x \in E <-> x \in F) ->
  E = F.
Proof using. intros. rewrite~ set_ext_eq. Qed.

Lemma set_st_eq : forall A (P Q : A -> Prop),
  (forall (x:A), P x <-> Q x) ->
  set_st P = set_st Q.
Proof using. intros. asserts_rewrite~ (P = Q). extens~. Qed.

(* ----------------------------------------------------------------------

    set_in, incl *)

Global Instance in_extens_inst : In_extens (A:=A) (T:=set A).
Proof using. constructor. intros. rewrite* set_ext_eq. Qed.

Global Instance in_empty_eq_inst : In_empty_eq (A:=A) (T:=set A).
Proof using. constructor. intros. apply* prop_ext. Qed.

Global Instance in_single_eq_inst : In_single_eq (A:=A) (T:=set A).
Proof using. constructor. intros. apply* prop_ext. Qed.

Global Instance in_union_eq_inst : In_union_eq (A:=A) (T:=set A).
Proof using. constructor. intros. set_unf. simpl. apply* prop_ext. Qed.

Global Instance in_inter_eq_inst : In_inter_eq (A:=A) (T:=set A).
Proof using. constructor. intros. set_unf. apply* prop_ext. Qed.

Global Instance in_remove_eq_inst : In_remove_eq (A:=A) (T:=set A).
Proof using. constructor. intros. set_unf. applys* prop_ext. Qed.

Global Instance incl_in_eq_inst : Incl_in_eq (A:=A) (T:=set A).
Proof using. constructor. intros. set_unf. autos*. Qed.

Global Instance disjoint_eq_inst : Disjoint_eq (T:=set A).
Proof using.
  constructor. intros. rewrite disjoint_eq_inter_empty.
  set_unf. applys prop_ext. iff M.
    intros x. rewrite* <- (@fun_eq_1 _ _ x _ _ M).
    extens*.
Qed.

(* -- LATER: fix naming conventions below *)

(* -- TODO
Lemma nonempty_eq_exists_one : forall E,
  finite E ->
  (E <> \{}) = (exists x, x \in E).
Proof using.
Qed.
*)

Lemma eq_union_single_remove_one : forall E x,
  x \in E ->
  E = \{x} \u (E \-- x).
Proof using.
  introv H. set_unf. extens. intros y. iff M.
    simpls. tests*: (y = x).
    destruct M. subst*. autos*.
Qed.

Lemma set_remove_one_add_same : forall E x,
  x \notin E ->
  E = (E \u \{x}) \-- x.
Proof using.
  introv Hx. set_unf. extens. iff.
  { split. eauto. intro. subst*. }
  { tauto. }
Qed.

(* ----------------------------------------------------------------------

    repr and covers *)

Lemma list_covers_of_list_repr : forall E L,
  list_repr E L ->
  list_covers E L.
Proof using. introv (ND&EQ). introv Hx. rewrite~ EQ. Qed.

Lemma list_repr_disjoint_union : forall E F LE LF,
  E \# F ->
  list_repr E LE ->
  list_repr F LF ->
  list_repr (E \u F) (LE ++ LF).
Proof using.
  introv D (HE&QE) (HF&QF). split.
  applys~ noduplicates_app.
    intros x ? ?. applys* @disjoint_inv x.
      typeclass. rewrite~ <- QE. rewrite~ <- QF.
    intros x. rewrite mem_app_eq. rewrite in_union_eq.
      rewrite <- QE. rewrite* <- QF.
Qed.

Lemma noduplicates_of_list_repr : forall E xs,
  list_repr E xs ->
  noduplicates xs.
Proof using. unfold list_repr. tauto. Qed.

(* see also [list_repr_nil] further on *)

(* ----------------------------------------------------------------------

    to_list *)

Lemma ex_list_repr_impl_of_ex_list_covers_impl : forall E,
  ex (list_covers_impl E) ->
  ex (list_repr_impl E).
Proof using.
  (* --TODO: factorize this wiht later proofs *)
  introv (L&M). sets_eq L1 EQL1: (remove_duplicates L).
  forwards~ (HN&HM&_): remove_duplicates_spec EQL1.
  sets L2: (filter (fun x => x \in E) L1).
  exists L2. split.
    applys* noduplicates_filter.
    intros x. specializes M x. rewrite <- HM in M. set_unf. iff N.
      subst L2. forwards*: mem_filter_inv N.
      applys* mem_filter.
Qed.

Lemma list_repr_to_list_of_finite : forall E,
  finite E ->
  list_repr E (to_list E).
Proof using.
  introv FE. unfolds to_list, finite, list_repr_impl.
  epsilon~ L'.
  applys~ ex_list_repr_impl_of_ex_list_covers_impl.
Qed.

(* corrolary of above, presented as an inversion lemma *)
Lemma eq_to_list_inv : forall E L,
  L = to_list E ->
  finite E ->
  list_repr E L.
Proof.
  introv EQ HE. unfolds. subst. forwards* (?&?): list_repr_to_list_of_finite HE.
Qed.

Lemma finite_eq_in_iff_mem_to_list : forall E,
  finite E = (forall x, x \in E <-> mem x (to_list E)).
Proof.
  intros. applys prop_ext. iff M.
  { forwards* (N1&N2): eq_to_list_inv E. intros x. specializes N2 x. autos*. }
  { exists (to_list E). intros x Ex. rewrite~ <- M. }
Qed.

Lemma to_list_empty :
  to_list (\{}:set A) = nil.
Proof using.
  set_unf. epsilon l.
  { exists (@nil A). split. { constructor. } { intros. rewrite* mem_nil_eq. } }
  intros Hl. inverts Hl. simpls. destruct~ l. false. rewrite <- H0. simple~.
Qed.

Lemma to_list_single : forall (x:A),
  to_list (\{x}) = x::nil.
Proof using.
  intros. unfold to_list. epsilon l.
  { exists (x::nil). split.
   { applys noduplicates_one. }
   { unfold single_inst, single_impl. simple~.
     intros. rewrite* mem_one_eq. } }
  introv Hl. unfolds single_inst, single_impl. simpls~.
  inverts Hl as H H0. destruct (H0 x). specializes~ H2.
  destruct l.
  { inverts H2. }
  { tests E: (x = a).
    { fequals. destruct l. auto. forwards~: (proj1 (H0 a0)).
      subst. inverts H as M1 M2. false* M1. }
    { inverts H2. false. forwards~: (proj1 (H0 a)). false. } }
Qed.

(* See also [finite_eq_mem_to_list] *)

(* ----------------------------------------------------------------------

    finite *)

(* introduction *)

Lemma finite_of_list_covers : forall (E:set A) L,
  list_covers E L ->
  finite E.
Proof using. introv H. exists* L. Qed.

Lemma finite_of_list_repr : forall (E:set A) L,
  list_repr E L ->
  finite E.
Proof using. introv (ND&EQ). exists~ L. introv Hx. rewrite~ EQ. Qed.

Lemma finite_of_ex_list_covers : forall (E:set A),
  ex (list_covers E) ->
  finite E.
Proof using. introv (L&H). applys* finite_of_list_covers. Qed.

(* elimination *)

Definition finite_inv_list_covers_and_card : forall (E:set A),
  finite E ->
  exists L, list_covers E L /\ card E = length L.
Proof.
  introv (L&H). sets m: (card E).
  forwards* (R&P): mmin_spec_nat m.
Qed.

Lemma finite_inv_list_covers : forall (E:set A),
  finite E ->
  exists L, list_covers E L.
Proof using. introv (L&HN). exists L. intros. applys* HN. Qed.

(* operations *)

Lemma finite_empty :
  finite (\{} : set A).
Proof using.
  intros. apply finite_of_ex_list_covers. set_unf.
  exists (@nil A). introv M. inverts M.
Qed.

Lemma finite_single : forall (a : A),
  finite \{a}.
Proof using.
  intros. apply finite_of_ex_list_covers. set_unf.
  exists (a::nil). introv M. hnf in M. subst*.
Qed.

Lemma finite_union : forall E F,
  finite E ->
  finite F ->
  finite (E \u F).
Proof using.
  introv H1 H2. apply finite_of_ex_list_covers.
  lets (L1&E1): finite_inv_list_covers H1.
  lets (L2&E2): finite_inv_list_covers H2.
  exists (L1++L2). unfolds list_covers.
  introv M.
  rewrite @in_union_eq in M; try typeclass.
  rewrite* mem_app_eq.
Qed.

Lemma finite_inter : forall E F,
  finite E \/ finite F ->
  finite (E \n F).
Proof using.
  introv H. apply finite_of_ex_list_covers. destruct H.
  lets (L&EQ): finite_inv_list_covers H. exists L. unfold list_covers. set_unf. autos*.
  lets (L&EQ): finite_inv_list_covers H. exists L. unfold list_covers. set_unf. autos*.
Qed.

Lemma finite_incl : forall E F,
  E \c F ->
  finite F ->
  finite E.
Proof using.
  introv HI HF. apply finite_of_ex_list_covers.
  lets (L&EQ): finite_inv_list_covers HF. unfold list_covers.
  set_unf. exists* L. introv Ex. applys EQ. applys~ HI.
Qed.

Lemma finite_remove : forall E F,
  finite E ->
  finite (E \- F).
Proof using.
  introv HE. apply finite_of_ex_list_covers.
  lets (L&EQ): finite_inv_list_covers HE. unfold list_covers. set_unf. exists* L.
Qed.

Section Finite_remove_inv.
Local Opaque remove_inst single_inst.

Lemma finite_remove_inv : forall E F,
  finite (E \- F) ->
  finite F ->
  finite E.
Proof using.
  introv H1 H2. lets (L1&R1): finite_inv_list_covers H1.
  lets (L2&R2): finite_inv_list_covers H2.
  applys finite_of_list_covers (L1 ++ L2).
  intros y Hy. rewrite~ mem_app_eq. tests: (y \in F).
    autos~.
    forwards~ M: R1 y. rewrite~ @in_remove_eq. typeclass.
Qed.

End Finite_remove_inv.

Lemma finite_remove_one_inv : forall E x,
  finite (E \-- x) ->
  finite E.
Proof using.
  introv H. applys finite_remove_inv H. applys finite_single.
Qed.

(* --LATER : finite_remove_inv
   finite (E \- F) -> finite F -> finite E
*)

(* The following lemma pushed here due to dependencies. *)

Lemma list_repr_nil:
  list_repr \{} (@nil A).
Proof using.
  rewrite <- to_list_empty.
  eapply eq_to_list_inv; eauto using finite_empty.
Qed.

(* ----------------------------------------------------------------------

    card *)

(* introduction of properties on card *)

Definition list_covers_inv_card : forall (E:set A) L,
  list_covers E L ->
  (card E <= length L)%nat.
Proof using.
  introv H. sets m: (card E). set_unf.
  forwards* (R&P): mmin_spec_nat m.
  simpls. applys P. exists L. splits~.
Qed.

Definition finite_inv_list_repr_and_card : forall (E:set A),
  finite E ->
  exists L, list_repr E L /\ card E = length L.
Proof.
  introv H. forwards (L1&HL1&EL1): finite_inv_list_covers_and_card H.
  sets L2: (remove_duplicates L1).
  forwards~ (ND&EQ&LE): remove_duplicates_spec L1 L2.
  sets L3: (filter (fun x => x \in E) L2).
  asserts: (length L3 <= length L2)%nat. applys length_filter.
  asserts R3: (list_repr E L3).
    split.
      applys~ noduplicates_filter.
      intros x. iff M.
        unfold L3 in M. lets~ (_&?): mem_filter_inv M.
        applys~ mem_filter. rewrite~ EQ.
  forwards C3: list_covers_of_list_repr R3.
  exists L3. splits*.
  forwards: list_covers_inv_card C3. math.
Qed.

Lemma list_repr_inv_card : forall (E:set A) (L:list A),
  list_repr E L ->
  card E = length L.
Proof using.
  introv HR. lets (ND&EQ): HR.
  forwards~ (L'&(ND'&HR')&EQ'): finite_inv_list_repr_and_card E.
    applys* finite_of_list_repr.
  unfold card. simpl. rewrite EQ'.
  applys~ noduplicates_length_eq.
  intros x. rewrite EQ. rewrite* HR'.
Qed.

Definition finite_inv_card_ge : forall (E:set A) n,
  finite E ->
  (forall L, list_covers E L -> (length L >= n)%nat) ->
  (card E >= n)%nat.
Proof using.
  introv H. sets m: (card E).
  forwards* (R&P): mmin_spec_nat m.
    lets (L&EL): finite_inv_list_covers H. exists~ (length L) L.
  simpls. introv HL. destruct R as (L&CR&ER).
  forwards~: HL L. math.
Qed.

Definition list_covers_inv_card_eq : forall (E:set A) L,
  list_covers E L ->
  (forall L', list_covers E L' -> (length L' >= length L)%nat) ->
  card E = length L.
Proof using.
  introv HC HG.
  forwards~: list_covers_inv_card HC.
  forwards~: finite_inv_card_ge HG.
    applys* finite_of_list_covers.
  math.
Qed.

Lemma card_eq_length_to_list : forall (E:set A),
  finite E ->
  card E = length (to_list E).
Proof using.
  introv FE. applys list_repr_inv_card. applys~ eq_to_list_inv.
Qed.

(* operations *)

Global Instance card_empty_inst : Card_empty (T:=set A).
Proof using.
  constructor. rewrite card_eq_length_to_list.
  lets E: to_list_empty. set_unf. rewrite E. rew_list~.
  applys finite_empty.
Qed.

Global Instance card_single_inst : Card_single (T:=set A).
Proof using.
  constructor. intros a. rewrite card_eq_length_to_list.
  lets E: to_list_single a. set_unf. rewrite E. rew_list~.
  applys finite_single.
Qed.

End Instances.

Hint Resolve finite_empty finite_single finite_union
  finite_inter finite_incl finite_remove : finite.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Tactics for proving set equalities and set inclusions *)

(** The tactic [set_prove] aims at proving set equality by testing
    double inclusion using a boolean tautology decision procedure. *)

(* lemmas *)

Section Autorewrite.
Variables (A : Type).
Implicit Types x y : A.
Implicit Types E F : set A.

Lemma set_in_empty_eq : forall x,
  x \in (\{}:set A) = False.
Proof using. apply in_empty_eq. Qed.

Lemma set_in_single_eq : forall x y,
  x \in (\{y}:set A) = (x = y).
Proof using. apply in_single_eq. Qed.

Lemma set_in_inter_eq : forall x E F,
  x \in (E \n F) = (x \in E /\ x \in F).
Proof using. apply in_inter_eq. Qed.

Lemma set_in_union_eq : forall x E F,
  x \in (E \u F) = (x \in E \/ x \in F).
Proof using. apply in_union_eq. Qed.

Lemma set_in_remove_eq : forall x E F,
  x \in (E \- F) = (x \in E /\ ~ x \in F).
Proof using. apply in_remove_eq. Qed.

Lemma set_in_extens_eq : forall E F,
  (E = F) = (forall x, x \in E <-> x \in F).
Proof using.
  extens. iff M.
  subst*.
  applys @in_extens_eq. typeclass. intros. extens*.
Qed.

Lemma set_incl_in_eq : forall E F,
  (E \c F) = (forall x, x \in E -> x \in F).
Proof using. apply incl_in_eq. Qed.

Lemma set_disjoint_eq : forall E F,
  (E \# F) = (forall x, x \in E -> x \in F -> False).
Proof using. apply disjoint_eq. Qed.

End Autorewrite.

Hint Rewrite in_set_st_eq set_in_empty_eq set_in_single_eq
  set_in_inter_eq set_in_union_eq set_in_remove_eq set_in_extens_eq
  set_incl_in_eq set_disjoint_eq : rew_set.

(* tactic *)

Ltac rew_set_tactic tt :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_set).

Ltac set_specialize_hyps A x :=
  repeat match goal with H: forall _:?A, _ |- _ =>
    specializes H x
  end.

Ltac set_specialize_classic x :=
  repeat match goal with E: set _ |- _ =>
    match goal with
    | H: x \in E \/ ~ x \in E |- _ => fail 1
    | _ => lets: (prop_inv (x \in E))
    end
  end.

Ltac set_specialize use_classic :=
  match goal with |- forall _:?A, _ =>
    let x := fresh "x" in intros x;
    set_specialize_hyps A x;
    match use_classic with
    | true => set_specialize_classic x
    | false => idtac
    end
  end.

Ltac set_prove_setup use_classic :=
  intros;
  rew_set_tactic tt;
  try set_specialize use_classic;
  rew_set_tactic tt.

Ltac set_prove_conclude :=
  solve [ intros; subst; tauto ].

Ltac set_prove :=
  set_prove_setup false; set_prove_conclude.

Ltac set_prove_classic :=
  set_prove_setup true; set_prove_conclude.

(* ********************************************************************** *)
(* ################################################################# *)
(** * More properties *)

(* ----------------------------------------------------------------------

    Card *)

Lemma card_le_of_incl : forall A (E F:set A),
  finite F ->
  E \c F ->
  (card E <= card F)%nat.
Proof using.
  introv FF CF. lets FE: finite_incl CF FF.
  lets (LF&RF&QF): finite_inv_list_covers_and_card FF.
  rewrite QF. applys list_covers_inv_card. introv Ex.
  applys RF. applys* @incl_inv. typeclass.
Qed.

Lemma card_union_le : forall A (E F:set A),
  finite E ->
  finite F ->
  card (E \u F) <= (card E + card F)%nat.
Proof using.
  introv FE FF.
  lets (LE&RE&QE): finite_inv_list_covers_and_card FE.
  lets (LF&RF&QF): finite_inv_list_covers_and_card FF.
  lets H: list_covers_inv_card (E \u F) (LE++LF) __.
    unfolds list_covers. intros. apply mem_app.
    rewrite in_union_eq in H. autos*.
  rew_list in H. math.
Qed.

Lemma card_disjoint_union : forall A (E F:set A),
  finite E ->
  finite F ->
  E \# F ->
  card (E \u F) = (card E + card F)%nat.
Proof using.
  introv FE FF EF.
  forwards: card_union_le FE FF.
  cuts: (card (E \u F) >= (card E + card F)%nat). math. clear H.
  forwards (L&LC&LL): finite_inv_list_covers_and_card (E \u F). applys~ finite_union.
  rewrite LL. clear LL.
  sets PE: (fun x => x \in E). sets LE: (filter PE L).
  sets PF: (fun x => x \in F). sets LF: (filter PF L).
  forwards: list_covers_inv_card E LE.
    unfold LE, PE. introv Ex. forwards: LC x. set_prove. applys~ mem_filter.
  forwards: list_covers_inv_card F LF.
    unfold LF, PF. introv Fx. forwards: LC x. set_prove. applys~ mem_filter.
  forwards LEF: filter_length_two_disjoint PE PF L.
    introv _ HEx HFx. unfolds PE, PF. applys* @disjoint_inv. typeclass.
  subst LE LF. math.
Qed.

Lemma card_inter_le_l : forall A (E F:set A),
  finite E ->
  card (E \n F) <= card E.
Proof using.
  intros. applys~ card_le_of_incl. set_prove.
Qed.

Lemma card_inter_le_r : forall A (E F:set A),
  finite F ->
  card (E \n F) <= card F.
Proof using.
  intros. rewrite inter_comm. apply~ card_inter_le_l.
Qed.

Lemma card_ge_one : forall A (E:set A) x,
  x \in E ->
  finite E ->
  1%nat <= card E.
Proof using.
  intros.
  rewrite <- (card_single x).
  applys~ card_le_of_incl.
  set_prove.
Qed.

(* -- LATER
Lemma card_nonempty : forall A (E:set A),
  E <> \{} ->
  finite E ->
  card E > 0.
Proof using.
Qed.
*)

Lemma card_disjoint_union_single : forall A (E:set A) x,
  finite E ->
  x \notin E ->
  (card (E \u \{x}) = card E + 1)%nat.
Proof using.
  intros.
  replace 1%nat with (card \{x}) by eauto using card_single.
  applys~ card_disjoint_union. applys finite_single.
  rewrite disjoint_single_r_eq. auto.
Qed.

Lemma card_diff_single : forall A (E:set A) x,
  finite E ->
  x \in E ->
  (card (E \-- x) = card E - 1)%nat.
Proof using.
  intros.
  assert (h1: (E \-- x) \u \{x} = E).
  { rewrite union_comm. erewrite eq_union_single_remove_one by eauto. reflexivity. }
  forwards h2: card_disjoint_union_single (E \-- x) x.
  { eauto with finite. }
  { unfold notin. rewrite set_in_remove_eq.
    rew_logic. right.
    eapply in_single_self. }
  rewrite h1 in h2.
  math.
Qed.

(* ----------------------------------------------------------------------

    fold *)

Lemma fold_eq_fold_to_list : forall A B (m:monoid_op B) (f:A->B) (E: set A),
  fold m f E = LibList.fold m f (to_list E).
Proof using. reflexivity. Qed.

Lemma fold_eq_fold_list_repr : forall A B (m:monoid_op B) (f:A->B) (E: set A) L,
  Comm_monoid m ->
  list_repr E L ->
  fold m f E = LibList.fold m f L.
Proof using.
  introv HM EL. rewrite fold_eq_fold_to_list.
  forwards~ (N&EQ2): eq_to_list_inv E. applys* finite_of_list_repr.
  destruct EL as (ND&EQ1).
  applys~ LibList.fold_equiv. intros. rewrite EQ2. rewrite* EQ1.
Qed.

Lemma fold_induction:
  forall A B (m : monoid_op B) (f : A -> B) (P : B -> Prop),
  Comm_monoid m ->
  P (monoid_neutral m) ->
  (forall x a, P x -> P (monoid_oper m (f a) x)) ->
  forall E,
  finite E ->
  P (fold m f E).
Proof using. (* --todo: cleanup proof *)
  introv Hm Hbase Hstep Hfinite.
  assert (forall xs, P (LibList.fold m f xs)).
  { induction xs; rew_listx; eauto. }
  forwards: list_repr_to_list_of_finite Hfinite.
  erewrite fold_eq_fold_list_repr by eauto.
  eauto.
Qed.

Lemma fold_congruence : forall A B (m:monoid_op B) (f g:A -> B) (E:set A),
  Comm_monoid m ->
  finite E ->
  (forall x, x \in E -> f x = g x) ->
  fold m f E = fold m g E.
Proof using. (* --todo: cleanup proof *)
  introv Hm HE h. do 2 rewrite fold_eq_fold_to_list.
  eapply LibList.fold_congruence. intros.
  eapply h. rewrite finite_eq_in_iff_mem_to_list in HE. rewrite* HE.
Qed.

Lemma fold_empty : forall A B (m:monoid_op B) (f:A->B),
  fold m f (\{}:set A) = monoid_neutral m.
Proof using.
  intros. rewrite fold_eq_fold_to_list.
  rewrite to_list_empty. rewrite~ LibList.fold_nil.
Qed.

Lemma fold_single : forall A B (m:monoid_op B) (f:A->B) (x:A),
  Monoid m ->
  fold m f \{x} = f x.
Proof using.
  intros. rewrite fold_eq_fold_to_list.
  rewrite to_list_single. rewrite~ fold_cons.
  rewrite fold_nil. rewrite~ monoid_neutral_r.
Qed.

Lemma fold_union : forall A B (m:monoid_op B) (f:A->B) (E F:set A),
  Comm_monoid m ->
  finite E ->
  finite F ->
  E \# F ->
  fold m f (E \u F) = monoid_oper m (fold m f E) (fold m f F).
Proof using.
  introv HM HE HF HD.
  rewrites (>> fold_eq_fold_to_list E).
  rewrites (>> fold_eq_fold_to_list F).
  hint list_repr_to_list_of_finite.
  forwards~ HR: list_repr_disjoint_union HD.
  rewrites~ (>> fold_eq_fold_list_repr HR).
  rewrite~ LibList.fold_app. typeclass.
Qed.

Lemma fold_isolate : forall A (E:set A) x,
  finite E ->
  x \in E ->
  forall B (m : monoid_op B),
  Comm_monoid m ->
  forall (f : A -> B),
  fold m f E = monoid_oper m (f x) (fold m f (E \- \{x})).
Proof using. (* --todo: cleanup proof *)
  intros.
  (* Separate [E] into the singleton [\{x}] union the rest. *)
  rewrite (eq_union_single_remove_one E x) at 1 by eauto.
  (* Note that [f x] is the result of folding [f] over the singleton [\{x}]. *)
  erewrite <- (fold_single f x) by typeclass.
  (* Conclude. *)
  eapply fold_union; eauto using remove_disjoint with finite.
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Structural properties *)

(** Rewriting tactics [rew_set] *)

Hint Rewrite in_set_st_eq : rew_set.

Tactic Notation "rew_set" :=
  autorewrite with rew_set.
Tactic Notation "rew_set" "in" hyp(H) :=
  autorewrite with rew_set in H.
Tactic Notation "rew_set" "in" "*" :=
  autorewrite with rew_set in *.

(* ********************************************************************** *)
(* ################################################################# *)
(** * MORE *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** TEMPORARY Foreach *)

(** -- TODO: these lemmas should be instead derived as typeclasses
       in a generic way, in LibContainer. *)

(** -- TODO: add a paragraphe of the definition:
             foreach P E = (forall x, x \in E -> P x) *)

Section ForeachProp.
Variables (A : Type).
Implicit Types P Q : A -> Prop.
Implicit Types E F : set A.

Lemma foreach_empty : forall P,
  @foreach A (set A) _ P \{}.
Proof using. intros_all. false. Qed.
(* --TODO: false* @in_empty. typeclass. *)

Lemma foreach_single : forall P X,
  P X ->
  @foreach A (set A) _ P (\{ X }).
Proof using. intros_all. rewrite in_single_eq in H0. subst*. Qed.

Lemma foreach_union : forall P E F,
  foreach P E ->
  foreach P F ->
  foreach P (E \u F).
Proof using. intros_all. destruct~ (in_union_inv H1). Qed.

Lemma foreach_union_inv : forall P E F,
  foreach P (E \u F) ->
  foreach P E /\ foreach P F.
Proof using.
  introv H. split; introv K.
  apply H. rewrite~ @in_union_eq. typeclass.
  apply H. rewrite~ @in_union_eq. typeclass.
Qed.

Lemma foreach_union_eq : forall P E F,
  foreach P (E \u F) = (foreach P E /\ foreach P F).
Proof using.
  intros. extens. iff.
  apply~ foreach_union_inv.
  intuition eauto using foreach_union.
Qed.

Lemma foreach_single_eq : forall P X,
  foreach P (\{X}:set A) = P X.
Proof using.
  intros. extens. iff.
  apply H. apply in_single_self.
  apply~ foreach_single.
Qed.

Lemma foreach_of_pred_incl: forall P Q E,
  foreach P E ->
  pred_incl P Q ->
  foreach Q E.
Proof using. introv H L K. apply~ L. Qed.

Lemma foreach_remove_of_foreach_all : forall P E F,
  foreach P E ->
  foreach P (E \- F).
Proof using. introv M H. applys M. rewrite in_remove_eq in H. autos*. Qed.

Lemma foreach_remove : forall P E F,
  (forall x, x \in E -> x \notin F -> P x) ->
  foreach P (E \- F).
Proof using. introv M Px. rewrite in_remove_eq in Px. applys* M. Qed.

Lemma notin_of_foreach_not : forall P x E,
  foreach P E ->
  ~ P x ->
  x \notin E.
Proof using. introv M N I. applys N. applys~ M. Qed.

End ForeachProp.

Hint Resolve foreach_empty foreach_single foreach_union.
Hint Rewrite foreach_union_eq foreach_single_eq : rew_foreach.

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

(* ----------------------------------------------------------------------

    FUTURE WORK *)

(* -- TODO

   map f E = \set{= f x | x in E }

   bij E F f g =
      forall x \in E, f x \in F
      forall y \in F, g x \in E
      forall x \in E, g (f x) = x
      forall y \in F, f (g y) = y

   F m i E = fold m j F
     when  bij E F f g
      and  forall x \in E,  i x = j (f x)
       or  forall y \in E,  j y = i (g y)
*)

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


Set Implicit Arguments.
Require Import LibTactics BigStep_Definitions.

Definition terminates t :=
  exists v, reds t v.

Definition returns_of t :=
  { v | reds t v }.

Lemma reds_deterministic : forall v v' t,
  reds t v -> reds t v' -> v = v'.
Proof.
  introv R1 R2. gen v'. induction R1; intros.
  inversions R2.
    auto.
    false_inv.
  inversions R2.
    false_inv.
    lets E: IHR1_1 H1. inversions E.
    lets E: IHR1_2 H2. inversions E.
    lets E: IHR1_3 H4. inversions E.
    auto.
Defined.

Lemma terminates_bvar_not : forall i,
  ~ terminates (trm_bvar i).
Proof.
  introv H. inversions H. inversions H0. false_inv.
Defined.

Lemma terminates_fvar_not : forall x,
  ~ terminates (trm_fvar x).
Proof.
  introv H. inversions H. inversions H0. false_inv.
Defined.

Lemma terminates_abs : forall t,
  terminates (trm_abs t) ->
  reds (trm_abs t) (trm_abs t).
Proof.
  introv H. inversions H. inversions H0. apply~ reds_val.
Defined.

Lemma terminates_app_1 : forall t2 t1,
  terminates (trm_app t1 t2) ->
  terminates t1.
Proof.
  introv [v H]. inversions H. false_inv. exists_*.
Defined.

Lemma terminates_app_2 : forall t1 t2,
  terminates (trm_app t1 t2) ->
  terminates t2.
Proof.
  introv [v H]. inversions H. false_inv. exists_*.
Defined.

Lemma terminates_app_3 : forall t3 v2 t1 t2,
  terminates (trm_app t1 t2) ->
  reds t1 (trm_abs t3) ->
  reds t2 v2 ->
  terminates (t3 ^^ v2).
Proof.
  introv [v H] R1' R2'. inverts H as R1 R2 R3.
  false_inv.
  lets E: (reds_deterministic R1' R1). inversions E.
  lets E: (reds_deterministic R2 R2'). inversions E.
  exists_*.
Defined.

Lemma terminates_app_bvar_not : forall t1 t2 i,
  terminates (trm_app t1 t2) ->
  reds t1 (trm_bvar i) -> False.
Proof.
  introv [v T] R. inversions T.
  inversions R; false_inv.
  lets E: (reds_deterministic R H1). inversions E.
Defined.

Lemma terminates_app_fvar_not : forall t1 t2 x,
  terminates (trm_app t1 t2) ->
  reds t1 (trm_fvar x) -> False.
Proof.
  introv [v T] R. inversions T.
  inversions R; false_inv.
  lets E: (reds_deterministic R H1). inversions E.
Defined.

Lemma terminates_app_app_not : forall t1 t2 v1 v2,
  terminates (trm_app t1 t2) ->
  reds t1 (trm_app v1 v2) -> False.
Proof.
  introv [v T] R. inversions T.
  inversions R; false_inv.
  lets E: (reds_deterministic R H1). inversions E.
Defined.

Inductive ends (t:trm) : Prop :=
  | ends_intro :
     (forall t1 t2, t = trm_app t1 t2 -> ends t1) ->
     (forall t1 t2, t = trm_app t1 t2 -> ends t2) ->
     (forall t1 t2 t3 v2, t = trm_app t1 t2 ->
        reds t1 (trm_abs t3) ->
        reds t2 v2 ->
        ends (t3 ^^ v2)) ->
     ends t.

Lemma terminates_ends : forall t,
  terminates t -> ends t.
Proof.
  introv [v H]. induction H.
  inversions H. constructor; introv Eq; inversions Eq.
  constructor; introv Eq; inversions Eq.
  auto.
  auto.
  introv R2 R3.
  lets E: (reds_deterministic R2 H). inversions E.
  lets E: (reds_deterministic R3 H0). inversions E.
  auto.
Defined.

Definition eval_core :
  forall (t:trm) (H:terminates t), (returns_of t).
Proof.
introv H.
lets H': (terminates_ends H). gen H.
induction H' as [t H1 IH1 H2 IH2 H3 IH3].
introv H. destruct t.
false* terminates_bvar_not.
false* terminates_fvar_not.
constructors. apply~ terminates_abs.
destruct~ (IH1 t1 t2) as [v1 R1]. apply* terminates_app_1.
destruct~ (IH2 t1 t2) as [v2 R2]. apply* terminates_app_2.
destruct v1.
  false* terminates_app_bvar_not.
  false* terminates_app_fvar_not.
  destruct~ (IH3 t1 t2 v1 v2) as [v3 R3].
   apply* terminates_app_3.
   constructors. apply* reds_red.
    false* terminates_app_app_not.
Defined.

Print eval_core.

Definition eval (t:trm) (H:terminates t) :=
  proj1_sig (eval_core H).

Require Import Metatheory.

Hint Constructors term.

Definition test :=
  trm_app (trm_abs (trm_bvar 0)) (trm_abs (trm_bvar 0)).

Lemma terminates_test : terminates test.
Proof.
  exists (trm_abs (trm_bvar 0)).
  unfold test.
  constructors.
  apply reds_val. apply value_abs. apply (@term_abs {}).
   intros. unfold open. simple~.
  apply reds_val. apply value_abs. apply (@term_abs {}).
   intros. unfold open. simple~.
  unfold open. simpl. apply reds_val.
  apply value_abs. apply (@term_abs {}).
   intros. unfold open. simple~.
Defined.

Eval compute in (eval terminates_test).
(* It works !! *)

Notation "'returns' t" := (exist _ t _) (at level 67).

Program Fixpoint Eval
  (t:trm) (H:ends t) {struct H} : (terminates t -> returns_of t) :=
  fun T => match t with
  | trm_app t1 t2 =>
     let (t1',H1) := @Eval t1 _ _ in
     let (t2',H2) := @Eval t2 _ _ in
     match t1' with
     | trm_abs t3 =>
         let (t',H3) := @Eval (t3 ^^ t2') _ _ in
         returns t'
     | _ => returns (trm_app t1' t2')
     end
  | _ => returns t
  end.
Next Obligation.
apply terminates_ends. apply* terminates_app_1.
Defined.
Next Obligation.
apply* terminates_app_1.
Defined.
Next Obligation.
apply terminates_ends. apply* terminates_app_2.
Defined.
Next Obligation.
apply* terminates_app_2.
Defined.
Next Obligation.
apply terminates_ends. apply* terminates_app_3.
Defined.
Next Obligation.
apply* terminates_app_3.
Defined.
Next Obligation.
apply* reds_red.
Defined.
Next Obligation.
destruct t1'.
false* terminates_app_bvar_not.
false* terminates_app_fvar_not.
false*.
false* terminates_app_app_not.
Defined.
Next Obligation.
destruct t.
false* terminates_bvar_not.
false* terminates_fvar_not.
apply* terminates_abs.
false*.
Defined.

(*
Error:
Recursive definition of Eval is ill-formed.
In environment
Eval : forall t : trm, ends t -> terminates t -> returns_of t
t : trm
H : ends t
T : terminates t
t1 : trm
t2 : trm
Heq_t : trm_app t1 t2 = t
Recursive call to Eval has principal argument equal to
"Eval_obligation_1 H T Heq_t"
instead of a subterm of H.
*)

(*  let eval t' := @Eval t' _ _ in
  puis appeler "eval t1" ça ne marche pas .. *)

Proof.
introv H.
lets H': (terminates_ends H). gen H.
induction H' as [t H0 H1 IH1 H2 IH2 H3 IH3].
introv H. destruct t.
false* terminates_bvar_not.
false* terminates_fvar_not.
constructors. apply~ terminates_abs.
destruct~ (IH1 t1 t2) as [v1 R1]. apply* terminates_app_1.
destruct~ (IH2 t1 t2) as [v2 R2]. apply* terminates_app_2.
destruct v1.
  false* terminates_app_bvar_not.
  false* terminates_app_fvar_not.
  destruct~ (IH3 t1 t2 v1 v2) as [v3 R3].
   apply* terminates_app_3.
   constructors. apply* reds_red.
    false* terminates_app_app_not.
Defined.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.

Require Import LensLaws.Isomorphism.
Require Import LensLaws.These.
Require Import LensLaws.Crush.

Definition Achroma (A B : Set) : Type := { X : Set & Iso A (option X * B) }.

Lemma achroma_compose {A B C} (ab : Achroma A B) (bc : Achroma B C) : Achroma A C.
Proof.
  intros.
  destruct ab as [X ab]. destruct ab as [axb xba H H0].
  destruct bc as [Y bc]. destruct bc as [byc ycb H1 H2].

  exists (these X Y).

  set (FWD := fun (a : A) => match axb a with
    | pair ox b => match byc b with
      | pair oy c => pair (toThese ox oy) c
      end
    end).

  set (BWD := fun (z : option (these X Y) * C) => match z with
    | pair None               c => xba (pair None     (ycb (pair None c)))
    | pair (Some (This x))    c => xba (pair (Some x) (ycb (pair None c)))
    | pair (Some (That y))    c => xba (pair None     (ycb (pair (Some y) c)))
    | pair (Some (These x y)) c => xba (pair (Some x) (ycb (pair (Some y) c)))
    end).

  apply (MkIso FWD BWD); subst FWD; subst BWD.
  + crush.
  + unfold toThese; crush. Qed.

Definition achroma_select {A B} (achroma : Achroma A B) (a : A) : B.
Proof.
  destruct achroma as [X iso].
  destruct iso.
  exact (snd (f a)). Defined.

Definition achroma_upsert {A B} (achroma : Achroma A B) (oa : option A) (obb : option B -> B) : A.
Proof.
  destruct achroma as [X iso].
  destruct iso as [f g _ _ ].
  refine (match oa with
    | None   => g (pair None (obb None))
    | Some a => _
    end).

  refine (let (ox, b) := (f a) in g (pair ox (obb (Some b)))). Defined.

Definition achroma_insert {A B} (achroma : Achroma A B) (b : B) : A.
Proof.
  destruct achroma as [X iso].
  destruct iso as [f g _ _ ].
  exact (g (pair None b)). Defined.

Definition achroma_update {A B} (achroma : Achroma A B) (a : A) (b : B) : A.
Proof.
  destruct achroma as [X iso].
  destruct iso as [f g _ _ ].
  refine (match f a with
    | pair ox _ => g (pair ox b)
    end). Defined.

Theorem achroma_law1 {A B} (achroma : Achroma A B) :
  forall a b, achroma_select achroma (achroma_update achroma a b) = b.
Proof.
  intros a b. destruct achroma as [X ab]. destruct ab as [axb xba H H0]. crush. Qed.

Theorem achroma_law2 {A B} (achroma : Achroma A B) :
  forall a, achroma_update achroma a (achroma_select achroma a) = a.
Proof.
  intros a. destruct achroma as [X ab]. destruct ab as [axb xba H H0]. crush. Qed.

Theorem achroma_law3 {A B} (achroma : Achroma A B) :
  forall a b b', achroma_update achroma (achroma_update achroma a b') b = achroma_update achroma a b.
Proof.
  intros a b b'. destruct achroma as [X ab]. destruct ab as [axb xba H H0]. crush. Qed.

Theorem achroma_law4 {A B} (achroma : Achroma A B) :
  forall b, achroma_select achroma (achroma_insert achroma b) = b.
Proof.
  intros b. destruct achroma as [X ab]. destruct ab as [axb xba H H0]. crush. Qed.

Definition Dec (P : Prop) : Set := {P} + {~P}.

Theorem achroma_law5 {A B} (achroma : Achroma A B) :
  forall b b', achroma_update achroma (achroma_insert achroma b) b' = achroma_insert achroma b'.
Proof.
  intros b b'. destruct achroma as [X ab]. destruct ab as [axb xba H H0]. crush. Qed.

Theorem achroma_extra {A B} (achroma : Achroma A B) (a : A) :
  Dec (achroma_update achroma a = achroma_insert achroma).
Proof.
  destruct achroma as [X ab]. destruct ab as [axb xba H H0].
  remember (axb a) as z.
  destruct z as [ox b].
  unfold achroma_update. unfold achroma_insert.
  destruct ox as [x |].
  - right.
    unfold not. intros.
    assert (Haux : forall (f g : B -> A) (b : B), f = g -> f b = g b).
    intros f g b' R. rewrite R. trivial.
    apply Haux with (b := b) in H1.
    rewrite <- Heqz in H1.
    assert (Haux' : axb (xba (Some x, b)) = axb (xba (None, b))).
    rewrite H1. trivial.
    repeat (rewrite <- H0 in Haux').
    inversion Haux'.
  - left. rewrite <- Heqz. trivial. Defined.

(* We essentially prove that law variants are equivalent, given other laws *)
Theorem achroma_pristine_alt {A B} (achroma : Achroma A B) (a : A) :
  Dec (a = achroma_insert achroma (achroma_select achroma a)).
Proof.
  destruct (achroma_extra achroma a).
  - left.
    rewrite <- (achroma_law2 achroma) at 1. rewrite e.
    reflexivity.
  - right.
    unfold not in *. intros H1. apply n.
    rewrite H1.
    extensionality b.
    apply (achroma_law5 achroma). Qed.

Module Completeness.
  Parameter A : Set.
  Parameter B : Set.
  Parameter insert : B -> A.
  Parameter update : A -> B -> A.

  Parameter select : A -> B.

  Parameter law1 : forall a b, select (update a b) = b.
  Parameter law2 : forall a, update a (select a) = a.
  Parameter law3 : forall a b b', update (update a b') b = update a b.
  Parameter law4 : forall b, select (insert b) = b.
  Parameter law5 : forall b b', update (insert b) b' = insert b'.

  Parameter extra : forall a, Dec (update a = insert).

  Definition X : Set := {ba : B -> A | exists (a : A), ba = update a /\ update a <> insert }.

(*
  Inductive sigma (a : A) : Set := mksigma :
    forall (b : B), Dec (a = insert b) -> b = select a -> sigma a.

  Definition select'' (a : A) : sigma a.
  Proof.
    remember (select' a) as b. destruct b as [b proof].
    exists b. apply proof. unfold select. rewrite <- Heqb. exact eq_refl. Defined.
*)

  Definition FWD (a : A) : option X * B.
  Proof.
    destruct (extra a) as [_ | H].
    - refine (None, select a).
    - refine (Some _, select a).
      exists (update a). exists a. split.
      + exact (eq_refl).
      + exact H. Defined.

  Definition BWD (p : option X * B) : A.
  Proof.
    destruct p as [ox b]. destruct ox as [| x].
    - destruct x as [ba _]. exact (ba b).
    - exact (insert b). Defined.

  Theorem achroma_compete : Achroma A B.
  Proof.
    exists X.
    apply (MkIso FWD BWD); unfold FWD; unfold BWD; unfold X.

    - intros a. destruct (extra a) as [E | E].
      + rewrite <- E. symmetry. apply law2.
      + symmetry. apply law2.

    - intros p. destruct p as [ox b]. destruct ox as [x |].
      + destruct x as [ba proof].
        destruct proof as [a proof].
        destruct proof as [H H'].
        destruct (extra (ba b)) as [E | E].
        * exfalso.
          apply H'. rewrite <- E. rewrite -> H. extensionality b'. symmetry. apply law3.
        * f_equal. f_equal. subst ba.
          assert (update a = update (update a b)).
          extensionality b'. symmetry. apply law3.
          apply sigma_eq with (eqp := H).
          apply proof_irrelevance. subst ba. symmetry. apply law1.
      + destruct (extra (insert b)) as [_ | E].
        * f_equal. symmetry. apply law4.
        * exfalso. apply E. extensionality b'. apply law5. Qed.
End Completeness.


(* Fig.1(a) of COMPSAC'17 paper *)

Require Import refine.
Require Import parser.

Definition binS1: IA := parse
"IA [s1,s2,s3,s4] (s1) [h] [a,b] []
[s1->(h)s2, s2->(b)s4, s1->(b)s4, s1->(a)s3]".

Definition binS1_rep_l: IA :=
  IAutomaton.replacement binS1 (&"tau") (ASet.GenActs [&"h"]).

Definition binS1_hid_l: IA :=
  IAutomaton.hiding binS1 (ASet.GenActs [&"h"]).

Definition binS1_res_l: IA :=
  IAutomaton.restriction binS1 (ASet.GenActs [&"h"]).

Eval compute in :> binS1_rep_l.
Eval compute in :> binS1_hid_l.
Eval compute in :> binS1_res_l.

(* SIR-GNNI: true *)
Eval compute in (SIRGNNI_refinement binS1_res_l binS1_hid_l).

(* SME-NI: true *)
Eval compute in (SMENI_refinement binS1_rep_l binS1_hid_l).


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

  purpose   : Vector implmented with Recursive Pair
  author    : ZhengPu Shi
  date      : 2021.01

  remark    :
  1. the definition of vec inspired by Coquelicot.
  2. all definitions are polymorphism.

*)

Require Import Lia.
Require Import List.

Require Export VectorThySig.

Open Scope vec_scope.

(** ** Definition of vector *)
Section vec.

  Variable T : Type.

  Fixpoint vec (n : nat) : Type :=
    match n with
    | O => unit
    | S n => prod T (vec n)
    end.

  (** all vec 0 are same *)
  Lemma vec_0 (v : vec 0) : v = tt.
  Proof. destruct v. auto. Qed.

(*   (** vec 1 must be one element *)
  Lemma vec_1 : forall (v : vec 1), {a | v = (a,tt)}.
  Proof. intros. destruct v,v. exists t. auto. Qed. *)

  (** vec (S n) must be a prod type *)
  Lemma vec_S (n : nat) (v : vec (S n)) : {x & { v' | v = (x, v')}}.
  Proof. refine (match v with (x,v') => _ end). eauto. Qed.

  (** Convert between "T * vec n" and "vec (S n)", just type conversion *)
  Lemma vec_eq_pair : forall {n} a (v : vec n),
    ((a,v) : T * (vec n)) = ((a,v) : vec (S n)).
  Proof. intros; auto. Qed.

End vec.

Arguments vec {T}.
Arguments vec_0 {T}.
Arguments vec_S {T}.

Bind Scope vec_scope with vec.

(** ** Notations for vec *)
Notation "[ x ]" := (prod x (vec 0)) : vec_scope.
Notation "[ x1 ; .. ; xn ]" := (pair x1 .. (pair xn tt) .. ) : vec_scope.

(** ** Equality of vec *)
Section vec_eq.

  Variable T : Type.
  Variable Teqb : T -> T -> bool.
  Variable Teq_dec : forall (x y : T), {x = y} + {x <> y}.

  (** Equality of vec *)
  Fixpoint vec_eqb {n : nat} : vec n -> vec n -> bool :=
    match n with
    | O => fun (v1 v2 : vec 0) => true
    | S n' => fun (v1 v2 : vec (S n')) =>
      andb (Teqb (fst v1) (fst v2)) (vec_eqb (snd v1) (snd v2))
    end.

  (** Decidable equality on vector *)
  Lemma vec_eq_dec {n} (v1 v2 : @vec T n) : {v1 = v2} + {v1 <> v2}.
  Proof.
    induction n.
    - rewrite (vec_0 v1);rewrite (vec_0 v2). left. auto.
    - destruct v1,v2. destruct (IHn v v0), (Teq_dec t t0); subst; auto;
      try right; intros H; inversion H; auto.
  Qed.

End vec_eq.

(** ** Construct a vector with same element *)
Section vrepeat.

  Variable T : Type.

  Fixpoint vrepeat (n : nat) (val : T) : vec n := match n with
  | O => tt
  | S n' => (val, vrepeat n' val)
  end.

  Lemma vrepeat_0 a : vrepeat 0 a = tt.
  Proof. compute. auto. Qed.

  Lemma vrepeat_S r a : vrepeat (S r) a = (a, vrepeat r a).
  Proof. induction r; simpl; auto. Qed.

End vrepeat.

Arguments vrepeat {T}.

(** ** vec0, its elements is 0 *)
Section vec0.

  Variable T : Type.
  Variable T0 : T.

  Definition vec0 (n : nat) := vrepeat n T0.

  Lemma vec0_S : forall n, vec0 (S n) = (T0, vec0 n).
  Proof. intros. auto. Qed.

  Lemma vec0_eq_vrepeat0 : forall n, vec0 n = vrepeat n T0.
  Proof. auto. Qed.

End vec0.

Arguments vec0 {T}.

(** ** Get head element *)
Section vhead.

  Variable T : Type.
  Variable T0 : T.

  Definition vhd {n} : vec n -> T := match n with
  | O => fun (_ : vec O) => T0
  | S n' => fun (v : vec (S n')) => fst v
  end.

End vhead.

Arguments vhd {T} T0 {n}.

(** ** Get tail vector *)
Section vtail.

  Variable T : Type.

  Definition vtl {n} (v : @vec T (S n)) : vec n := snd v.

End vtail.

Arguments vtl {T n}.

(** ** Get last element *)
Section vlast.

  Variable T : Type.
  Variable T0 : T.

  (* why fail? *)
  Fail Fixpoint vlast (n : nat) : vec n -> T := match n with
  | O => fun (_ : vec O) => T0
  | 1 => fun (v : vec 1) => fst v
  | S n' => fun (v : vec (S n')) => vlast n' (snd v)
  end.

  Fixpoint vlast {n} : vec (S n) -> T := match n with
  | O => fun (v : vec 1) => fst v
  | S n' => fun (v : vec (S (S n'))) => vlast (snd v)
  end.

End vlast.

Arguments vlast {T n}.

(** Construct a vector with a function *)
Section vmake.

  Variable T : Type.
  Variable T0 : T.

  (* it is wrong direction, we need (f 0, f 1 ..), but got (f n, f (n-1) ..) *)
  Fixpoint vmake_old (n : nat) (f : nat  -> T) : vec n := match n with
  | O => tt
  | S n' => (f n', vmake_old n' f)
  end.

  Fixpoint vmake_aux (n : nat) (i : nat) (f : nat  -> T) : vec n
    := match n with
  | O => tt
  | S n' => (f i, vmake_aux n' (S i) f)
  end.

  Lemma vmake_aux_S (n : nat) (i : nat) (f : nat  -> T) :
    vmake_aux n (S i) f = vmake_aux n i (fun j => f (S j)).
  Proof.
    generalize dependent f.
    generalize dependent i.
    induction n.
    - simpl. auto.
    - simpl. intros. f_equal. rewrite IHn. f_equal.
  Qed.

  Lemma vmake_aux_zero_eq_vec0 : forall n,
    (vmake_aux n 0 (fun _ => T0)) = vec0 T0 n.
  Proof.
    induction n; simpl; auto. rewrite vmake_aux_S. f_equal; auto.
  Qed.

  Definition vmake (n : nat) (f : nat  -> T) : vec n := vmake_aux n 0 f.

  Lemma vmake_0 (f : nat  -> T) : vmake 0 f = tt.
  Proof. auto. Qed.

  Lemma vmake_S n (f : nat  -> T) :
    vmake (S n) f = (f 0%nat, vmake n (fun i => f (S i))).
  Proof.
    unfold vmake. destruct n; simpl; auto.
    f_equal. f_equal. apply vmake_aux_S.
  Qed.

  Lemma vmake_zero_eq_vec0 : forall n, (vmake n (fun _ => T0)) = vec0 T0 n.
  Proof.
    unfold vmake. apply vmake_aux_zero_eq_vec0.
  Qed.

End vmake.

Arguments vmake_aux {T}.
Arguments vmake_aux_S {T}.
Arguments vmake_aux_zero_eq_vec0 {T}.
Arguments vmake_old {T}.
Arguments vmake {T}.
Arguments vmake_0 {T}.
Arguments vmake_S {T}.
Arguments vmake_zero_eq_vec0 {T}.

(** ** Append two vectors *)
Section vapp.

  Variable T : Type.

  Fixpoint vapp {n1 n2} : @vec T n1 -> vec n2 -> vec (n1 + n2) :=
    match n1 with
    | 0 => fun (v1 : vec 0) (v2 : vec n2) => v2
    | S n1' => fun (v1 : vec (S n1')) (v2 : vec n2) =>
      (fst v1, vapp (snd v1) v2)
    end.

End vapp.

Arguments vapp {T n1 n2}.

(** Reverse a vector *)
Section vrev.

  Variable T : Type.

  Fail Fixpoint vrev {n : nat} : @vec T n -> @vec T n :=
    match n with
    | O => fun _ => let v : @vec T 0 := tt in v
    | S n' => fun (v : @vec T (S n')) => let (x, v') := v in
      @vapp T n' 1 (vrev v') [x]
    end.

End vrev.

(** Get n-th element of a vector *)
Section vnth.

  Variable T : Type.
  Variable T0 : T.

  Fixpoint vnth {n} (i : nat) : (vec n) -> T := match n with
  | O => fun (_ : vec O) => T0
  | S n' => fun (v : vec (S n')) => match i with
     | O => (fst v)
     | S i' => vnth i' (snd v)
     end
  end.

  Lemma vnth_0 {n} (v : vec (S n)) : vnth 0 v = fst v.
  Proof. destruct v. simpl. auto. Qed.

  Lemma vnth_S {n} i (v : vec (S n)) :
    vnth (S i) v = vnth i (snd v).
  Proof. destruct v. simpl. auto. Qed.

  (** Every element pair of two vectors are same iff the two vectors same *)
  Lemma vnth_iff : forall {n} (v1 v2 : vec n),
    v1 = v2 <-> (forall i, vnth i v1 = vnth i v2).
  Proof.
    split.
    - intros. subst. auto.
    - intros; destruct n; destruct v1,v2; auto. f_equal.
      + apply (H 0%nat).
      + Abort.  (* I cannot prove it  *)

  Lemma v0_nth : forall n i, vnth i (vec0 T0 n) = T0.
  Proof. induction n; intros; auto. destruct i; simpl; auto. Qed.

  Lemma vnth_vmake_invalid : forall {n} f i, i >= n -> vnth i (vmake n f) = T0.
  Proof.
    induction n; intros; simpl; auto. unfold vmake in *.
    Abort.

  Lemma vnth_vmake_valid : forall {n} f i, i < n -> vnth i (vmake n f) = f i.
  Proof.
    induction n; intros. lia.
    simpl. unfold vmake in *. destruct i; auto.
    rewrite vmake_aux_S. rewrite IHn; auto. lia.
  Qed.

End vnth.

Arguments vnth {T} T0 {n}.

(** ** Get top k element of a vector *)
Section vfirstn.

  Variable T : Type.
  Variable T0 : T.

  Fixpoint vfirstn {n} (k : nat) : (vec n) -> (vec k) :=
    match n,k with
    | O, O => fun (v : vec O) => tt
    | O, S k' => fun (v : vec O) => (T0, vfirstn k' v)
    | S n', O => fun (v : vec (S n')) => tt
    | S n', S k' => fun (v : vec (S n')) => (fst v, vfirstn k' (snd v))
    end.

End vfirstn.

Arguments vfirstn {T} T0 {n}.

(** Get remain (n-k) elements of a vector *)
Section vskipn.

  Variable T : Type.

  Fixpoint vskipn {n} (k : nat) : @vec T n -> vec (n-k) :=
    match n,k with
    | O, O => fun (v : vec 0) => let v1 : vec (0-0) := tt in v1
    | O, S k' => fun (v : vec O) => let v1 : vec (0 - (S k')) := tt in v1
    | S n', O => fun (v : vec (S n')) => let v1 : vec (S n' - 0) := v in v1
    | S n', S k' => fun (v : vec (S n')) => let v1 : vec (S n' - S k') :=
      vskipn k' (snd v) in v1
    end.

End vskipn.

Arguments vskipn {T n}.

(** ** Maping a vector to another *)
Section vmap.

  Variable T : Type.
  Variable f : T -> T.

  Fixpoint vmap {n} : vec n -> vec n :=
    match n with
    | O => fun (v : vec 0) => tt
    | S n' => fun (v : vec (S n')) => (f (fst v), vmap (snd v))
    end.

End vmap.

Arguments vmap {T} f {n}.

Section vmap_props.

  Variable T : Type.
  Variable f g : T -> T.
  Variable Hfg : forall x, f x = g x.

  Lemma vmap_eq : forall {n} (v : vec n), vmap f v = vmap g v.
  Proof.
    induction n; intros; simpl; auto. f_equal; auto.
  Qed.

End vmap_props.

Section vmap_props2.

  Variable T : Type.
  Variable fmul : T -> T -> T.
  Variable fmul_comm : forall a b, fmul a b = fmul b a.
  Variable fmul_assoc : forall a b c, fmul (fmul a b) c = fmul a (fmul b c).

  Lemma vmap_assoc1 : forall {n} a b m,
    vmap (fun x : T => fmul a x) (@vmap T (fun x : T => fmul b x) n m) =
    vmap (fun x => fmul (fmul a b) x) m.
  Proof.
    induction n; intros; simpl; auto. f_equal; auto.
  Qed.

  Lemma vmap_assoc2 : forall {n} a b m,
    vmap (fun x : T => fmul a x) (@vmap T (fun x : T => fmul b x) n m) =
    vmap (fun x : T => fmul b x) (@vmap T (fun x : T => fmul a x) n m).
  Proof.
    induction n; intros; simpl; auto. f_equal; auto.
    repeat rewrite <- fmul_assoc. f_equal. auto.
  Qed.

End vmap_props2.

(** Mapping two vectors to another vector *)
Section vmap2.

  Variable T : Type.
  Variable f : T -> T  -> T.
  Variable f_comm : forall a b, f a b = f b a.
  Variable f_assoc : forall a b c, f (f a b) c = f a (f b c).

  Fixpoint vmap2 {n} : vec n -> vec n -> vec n :=
    match n with
    | O => fun (v1 : vec 0) (v2 : vec 0) => tt
    | S n' => fun (v1 : vec (S n')) (v2 : vec (S n')) =>
      (f (fst v1) (fst v2), vmap2 (snd v1) (snd v2))
    end.

  Lemma vmap2_S : forall {n} t1 t2 (v1 v2 : vec n),
    vmap2 ((t1, v1):vec (S n)) (t2, v2) = (f t1 t2, vmap2 v1 v2).
  Proof. induction n; intros; destruct v1,v2; simpl; auto. Qed.

  Lemma vmap2_comm {n} (v1 v2 : vec n): vmap2 v1 v2 = vmap2 v2 v1.
  Proof.
    induction n; intros; destruct v1,v2; auto. simpl. f_equal; auto.
  Qed.

  Lemma vmap2_assoc {n} (v1 v2 v3 : vec n) :
    vmap2 (vmap2 v1 v2) v3 = vmap2 v1 (vmap2 v2 v3).
  Proof.
    induction n; intros; destruct v1,v2; auto. simpl. f_equal; auto.
  Qed.

End vmap2.

Arguments vmap2 {T} f {n}.

(** ** Vector addition *)
Section vadd.

  Variable T : Type.
  Variable T0 : T.
  Variable fadd : T -> T -> T.
  Variable fadd_comm : forall a b, fadd a b = fadd b a.
  Variable fadd_assoc : forall a b c, fadd (fadd a b) c = fadd a (fadd b c).
  Variable fadd_0_l : forall t, fadd T0 t = t.
  Variable fmul : T -> T -> T.
  Variable fmul_add_distr_l : forall a b1 b2,
    fmul a (fadd b1 b2) = fadd (fmul a b1) (fmul a b2).
  Variable fmul_add_distr_r : forall a1 a2 b,
    fmul (fadd a1 a2) b = fadd (fmul a1 b) (fmul a2 b).

  Definition vadd {n} (v1 v2 : vec n) : vec n := vmap2 fadd v1 v2.

  Lemma vadd_comm {n} (v1 v2 : vec n): vadd v1 v2 = vadd v2 v1.
  Proof. unfold vadd. apply vmap2_comm. auto. Qed.

  Lemma vadd_assoc {n} (v1 v2 v3 : vec n):
    vadd (vadd v1 v2) v3 = vadd v1 (vadd v2 v3).
  Proof. unfold vadd. apply vmap2_assoc. auto. Qed.

  Lemma vadd_S : forall {n} t1 t2 (v1 v2 : vec n),
    vadd ((t1, v1) : vec (S n)) (t2, v2) = (fadd t1 t2, vadd v1 v2).
  Proof. intros. apply vmap2_S. Qed.

  Lemma vadd_0_l : forall {n} (v : vec n), vadd (vec0 T0 n) v = v.
  Proof.
    induction n; intros; destruct v;auto. rewrite vec0_S. rewrite vadd_S.
    f_equal. auto. auto.
  Qed.

  Lemma vadd_0_r : forall {n} (v : vec n), vadd v (vec0 T0 n) = v.
  Proof. intros. rewrite vadd_comm. apply vadd_0_l. Qed.

  Lemma vmap_vadd_distr_l : forall {n} a (v1 v2 : vec n),
    vmap (fun x : T => fmul a x) (vadd v1 v2) =
    vadd (vmap (fun x : T => fmul a x) v1) (vmap (fun x : T => fmul a x) v2).
  Proof.
    induction n; intros; simpl; auto. f_equal; auto.
  Qed.

  Lemma vmap_vadd_distr_r : forall {n} a b (v : vec n),
    vmap (fun x : T => fmul (fadd a b) x) v =
    vadd (vmap (fun x : T => fmul a x) v) (vmap (fun x : T => fmul b x) v).
  Proof.
    induction n; intros; simpl; auto. f_equal; auto.
  Qed.

End vadd.

Arguments vadd {T} fadd {n}.

(** ** Vector substraction *)
Section vsub.

  Variable T : Type.
  Variable T0 : T.
  Variable fopp : T -> T.
(*   Variable fadd fsub : T -> T -> T. *)
  Variable fadd : T -> T -> T.
  Infix "+" := fadd.
  Notation "- x" := (fopp x).
  Notation "a - b" := (a + (-b)).

  Variable fopp_opp : forall a, - (- a) = a.
  Variable fadd_comm : forall a b, a + b = b + a.
  Variable fadd_assoc : forall a b c, (a + b) + c = a + (b + c).
  Variable fadd_0_l : forall t, T0 + t = t.
  Variable fadd_0_r : forall t, t + T0 = t.
  Variable fadd_opp : forall a, a + (-a) = T0.
  Variable fopp_add_dist : forall a b, -(a+b) = -a + -b.
  Variable fopp_0 : - T0 = T0.

  Definition vopp {n} (v : vec n) : vec n := vmap fopp v.

  Lemma vopp_S : forall {n} a (v : vec n),
    vopp ((a, v) : vec (S n)) = (fopp a, vopp v).
  Proof.
    induction n; auto.
  Qed.

  Lemma vopp_vopp : forall {n} (v : vec n), vopp (vopp v) = v.
  Proof.
    induction n; intros; destruct v; simpl; auto. f_equal; auto.
  Qed.

  Definition vsub {n} (v1 v2 : vec n) : vec n :=
    vadd fadd v1 (vopp v2).
(*     vmap2 fsub v1 v2. *)

  Lemma vsub_comm : forall {n} (v1 v2 : vec n), vsub v1 v2 = vopp (vsub v2 v1).
  Proof.
    unfold vsub.
    induction n; intros; simpl; auto. f_equal; auto.
    rewrite fopp_add_dist. rewrite fopp_opp. auto.
  Qed.

  Lemma vsub_assoc {n} (v1 v2 v3 : vec n):
    vsub (vsub v1 v2) v3 = vsub v1 (vadd fadd v2 v3).
  Proof.
    unfold vsub.
    induction n; intros; simpl; auto. f_equal; auto.
    rewrite fopp_add_dist. auto.
  Qed.

  Lemma vsub_S : forall {n} t1 t2 (v1 v2 : vec n),
    vsub ((t1, v1) : vec (S n)) (t2, v2) = (t1 - t2, vsub v1 v2).
  Proof. intros. apply vmap2_S. Qed.

  Lemma vsub_v0_l : forall {n} (v : vec n), vsub (vec0 T0 n) v = vopp v.
  Proof.
    induction n; intros; destruct v;auto. rewrite vec0_S. rewrite vsub_S.
    rewrite vopp_S. f_equal. auto. auto.
  Qed.

  Lemma vsub_v0_r : forall {n} (v : vec n), vsub v (vec0 T0 n) = v.
  Proof.
    induction n; intros; destruct v; auto. rewrite vec0_S. rewrite vsub_S.
    f_equal. rewrite fopp_0. auto. auto.
  Qed.

  Lemma vsub_self : forall {n} (v : vec n), vsub v v = vec0 T0 n.
  Proof.
    unfold vsub.
    induction n; intros; destruct v; simpl; auto. f_equal; auto.
  Qed.

End vsub.

Arguments vopp {T} fopp {n}.
Arguments vsub {T} fopp fadd {n}.

(** ** Vector constant multiplication *)
Section vcmul_vmulc.

  Variable T : Type.
  Variable T0 T1 : T.
  Variable fmul : T -> T -> T.
  Variable fmul_comm : forall a b, fmul a b = fmul b a.
  Variable fmul_0_l : forall a, fmul T0 a = T0.
  Variable fmul_0_r : forall a, fmul a T0 = T0.
  Variable fmul_1_l : forall a, fmul T1 a = a.

  Definition vcmul {n} a v : vec n := vmap (fun x => fmul a x) v.
  Definition vmulc {n} v a : vec n := vmap (fun x => fmul x a) v.

  Lemma vcmul_eq_vmulc : forall {n} a (v : vec n), vcmul a v = vmulc v a.
  Proof.
    unfold vcmul,vmulc.
    induction n; intros; destruct v; simpl; auto. f_equal; auto.
  Qed.

  Lemma vcmul_S : forall {n} a b (v : vec n),
    vcmul a ((b,v):vec (S n)) = (fmul a b, vcmul a v).
  Proof. induction n; intros; destruct v; unfold vcmul; simpl; auto. Qed.

  Lemma vmulc_S : forall {n} a b (v : vec n),
    vmulc ((b,v):vec (S n)) a = (fmul b a, vmulc v a).
  Proof. induction n; intros; destruct v; unfold vcmul; simpl; auto. Qed.

  (** 0 * l = 0 *)
  Lemma vcmul_0_l : forall {n} (v : vec n), vcmul T0 v = vec0 T0 n.
  Proof.
    induction n; intros; simpl; auto. f_equal; auto.
  Qed.

  (** l * 0 = 0 *)
  Lemma vcmul_0_r : forall {n} a, vcmul a (vec0 T0 n) = vec0 T0 n.
  Proof.
    induction n; intros; simpl; auto. f_equal; auto.
  Qed.

  (** 1 * l = l *)
  Lemma vcmul_1_l : forall {n} (v : vec n), vcmul T1 v = v.
  Proof.
    induction n; intros; destruct v; simpl; auto. f_equal; auto.
  Qed.

End vcmul_vmulc.

Arguments vcmul {T} fmul {n}.
Arguments vmulc {T} fmul {n}.

(** ** Fold a vector to an element *)
Section vfold.

  Variable T : Type.

  Variable fadd : T -> T -> T.

  Fixpoint vfoldl {n} (init_val : T) : (vec n) -> T :=
    match n with
    | O => fun (v : vec 0) => init_val
    | S n' => fun (v : vec (S n')) =>
      fadd (fst v) (vfoldl init_val (snd v))
    end.

  (** Fold a vector to en element from right to left *)
  Fixpoint vfoldr {n} (init_val : T) : (vec n) -> T :=
    match n with
    | O => fun (v : vec 0) => init_val
    | S n' => fun (v : vec (S n')) =>
      fadd (vfoldr init_val (snd v)) (fst v)
    end.

End vfold.

Arguments vfoldl {T} fadd {n}.
Arguments vfoldr {T} fadd {n}.

(** ** Dot product of two vectors *)
Section vdot.

  Variable T : Type.
  Variable T0 : T.
  Variable fadd : T -> T -> T.
  Variable fmul : T -> T -> T.
  Variable fadd_comm : forall a b, fadd a b = fadd b a.
  Variable fmul_comm : forall a b, fmul a b = fmul b a.
  Variable fmul_0_l : forall a, fmul T0 a = T0.
  Variable fadd_0_r : forall t, fadd t T0 = t.
  Variable fmul_fadd_dist_l : forall a b c,
    fmul a (fadd b c) = fadd (fmul a b) (fmul a c).
  Variable fadd_assoc: forall a b c, fadd a (fadd b c) = fadd (fadd a b) c.
  Variable fmul_assoc: forall a b c, fmul a (fmul b c) = fmul (fmul a b) c.

  Definition vdot {n} (v1 v2 : vec n) := vfoldl fadd T0 (vmap2 fmul v1 v2).

  Lemma vdot_S : forall {n} (a b : T) (v1 v2 : vec n),
      vdot ((a,v1):vec (S n)) (b,v2) = fadd (fmul a b) (vdot v1 v2).
  Proof. induction n; intros; auto. Qed.

  Lemma vdot_comm {n} (v1 v2 : vec n) : vdot v1 v2 = vdot v2 v1.
  Proof. unfold vdot. f_equal. apply vmap2_comm. intros; auto. Qed.

  Lemma vdot_tt (v : vec 0) : vdot v v = T0.
  Proof. unfold vdot. simpl. auto. Qed.

  Lemma vdot_0_l : forall {n} (v : vec n), vdot (vec0 T0 n) v = T0.
  Proof.
    induction n; intros; destruct v; simpl. apply vdot_tt.
    rewrite vdot_S. rewrite IHn. rewrite fmul_0_l. auto.
  Qed.

  Lemma vdot_0_r : forall {n} (v : vec n), vdot v (vec0 T0 n) = T0.
  Proof.
    intros. rewrite vdot_comm. apply vdot_0_l.
  Qed.

  Lemma vdot_vcmul_l : forall {n} a (v1 v2 : vec n),
    vdot (vcmul fmul a v1) v2 = fmul a (vdot v1 v2).
  Proof.
    induction n; intros; destruct v1,v2; simpl.
    - repeat rewrite vdot_tt. rewrite fmul_comm. auto.
    - repeat rewrite vdot_S. rewrite IHn.
      remember (vdot v v0). rewrite fmul_fadd_dist_l. f_equal. auto.
  Qed.

  Lemma vdot_vcmul_r : forall {n} a (v1 v2 : vec n),
    vdot v1 (vcmul fmul a v2) = fmul a (vdot v1 v2).
  Proof.
    intros. rewrite vdot_comm. rewrite vdot_vcmul_l. f_equal.
    apply vdot_comm.
  Qed.

  Lemma vdot_vmulc_l : forall {n} a (v1 v2 : vec n),
    vdot (vmulc fmul v1 a) v2 = fmul a (vdot v1 v2).
  Proof. intros. rewrite <- vcmul_eq_vmulc; auto. apply vdot_vcmul_l. Qed.

  Lemma vdot_vmulc_r : forall {n} a (v1 v2 : vec n),
    vdot v1 (vmulc fmul v2 a) = fmul a (vdot v1 v2).
  Proof. intros. rewrite <- vcmul_eq_vmulc; auto. apply vdot_vcmul_r. Qed.

  Lemma vdot_vadd_l : forall {n} (v1 v2 v3 : vec n),
    vdot v1 (vadd fadd v2 v3) = fadd (vdot v1 v2) (vdot v1 v3).
  Proof.
    induction n; intros; destruct v1,v2,v3; simpl.
    - repeat rewrite vdot_tt. auto.
    - repeat rewrite ?vdot_S, ?vadd_S. rewrite IHn.
      remember (vdot v v0). remember (vdot v v1).
      rewrite fmul_fadd_dist_l.
      repeat rewrite fadd_assoc. f_equal.
      remember (fmul t t0). remember (fmul t t1).
      repeat rewrite <- fadd_assoc. f_equal.
      apply fadd_comm.
  Qed.

  Lemma vdot_vadd_r : forall {n} (v1 v2 v3 : vec n),
    vdot (vadd fadd v1 v2) v3 = fadd (vdot v1 v3) (vdot v2 v3).
  Proof.
    intros. rewrite vdot_comm. rewrite vdot_vadd_l.
    f_equal; apply vdot_comm.
  Qed.

End vdot.

Arguments vdot {T} T0 fadd fmul {n}.

(** ** Concatenation a nested vector to a plain vector *)
Section vvflat.

  Variable T : Type.

  Fixpoint vvflat {r c} : (@vec (@vec T c) r) -> @vec T (r * c) :=
    match r with
    | O => fun (m : @vec (vec c) 0) => tt
    | S r' => fun (m : @vec (vec c) (S r')) =>
      vapp (fst m) (vvflat (snd m))
    end.

End vvflat.

Arguments vvflat {T r c}.

(** vector to list *)
Section v2l.
  Variable A : Type.
  Variable A0 : A.

  Fixpoint v2l {n} : @vec A n -> list A :=
    match n with
    | 0 => fun (v : @vec A 0) => nil
    | S n' => fun (v : @vec A (S n')) => cons (fst v) (v2l (snd v))
    end.

  Lemma v2l_length : forall n (v : @vec A n), length (v2l v) = n.
  Proof.
    induction n; intros; destruct v; simpl; auto.
  Qed.

  Fixpoint l2v (l : list A) (n : nat) {struct n} : vec n :=
    match n as n0 return (vec n0) with
    | 0 => tt
    | S n' => (hd A0 l, l2v (tl l) n')
    end.

  Lemma v2l_l2v_id : forall (n : nat) (l : list A), length l = n ->
    v2l (l2v l n) = l.
  Proof.
    induction n; intros; simpl.
    - apply length_zero_iff_nil in H; auto.
    - rewrite IHn; auto.
      + destruct l; auto; simpl in *. discriminate H.
      + destruct l; auto; simpl in *. discriminate H.
  Qed.

  Lemma l2v_v2l_id : forall (n : nat) (v : vec n), l2v (v2l v) n = v.
  Proof.
    intros. induction n; destruct v; simpl; auto. rewrite IHn. auto.
  Qed.

End v2l.

Arguments v2l {A n}.
Arguments l2v {A}.

(* Check ([1;2;3] : vec 3).
Compute v2l ([1;2;3] : vec 3).
Compute l2v 0 (cons 1 (cons 2 nil)) 2. *)

(** ** Linear Space. These code is for test *)
Section LinearSpace.

  (** definition of Linear Space:
  V ~~ vec
  P ~~ T
  + ~~ vadd
  . ~~ vcmul/vmulc
  *)

  (* dimension *)
  Variable n : nat.

  (* P *)
  Variable T : Type.
  Variable T0 : T.
  Variable T1 : T.
  Variable Topp : T -> T.
  Variable Tadd Tmul : T -> T -> T.

  Declare Scope T_scope.
  Delimit Scope T_scope with t.
  Open Scope T_scope.
  Notation "- t" := (Topp t) : T_scope.
  Infix "+" := Tadd : T_scope.
  Infix "*" := Tmul : T_scope.

  (** 这里有很多有趣的性质，等待去证明。
   平时我们用的都是直觉或特例，但是抽象的类型需要证明。
   研究课题：代数系统、群、环、域，等这些内容。
   研究目标：彻底弄懂这些定义。到底哪个是因，哪个是果 *)
  Variable Tadd_comm : forall a b, a + b = b + a.
  Variable Tadd_assoc : forall a b c, (a + b) + c = a + (b + c).
  Variable Tadd_0_l : forall a, T0 + a = a.
  Variable Tadd_opp : forall a, a + (-a) = T0.
  Variable Tadd_elim_l : forall a b c, a + b = a + c -> b = c.
  Variable Tadd_elim_2 : forall a b, a + b = a -> b = T0.
  Variable Tadd_elim_3 : forall a b, a + b = T0 -> a = -b.
  Variable Tadd_elim_4 : forall a b, a = -b <-> -a = b.
  Variable Tmul_1_l : forall t, T1 * t = t.
  Variable Tmul_comm : forall a b, a * b = b * a.
  Variable Tmul_assoc : forall a b c, (a * b) * c = a * (b * c).
  Variable Tmul_Tadd_dist_r : forall a b c, (a + b) * c = a * c + b * c.

  (* V *)
  Definition V := @vec T n.
  Definition V0 := @vec0 T T0 n.
  Definition Vadd := @vadd T Tadd n.
  Definition Vcmul := @vcmul T Tmul n.
  Definition Vmulc := @vmulc T Tmul n.

  Declare Scope V_scope.
  Delimit Scope V_scope with v.
  Open Scope V_scope.
  Notation "v1 + v2" := (Vadd v1 v2)
    : V_scope.
  Notation "a c* v" := (Vcmul a v) : V_scope.
  Notation "v *c a" := (Vmulc v a) : V_scope.

  (* (1), v1 + v2 = v2 + v1 *)
  Lemma Vadd_comm : forall (v1 v2 : V), v1 + v2 = v2 + v1.
  Proof. intros. apply vadd_comm. auto. Qed.

  (* (2), (v1 + v2) + v3 = v1 + (v2 + v3) *)
  Lemma Vadd_assoc : forall (v1 v2 v3 : V), (v1 + v2) + v3 = v1 + (v2 + v3).
  Proof. intros. apply vmap2_assoc. auto. Qed.

  (* (3), v + 0 = v *)
  Lemma Vadd_0_r : forall (v : V), v + V0 = v.
  Proof. intros. apply vadd_0_r; auto. Qed.

  (* (4), ∀α∈V (∃β (α + β = 0)) *)
  Lemma Vopp_exist : forall (v1 : V), {v2 | v1 + v2 = V0}.
  Proof.
    unfold V,V0,Vadd in *. induction n; intros; destruct v1; simpl.
    - exists tt. auto.
    - exists (-t, vmap Topp v). f_equal; simpl; auto.
      destruct (IHn0 v). clear IHn0 e x.
      induction n0; destruct v; simpl; auto. f_equal; auto.
  Qed.

  (* (5) 1 . v = v *)
  Lemma Vcmul_1_l : forall (v : V), T1 c* v = v.
  Proof.
    unfold V, Vcmul. intros. induction n; destruct v; simpl; auto.
    f_equal; auto.
  Qed.

  (* (6) k . (m . v) = (km) . v *)
  Lemma Vcmul_assoc : forall (k m : T) (v : V),
    k c* (m c* v) = (k*m) c* v.
  Proof.
    unfold V, Vcmul. intros. induction n; destruct v; simpl; auto.
    f_equal; auto.
  Qed.

  (* (7) (k + m) . v = k.v + m.v *)
  Lemma Vcmul_dist_c : forall (k m : T) (v : V),
    (k + m)%t c* v = (k c* v) + (m c* v).
  Proof.
    unfold V,Vadd,Vcmul. intros. induction n; destruct v; simpl; auto.
    f_equal; auto.
  Qed.

  (* (8) k . (v1 + v2) = k.v1 + k.v2 *)
  Lemma Vcmul_dist_v : forall (k : T) (v1 v2 : V),
    k c* (v1 + v2) = (k c* v1) + (k c* v2).
  Proof.
    unfold V,Vadd,Vcmul. intros. induction n; destruct v1,v2; simpl; auto.
    f_equal; auto. rewrite Tmul_comm. rewrite Tmul_Tadd_dist_r. f_equal; auto.
  Qed.

End LinearSpace.


(** * Bounded lattices *)

Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.MoreFoundations.Propositions.

Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Algebra.Lattice.Lattice.

Definition bounded_latticeop {X : hSet} (l : lattice X) (bot top : X) :=
  (islunit (Lmax l) bot) × (islunit (Lmin l) top).

Definition bounded_lattice (X : hSet) :=
  ∑ (l : lattice X) (bot top : X), bounded_latticeop l bot top.

Definition make_bounded_lattice {X : hSet} {l : lattice X} {bot top : X} :
  bounded_latticeop l bot top → bounded_lattice X := λ bl, l,, bot,, top,, bl.

Definition bounded_lattice_to_lattice X : bounded_lattice X → lattice X := pr1.
Coercion bounded_lattice_to_lattice : bounded_lattice >-> lattice.

Definition Lbot {X : hSet} (is : bounded_lattice X) : X := pr1 (pr2 is).
Definition Ltop {X : hSet} (is : bounded_lattice X) : X := pr1 (pr2 (pr2 is)).

Section bounded_lattice_pty.

Context {X : hSet} (l : bounded_lattice X).

Definition islunit_Lmax_Lbot : islunit (Lmax l) (Lbot l) :=
  pr1 (pr2 (pr2 (pr2 l))).

Definition islunit_Lmin_Ltop : islunit (Lmin l) (Ltop l) :=
  pr2 (pr2 (pr2 (pr2 l))).

Lemma Lmin_Lbot (x : X) : Lmin l (Lbot l) x = Lbot l.
Proof.
now rewrite <- (islunit_Lmax_Lbot x), Lmin_absorb.
Qed.

Lemma Lmax_Ltop (x : X) : Lmax l (Ltop l) x = Ltop l.
Proof.
now rewrite <- (islunit_Lmin_Ltop x), Lmax_absorb.
Qed.

End bounded_lattice_pty.

Definition hProp_bounded_lattice : bounded_lattice (hProp,,isasethProp).
Proof.
use make_bounded_lattice.
- exact hProp_lattice.
- exact hfalse.
- exact htrue.
- split.
  + intros P; apply hfalse_hdisj.
  + intros P; apply htrue_hconj.
Defined.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Nth.
Require option.Option.
Require list.HdTl.

(* Why3 goal *)
Lemma Nth_tl :
forall {a:Type} {a_WT:WhyType a},
forall (l1:(list a)) (l2:(list a)),
 ((list.HdTl.tl l1) = (Init.Datatypes.Some l2)) ->
 forall (i:Z),
  (~ (i = (-1%Z)%Z)) -> ((list.Nth.nth i l2) = (list.Nth.nth (i + 1%Z)%Z l1)).
Proof.
intros a a_WT [|x1 l1] l2 h1 i h2.
easy.
simpl.
generalize (Zeq_bool_if (i + 1) 0).
case Zeq_bool.
intro H.
exfalso.
omega.
intros _.
simpl in h1.
inversion h1.
apply (f_equal (fun i => Nth.nth i l2)).
exact (Zpred_succ i).
Qed.

(* Why3 goal *)
Lemma Nth0_head :
forall {a:Type} {a_WT:WhyType a},
forall (l:(list a)), ((list.Nth.nth 0%Z l) = (list.HdTl.hd l)).
Proof.
now intros a a_WT [|h t].
Qed.