Require Import Coq.Init.Byte FunctionalExtensionality EqdepFacts List Ndigits ZArith Lia.
From Minirust.def Require Import ty int_encoding.
From Minirust.proof.lemma Require Import utils.
From Minirust.proof.int_raw Require Import low.

(* TODO cleanup this file. There are a lot of things, that can be simplified using the basenum abstraction. *)

(* every other number relevant for `int_in_range` can be expressed neatly using basenum. *)
Definition basenum (size: Size) := (2 ^ (Z.of_nat size*8-1))%Z.

Lemma double_base {size: Size} (H: size > 0) :
  (2 ^ (Z.of_nat size * 8))%Z = ((basenum size) * 2)%Z.
Proof.
unfold basenum.
declare x Hx (Z.of_nat size * 8)%Z.
assert (x > 0)%Z as B. { lia. }
rewrite Hx. clear - x B.
destruct x; try (simpl; lia).
assert (2^(Z.pos p) = 2 * 2^(Z.pos p-1))%Z; try lia.
rewrite <- (Z.pow_succ_r 2); try lia.
replace (Z.succ (Z.pos p - 1))%Z with (Z.pos p); lia.
Qed.

Lemma start_to_base (size: Size) (signedness: Signedness) :
  int_start size signedness = match signedness with
  | Unsigned => 0%Z
  | Signed => (-(basenum size))%Z
  end.
Proof.
destruct signedness; unfold int_start.
- unfold basenum. reflexivity.
- reflexivity.
Qed.

Lemma stop_to_base (size: Size) (signedness: Signedness) :
  (size > 0) ->
  int_stop size signedness = match signedness with
  | Unsigned => ((basenum size) * 2)%Z
  | Signed => basenum size
  end.
Proof.
intros Hs.
destruct signedness; unfold int_stop,basenum.
- reflexivity.
- apply (double_base Hs).
Qed.

Lemma offset_to_base (size: Size) :
  (size > 0) ->
  signed_offset size = ((basenum size) * 2)%Z.
Proof.
apply double_base.
Qed.

Ltac to_base := repeat (
  unfold int_in_range ||
  (rewrite stop_to_base; try assumption) ||
  (rewrite start_to_base; try assumption) ||
  (rewrite offset_to_base; try assumption)
).

Ltac to_base_in x := repeat (
  unfold int_in_range in x ||
  (rewrite stop_to_base in x; try assumption) ||
  (rewrite start_to_base in x; try assumption) ||
  (rewrite offset_to_base in x; try assumption)
).

Lemma lemma2 (int: Int) (size: Size) (H: int_in_range int size Signed = true) (H2 : (int >=? 0)%Z = true) :
  (size > 0) ->
  int_in_range int size Unsigned = true.
Proof.
intros Hs.
to_base_in H.
to_base.
lia.
Qed.

Lemma lemma3 (size: Size) (int: Int) (H1: (int >=? 0)%Z = false) (H2: int_in_range int size Signed = true) (Hs: size > 0) :
  int_in_range (int + signed_offset size)%Z size Unsigned = true.
Proof.
to_base.
to_base_in H2.
lia.
Qed.

Lemma lemma4 (size: Size) (int: Int)
              (Hs0 : (int >= - 2 ^ (Z.of_nat size * 8 - 1))%Z) :
  true = (
        int + 2 ^ (Z.of_nat size * 8)
    >=? 2 ^ (Z.of_nat size * 8 - 1))%Z.
Proof.
rewrite (proj2 (Z.geb_le _ _)). { reflexivity. }
assert (2 ^ (Z.of_nat size * 8 - 1) <= (- 2 ^ (Z.of_nat size * 8 - 1))%Z + 2 ^ (Z.of_nat size * 8))%Z; cycle 1. { lia. }
declare x Hx (Z.of_nat size * 8)%Z. rewrite Hx. clear - x.
destruct x; try (simpl; lia).
assert (2^(Z.pos p) = 2 * 2^(Z.pos p-1))%Z; try lia.
rewrite <- (Z.pow_succ_r 2); try lia.
replace (Z.succ (Z.pos p - 1))%Z with (Z.pos p); lia.
Qed.

Lemma lemma5 (d: Int) (size: Size) :
  (size > 0) ->
  ((d >=? int_stop size Signed)%Z = true) ->
  (int_in_range d size Unsigned = true) ->
  (int_in_range (d - signed_offset size)%Z size Signed) = true.
Proof.
intros Hs.
to_base.
lia.
Qed.

Lemma lemma6 (d: Int) (size: Size) :
  (size > 0) ->
  (int_in_range d size Unsigned = true) ->
  (d - signed_offset size >=? 0)%Z = false.
Proof.
intros Hs.
to_base.
lia.
Qed.

Lemma lemma7 (size: Size) (l: list byte) :
  (length l = size) ->
  (decode_uint_le size l >=? 0)%Z = true.
Proof.
intros H.
destruct (destruct_int_in_range (uint_le_decode_valid size l H)) as [H0 _].
to_base_in H0.
to_base.
lia.
Qed.

Lemma lemma8 (d: Int) (size: Size) :
  (size > 0) ->
  (d >=? int_stop size Signed)%Z = false ->
  (d >=? 0)%Z = true ->
  (int_in_range d size Signed) = true.
Proof.
intros Hs.
to_base.
lia.
Qed.

Lemma rt1_int_le (size: Size) (signedness: Signedness) (int: Int) (H: int_in_range int size signedness = true) :
  (size > 0) ->
  exists l, Some l = encode_int_le size signedness int /\
  decode_int_le size signedness l = Some int /\ length l = size.
Proof.
intros Hs.
destruct signedness.
(* signed *)
- destruct (int >=? 0)%Z eqn:E.

(* signed, positive *)
-- exists (encode_uint_le size int).
unfold encode_int_le. rewrite H. simpl.
rewrite E.
split. { reflexivity. }
split.
++ unfold decode_int_le.
   have HR (lemma2 _ _ H E Hs).
   rewrite (uint_le_encode_valid); try apply HR.
   f_equal.
   rewrite Nat.eqb_refl.
   replace (decode_uint_le size (encode_uint_le size int) >=?
      int_stop size Signed)%Z with false. {
     simpl. f_equal.
     apply rt1_uint_le.
     apply HR; try lia; try assumption.
   }
   rewrite rt1_uint_le; try apply HR.
   destruct (destruct_int_in_range H).
   to_base. to_base_in H0. to_base_in H1. to_base_in HR.
   lia.
++ apply uint_le_encode_valid.
   apply (lemma2 _ _ H); lia.

(* signed, negative *)
-- exists (encode_uint_le size (int + signed_offset size)%Z).
split.
--- unfold encode_int_le. rewrite H,E. simpl. reflexivity.
--- unfold decode_int_le.
    rewrite rt1_uint_le.
    destruct (destruct_int_in_range (lemma3 _ _ E H Hs)) as [H0 H1].
---- rewrite uint_le_encode_valid.
     rewrite Nat.eqb_refl.
     f_equal.
     split; try reflexivity.
     replace (int + signed_offset size >=?
        int_stop size Signed)%Z with true.
     destruct (destruct_int_in_range H) as [Hs0 Hs1].
     to_base. to_base_in H0. to_base_in H1. to_base_in Hs0. to_base_in Hs1.
     simpl. f_equal. lia.

     destruct (destruct_int_in_range H) as [Hs0 Hs1]. (* this is redundant *)
     to_base. to_base_in H0. to_base_in H1. to_base_in Hs0. to_base_in Hs1.
     lia.

     to_base. to_base_in H0. to_base_in H1. to_base_in Hs0. to_base_in Hs1.
     lia.
---- apply (lemma3 _ _ E H Hs).

(* unsigned *)
- exists (encode_uint_le size int).
unfold encode_int_le. rewrite H. simpl.
split. { reflexivity. }
unfold decode_int_le.
rewrite (uint_le_encode_valid).
rewrite Nat.eqb_refl.
simpl.
f_equal. split; try reflexivity.
f_equal.
apply rt1_uint_le.
assumption.
assumption.
Qed.

Lemma rt2_int_le (size: Size) (signedness: Signedness) (l: list byte) (H: length l = size) :
  (size > 0) ->
  exists int, Some int = decode_int_le size signedness l /\
  encode_int_le size signedness int = Some l /\
  int_in_range int size signedness = true.
Proof.
intros Hs.
destruct signedness; unfold decode_int_le,encode_int_le; simpl; rewrite H; rewrite Nat.eqb_refl; simpl.
- destruct ((decode_uint_le size l) >=? int_stop size Signed)%Z eqn:E'.

(* signed, negative *)
-- exists ((decode_uint_le size l) - signed_offset size)%Z.
   rewrite lemma5; try assumption; try (apply uint_le_decode_valid; assumption).
   rewrite lemma6; try (apply uint_le_decode_valid; assumption); try assumption.
   unfold int_stop in E'. rewrite E'.
   split. { reflexivity. }
   simpl. f_equal.
   assert (forall x y, x - y + y = x)%Z as F. { lia. }
   rewrite F.
   split; try reflexivity.
   f_equal.
   apply rt2_uint_le.
   assumption.

(* signed, positive *)
-- exists (decode_uint_le size l).
   rewrite lemma7; try assumption.
   rewrite lemma8; try (assumption || (apply lemma7; assumption)).
   unfold int_stop in E'. rewrite E'.
   split. { reflexivity. }
   simpl.
   rewrite rt2_uint_le.
--- split; reflexivity.
--- assumption.

(* unsigned *)
- exists (decode_uint_le size l).
  split. { reflexivity. }
  rewrite uint_le_decode_valid; try assumption.
  simpl.
  rewrite rt2_uint_le.
-- split; reflexivity.
-- assumption.
Qed.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype.
From mathcomp Require Import bigop finset fingroup morphism automorphism.
From mathcomp Require Import quotient gproduct.

(******************************************************************************)
(*   This file provides basic interfaces for the notion of "generic"          *)
(* characteristic subgroups; these amount to subfunctors of the identity      *)
(* functor in some category of groups.                                        *)
(* See "Generic Proof Tools And Finite Group Theory",                         *)
(* Francois Garillot, PhD, 2011, Chapter 3.                                   *)
(* The implementation proposed here is fairly basic, relying on first order   *)
(* function matching and on structure telescopes, both of which are somewhat  *)
(* limited and fragile. It should switch in the future to more general and    *)
(* more robust quotation matching.                                            *)
(*   The definitions in this file (types, properties and structures) are all  *)
(* packaged under the GFunctor submodule, i.e., client code should refer to   *)
(* GFunctor.continuous, GFunctor.map, etc. Notations, Coercions and Lemmas    *)
(* are exported and thus directly available, however.                         *)
(*   We provide the following:                                                *)
(*      object_map == the type of the (polymorphic) object map of a group     *)
(*                    functor; the %gF scope is bound to object_map.          *)
(*                 := forall gT : finGroupType, {set gT} -> {set gT}.         *)
(*  We define two operations on object_map (with notations in the %gF scope): *)
(*        F1 \o F2 == the composite map; (F1 \o F2) G expands to F1 (F2 G).   *)
(*        F1 %% F2 == F1 computed modulo F2; we have                          *)
(*                    (F1 %% F2) G / F2 G = F1 (G / F2 G)                     *)
(* We define the following (type-polymorphic) properties of an object_map F:  *)
(*     group_valued F <-> F G is a group when G is a group                    *)
(*           closed F <-> F G is a subgroup o fG when G is a group            *)
(*       continuous F <-> F is continuous with respect to morphism image:     *)
(*                        for any f : {morphism G >-> ..}, f @* (F G) is a    *)
(*                        a subgroup of F (f @* G); equivalently, F is        *)
(*                        functorial in the category Grp of groups.           *)
(*                        Most common "characteristic subgroup" are produced  *)
(*                        continuous object maps.                             *)
(*   iso_continuous F <-> F is continuous with respect to isomorphism image;  *)
(*                        equivalently, F is functorial in the Grp groupoid.  *)
(*                        The Puig and the Thompson J subgroups are examples  *)
(*                        of iso_continuous maps that are not continuous.     *)
(*      pcontinuous F <-> F is continuous with respect to partial morphism    *)
(*                        image, i.e., functorial in the category of groups   *)
(*                        and partial morphisms. The center and p-core are    *)
(*                        examples of pcontinuous maps.                       *)
(*       hereditary F <-> inclusion in the image of F is hereditary, i.e.,    *)
(*                        for any subgroup H of G, the intersection of H with *)
(*                        F G is included in H. Note that F is pcontinuous    *)
(*                        iff it is continuous and hereditary; indeed proofs  *)
(*                        of pcontinuous F coerce to proofs of hereditary F   *)
(*                        and continuous F.                                   *)
(*        monotonic F <-> F is monotonic with respect to inclusion: for any   *)
(*                        subgroup H of G, F H is a subgroup of F G. The      *)
(*                        derived and lower central series are examples of    *)
(*                        monotonic maps.                                     *)
(* Four structures provide interfaces to these properties:                    *)
(*    GFunctor.iso_map == structure for object maps that are group_valued,    *)
(*                        closed, and iso_continuous.                         *)
(*  [igFun by Fsub & !Fcont] == the iso_map structure for an object map F     *)
(*                        such that F G is canonically a group when G is, and *)
(*                        given Fsub : closed F and Fcont : iso_continuous F. *)
(*  [igFun by Fsub & Fcont] == as above, but expecting Fcont : continuous F.  *)
(*        [igFun of F] == clone an existing GFunctor.iso_map structure for F. *)
(*        GFunctor.map == structure for continuous object maps, inheriting    *)
(*                        from the GFunctor.iso_map structure.                *)
(*     [gFun by Fcont] == the map structure for an F with a canonical iso_map *)
(*                        structure, given Fcont : continuous F.              *)
(*         [gFun of F] == clone an existing GFunctor.map structure for F.     *)
(*       GFunctor.pmap == structure for pcontinuous object maps, inheriting   *)
(*                        from the GFunctor.map structure.                    *)
(*    [pgFun by Fher] == the pmap structure for an F with a canonical map     *)
(*                        structure, given Fher : hereditary F.               *)
(*        [pgFun of F] == clone an existing GFunctor.pmap structure for F.    *)
(*   GFunctor.mono_map == structure for monotonic, continuous object maps     *)
(*                        inheriting from the GFunctor.map structure.         *)
(*     [mgFun by Fmon] == the mono_map structure for an F with a canonical    *)
(*                        map structure, given Fmon : monotonic F.            *)
(*        [mgFun of F] == clone an existing GFunctor.mono_map structure for F *)
(* Lemmas for these group functors use either a 'gF' prefix or an 'F' suffix. *)
(* The (F1 \o F2) and (F1 %% F2) operations have canonical GFunctor.map       *)
(* structures when F1 is monotonic or hereditary, respectively.               *)
(******************************************************************************)

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

Declare Scope gFun_scope.

Import GroupScope.

Delimit Scope gFun_scope with gF.

Module GFunctor.

Definition object_map := forall gT : finGroupType, {set gT} -> {set gT}.

Bind Scope gFun_scope with object_map.

Section Definitions.

Implicit Types gT hT : finGroupType.

Variable F : object_map.

(* Group closure. *)
Definition group_valued := forall gT (G : {group gT}), group_set (F G).

(* Subgroup closure. *)
Definition closed := forall gT (G : {group gT}), F G \subset G.

(* General functoriality, i.e., continuity of the object map *)
Definition continuous :=
  forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
    phi @* F G \subset F (phi @* G).

(* Functoriality on the Grp groupoid (arrows are restricted to isos). *)
Definition iso_continuous :=
  forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
   'injm phi -> phi @* F G \subset F (phi @* G).

Lemma continuous_is_iso_continuous : continuous -> iso_continuous.
Proof. by move=> Fcont gT hT G phi inj_phi; apply: Fcont. Qed.

(* Functoriality on Grp with partial morphisms. *)
Definition pcontinuous :=
  forall gT hT (G D : {group gT}) (phi : {morphism D >-> hT}),
    phi @* F G \subset F (phi @* G).

Lemma pcontinuous_is_continuous : pcontinuous -> continuous.
Proof. by move=> Fcont gT hT G; apply: Fcont. Qed.

(* Heredity with respect to inclusion *)
Definition hereditary :=
  forall gT (H G : {group gT}), H \subset G -> F G :&: H \subset F H.

Lemma pcontinuous_is_hereditary : pcontinuous -> hereditary.
Proof.
move=> Fcont gT H G sHG; rewrite -{2}(setIidPl sHG) setIC.
by do 2!rewrite -(morphim_idm (subsetIl H _)) morphimIdom ?Fcont.
Qed.

(* Monotonicity with respect to inclusion *)
Definition monotonic :=
  forall gT (H G : {group gT}), H \subset G -> F H \subset F G.

(* Self-expanding composition, and modulo *)

Variables (k : unit) (F1 F2 : object_map).

Definition comp : object_map := fun gT A => F1 (F2 A).

Definition modulo : object_map :=
  fun gT A => coset (F2 A) @*^-1 (F1 (A / (F2 A))).

End Definitions.

Section ClassDefinitions.

Structure iso_map := IsoMap {
  apply : object_map;
  _ : group_valued apply;
  _ : closed apply;
  _ : iso_continuous apply
}.
Local Coercion apply : iso_map >-> object_map.

Structure map := Map { iso_of_map : iso_map; _ : continuous iso_of_map }.
Local Coercion iso_of_map : map >-> iso_map.

Structure pmap := Pmap { map_of_pmap : map; _ : hereditary map_of_pmap }.
Local Coercion map_of_pmap : pmap >-> map.

Structure mono_map := MonoMap { map_of_mono : map; _ : monotonic map_of_mono }.
Local Coercion map_of_mono : mono_map >-> map.

Definition pack_iso F Fcont Fgrp Fsub := @IsoMap F Fgrp Fsub Fcont.

Definition clone_iso (F : object_map) :=
  fun Fgrp Fsub Fcont (isoF := @IsoMap F Fgrp Fsub Fcont) =>
  fun isoF0 & phant_id (apply isoF0) F & phant_id isoF isoF0 => isoF.

Definition clone (F : object_map) :=
  fun isoF & phant_id (apply isoF) F =>
  fun (funF0 : map) & phant_id (apply funF0) F =>
  fun Fcont (funF := @Map isoF Fcont) & phant_id funF0 funF => funF.

Definition clone_pmap (F : object_map) :=
  fun (funF : map) & phant_id (apply funF) F =>
  fun (pfunF0 : pmap) & phant_id (apply pfunF0) F =>
  fun Fher (pfunF := @Pmap funF Fher) & phant_id pfunF0 pfunF => pfunF.

Definition clone_mono (F : object_map) :=
  fun (funF : map) & phant_id (apply funF) F =>
  fun (mfunF0 : mono_map) & phant_id (apply mfunF0) F =>
  fun Fmon (mfunF := @MonoMap funF Fmon) & phant_id mfunF0 mfunF => mfunF.

End ClassDefinitions.

Module Exports.

Identity Coercion fun_of_object_map : object_map >-> Funclass.
Coercion apply : iso_map >-> object_map.
Coercion iso_of_map : map >-> iso_map.
Coercion map_of_pmap : pmap >-> map.
Coercion map_of_mono : mono_map >-> map.
Coercion continuous_is_iso_continuous : continuous >-> iso_continuous.
Coercion pcontinuous_is_continuous : pcontinuous >-> continuous.
Coercion pcontinuous_is_hereditary : pcontinuous >-> hereditary.

Notation "[ 'igFun' 'by' Fsub & Fcont ]" :=
    (pack_iso (continuous_is_iso_continuous Fcont) (fun gT G => groupP _) Fsub)
  (at level 0, format "[ 'igFun'  'by'  Fsub  &  Fcont ]") : form_scope.

Notation "[ 'igFun' 'by' Fsub & ! Fcont ]" :=
    (pack_iso Fcont (fun gT G => groupP _) Fsub)
  (at level 0, format "[ 'igFun'  'by'  Fsub  &  ! Fcont ]") : form_scope.

Notation "[ 'igFun' 'of' F ]" := (@clone_iso F _ _ _ _ id id)
  (at level 0, format "[ 'igFun'  'of'  F ]") : form_scope.

Notation "[ 'gFun' 'by' Fcont ]" := (Map Fcont)
  (at level 0, format "[ 'gFun'  'by'  Fcont ]") : form_scope.

Notation "[ 'gFun' 'of' F ]" := (@clone F _ id _ id _ id)
  (at level 0, format "[ 'gFun'  'of'  F ]") : form_scope.

Notation "[ 'pgFun' 'by' Fher ]" := (Pmap Fher)
  (at level 0, format "[ 'pgFun'  'by'  Fher ]") : form_scope.

Notation "[ 'pgFun' 'of' F ]" := (@clone_pmap F _ id _ id _ id)
  (at level 0, format "[ 'pgFun' 'of'  F ]") : form_scope.

Notation "[ 'mgFun' 'by' Fmon ]" := (MonoMap Fmon)
  (at level 0, format "[ 'mgFun'  'by'  Fmon ]") : form_scope.

Notation "[ 'mgFun' 'of' F ]" := (@clone_mono F _ id _ id _ id)
  (at level 0, format "[ 'mgFun' 'of'  F ]") : form_scope.

End Exports.

End GFunctor.
Export GFunctor.Exports.

Bind Scope gFun_scope with GFunctor.object_map.

Arguments GFunctor.comp F1 F2 _ /.
Notation "F1 \o F2" := (GFunctor.comp F1 F2) : gFun_scope.
Notation "F1 %% F2" := (GFunctor.modulo F1 F2) : gFun_scope.

Section FunctorGroup.

Variables (F : GFunctor.iso_map) (gT : finGroupType) (G : {group gT}).
Lemma gFgroupset : group_set (F gT G). Proof. by case: F. Qed.
Canonical gFgroup := Group gFgroupset.

End FunctorGroup.

Canonical gFmod_group
    (F1 : GFunctor.iso_map) (F2 : GFunctor.object_map)
    (gT : finGroupType) (G : {group gT}) :=
  [group of (F1 %% F2)%gF gT G].

Section IsoFunctorTheory.

Implicit Types gT rT : finGroupType.
Variable F : GFunctor.iso_map.

Lemma gFsub gT (G : {group gT}) : F gT G \subset G.
Proof. by case: F gT G. Qed.

Lemma gFsub_trans gT (G : {group gT}) (A : {pred gT}) :
  G \subset A -> F gT G \subset A.
Proof. exact/subset_trans/gFsub. Qed.

Lemma gF1 gT : F gT 1 = 1. Proof. exact/trivgP/gFsub. Qed.

Lemma gFiso_cont : GFunctor.iso_continuous F.
Proof. by case F. Qed.

Lemma gFchar gT (G : {group gT}) : F gT G \char G.
Proof.
apply/andP; split => //; first by apply: gFsub.
apply/forall_inP=> f Af; rewrite -{2}(im_autm Af) -(autmE Af).
by rewrite -morphimEsub ?gFsub ?gFiso_cont ?injm_autm.
Qed.

Lemma gFnorm gT (G : {group gT}) : G \subset 'N(F gT G).
Proof. exact/char_norm/gFchar. Qed.

Lemma gFnorms gT (G : {group gT}) : 'N(G) \subset 'N(F gT G).
Proof. exact/char_norms/gFchar. Qed.

Lemma gFnormal gT (G : {group gT}) : F gT G <| G.
Proof. exact/char_normal/gFchar. Qed.

Lemma gFchar_trans gT (G H : {group gT}) : H \char G -> F gT H \char G.
Proof. exact/char_trans/gFchar. Qed.

Lemma gFnormal_trans gT (G H : {group gT}) : H <| G -> F gT H <| G.
Proof. exact/char_normal_trans/gFchar. Qed.

Lemma gFnorm_trans gT (A : {pred gT}) (G : {group gT}) :
  A \subset 'N(G) -> A \subset 'N(F gT G).
Proof. by move/subset_trans/(_ (gFnorms G)). Qed.

Lemma injmF_sub gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
  'injm f -> G \subset D -> f @* (F gT G) \subset F rT (f @* G).
Proof.
move=> injf sGD; have:= gFiso_cont (injm_restrm sGD injf).
by rewrite im_restrm morphim_restrm (setIidPr _) ?gFsub.
Qed.

Lemma injmF gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
  'injm f -> G \subset D -> f @* (F gT G) = F rT (f @* G).
Proof.
move=> injf sGD; have [sfGD injf'] := (morphimS f sGD, injm_invm injf).
apply/esym/eqP; rewrite eqEsubset -(injmSK injf') ?gFsub_trans //.
by rewrite !(subset_trans (injmF_sub _ _)) ?morphim_invm // gFsub_trans.
Qed.

Lemma gFisom gT rT (G D : {group gT}) R (f : {morphism D >-> rT}) :
  G \subset D -> isom G (gval R) f -> isom (F gT G) (F rT R) f.
Proof.
case/(restrmP f)=> g [gf _ _ _]; rewrite -{f}gf => /isomP[injg <-].
by rewrite sub_isom ?gFsub ?injmF.
Qed.

Lemma gFisog gT rT (G : {group gT}) (R : {group rT}) :
  G \isog R -> F gT G \isog F rT R.
Proof. by case/isogP=> f injf <-; rewrite -injmF // sub_isog ?gFsub. Qed.

End IsoFunctorTheory.

Section FunctorTheory.

Implicit Types gT rT : finGroupType.
Variable F : GFunctor.map.

Lemma gFcont : GFunctor.continuous F.
Proof. by case F. Qed.

Lemma morphimF gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
  G \subset D -> f @* (F gT G) \subset F rT (f @* G).
Proof.
move=> sGD; rewrite -(setIidPr (gFsub F G)).
by rewrite -{3}(setIid G) -!(morphim_restrm sGD) gFcont.
Qed.

End FunctorTheory.

Section PartialFunctorTheory.

Implicit Types gT rT : finGroupType.

Section BasicTheory.

Variable F : GFunctor.pmap.

Lemma gFhereditary : GFunctor.hereditary F.
Proof. by case F. Qed.

Lemma gFunctorI gT (G H : {group gT}) :
  F gT G :&: H = F gT G :&: F gT (G :&: H).
Proof.
rewrite -{1}(setIidPr (gFsub F G)) [G :&: _]setIC -setIA.
rewrite -(setIidPr (gFhereditary (subsetIl G H))).
by rewrite setIC -setIA (setIidPr (gFsub F (G :&: H))).
Qed.

Lemma pmorphimF : GFunctor.pcontinuous F.
Proof.
move=> gT rT G D f; rewrite -morphimIdom -(setIidPl (gFsub F G)) setICA.
apply: (subset_trans (morphimS f (gFhereditary (subsetIr D G)))).
by rewrite (subset_trans (morphimF F _ _ )) ?morphimIdom ?subsetIl.
Qed.

Lemma gFid gT (G : {group gT}) : F gT (F gT G)  = F gT G.
Proof.
apply/eqP; rewrite eqEsubset gFsub.
by move/gFhereditary: (gFsub F G); rewrite setIid /=.
Qed.

End BasicTheory.

Section Modulo.

Variables (F1 : GFunctor.pmap) (F2 : GFunctor.map).

Lemma gFmod_closed : GFunctor.closed (F1 %% F2).
Proof. by move=> gT G; rewrite sub_cosetpre_quo ?gFsub ?gFnormal. Qed.

Lemma gFmod_cont : GFunctor.continuous (F1 %% F2).
Proof.
move=> gT rT G f; have nF2 := gFnorm F2.
have sDF: G \subset 'dom (coset (F2 _ G)) by rewrite nF2.
have sDFf: G \subset 'dom (coset (F2 _ (f @* G)) \o f).
  by rewrite -sub_morphim_pre ?subsetIl // nF2.
pose K := 'ker (restrm sDFf (coset (F2 _ (f @* G)) \o f)).
have sFK: 'ker (restrm sDF (coset (F2 _ G))) \subset K.
  rewrite {}/K !ker_restrm ker_comp /= subsetI subsetIl !ker_coset /=.
  by rewrite -sub_morphim_pre ?subsetIl // morphimIdom ?morphimF.
have sOF := gFsub F1 (G / F2 _ G); have sGG: G \subset G by [].
rewrite -sub_quotient_pre; last first.
  by apply: subset_trans (nF2 _ _); rewrite morphimS ?gFmod_closed.
suffices im_fact H : F2 _ G \subset gval H -> H \subset G ->
  factm sFK sGG @* (H / F2 _ G) = f @* H / F2 _ (f @* G).
- rewrite -2?im_fact ?gFmod_closed ?gFsub //.
    by rewrite cosetpreK morphimF /= ?morphim_restrm ?setIid.
  by rewrite -sub_quotient_pre ?normG //= trivg_quotient sub1G.
move=> sFH sHG; rewrite -(morphimIdom _ (H / _)) /= {2}morphim_restrm setIid.
rewrite -morphimIG ?ker_coset // -(morphim_restrm sDF) morphim_factm.
by rewrite morphim_restrm morphim_comp -quotientE morphimIdom.
Qed.

Canonical gFmod_igFun := [igFun by gFmod_closed & gFmod_cont].
Canonical gFmod_gFun := [gFun by gFmod_cont].

End Modulo.

Variables F1 F2 : GFunctor.pmap.

Lemma gFmod_hereditary : GFunctor.hereditary (F1 %% F2).
Proof.
move=> gT H G sHG; set FGH := _ :&: H; have nF2H := gFnorm F2 H.
rewrite -sub_quotient_pre; last exact: subset_trans (subsetIr _ _) _.
pose rH := restrm nF2H (coset (F2 _ H)); pose rHM := [morphism of rH].
have rnorm_simpl: rHM @* H = H / F2 _ H by rewrite morphim_restrm setIid.
have nF2G := subset_trans sHG (gFnorm F2 G).
pose rG := restrm nF2G (coset (F2 _ G)); pose rGM := [morphism of rG].
have sqKfK: 'ker rGM \subset 'ker rHM.
  rewrite !ker_restrm !ker_coset (setIidPr (gFsub F2 _)) setIC /=.
  exact: gFhereditary.
have sHH := subxx H; rewrite -rnorm_simpl /= -(morphim_factm sqKfK sHH) /=.
apply: subset_trans (gFcont F1 _); rewrite /= {2}morphim_restrm setIid /=.
apply: subset_trans (morphimS _ (gFhereditary _ (quotientS _ sHG))) => /=.
have ->: FGH / _ = restrm nF2H (coset _) @* FGH.
  by rewrite morphim_restrm setICA setIid.
rewrite -(morphim_factm sqKfK sHH) morphimS //= morphim_restrm -quotientE.
by rewrite setICA setIid (subset_trans (quotientI _ _ _)) // cosetpreK.
Qed.

Canonical gFmod_pgFun := [pgFun by gFmod_hereditary].

End PartialFunctorTheory.

Section MonotonicFunctorTheory.

Implicit Types gT rT : finGroupType.

Lemma gFunctorS (F : GFunctor.mono_map) : GFunctor.monotonic F.
Proof. by case: F. Qed.

Section Composition.

Variables (F1 : GFunctor.mono_map) (F2 : GFunctor.map).

Lemma gFcomp_closed : GFunctor.closed (F1 \o F2).
Proof. by move=> gT G; rewrite !gFsub_trans. Qed.

Lemma gFcomp_cont : GFunctor.continuous (F1 \o F2).
Proof.
move=> gT rT G phi; rewrite (subset_trans (morphimF _ _ (gFsub _ _))) //.
by rewrite (subset_trans (gFunctorS F1 (gFcont F2 phi))).
Qed.

Canonical gFcomp_igFun := [igFun by gFcomp_closed & gFcomp_cont].
Canonical gFcomp_gFun :=[gFun by gFcomp_cont].

End Composition.

Variables F1 F2 : GFunctor.mono_map.

Lemma gFcompS : GFunctor.monotonic (F1 \o F2).
Proof. by move=> gT H G sHG; rewrite !gFunctorS. Qed.

Canonical gFcomp_mgFun := [mgFun by gFcompS].

End MonotonicFunctorTheory.

Section GFunctorExamples.

Implicit Types gT : finGroupType.

Definition idGfun gT := @id {set gT}.

Lemma idGfun_closed : GFunctor.closed idGfun. Proof. by []. Qed.
Lemma idGfun_cont : GFunctor.continuous idGfun. Proof. by []. Qed.
Lemma idGfun_monotonic : GFunctor.monotonic idGfun. Proof. by []. Qed.

Canonical bgFunc_id := [igFun by idGfun_closed & idGfun_cont].
Canonical gFunc_id := [gFun by idGfun_cont].
Canonical mgFunc_id := [mgFun by idGfun_monotonic].

Definition trivGfun gT of {set gT} := [1 gT].

Lemma trivGfun_cont : GFunctor.pcontinuous trivGfun.
Proof. by move=> gT rT D G f; rewrite morphim1. Qed.

Canonical trivGfun_igFun := [igFun by sub1G & trivGfun_cont].
Canonical trivGfun_gFun := [gFun by trivGfun_cont].
Canonical trivGfun_pgFun := [pgFun by trivGfun_cont].

End GFunctorExamples.


Require Import List.

Require Import Logic.Class.Eq.

Require Import Logic.Func.Replace.
Require Import Logic.Func.Composition.

Require Import Logic.List.In.
Require Import Logic.List.Remove.
Require Import Logic.List.Replace.
Require Import Logic.List.Include.
Require Import Logic.List.Coincide.
Require Import Logic.List.InjectiveOn.

Require Import Logic.Lam.Free.
Require Import Logic.Lam.Bound.
Require Import Logic.Lam.Syntax.
Require Import Logic.Lam.Functor.
Require Import Logic.Lam.Variable.
Require Import Logic.Lam.Subformula.

Definition valid (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (t:T v) : Prop :=
    forall (s:T v) (x:v), s <<= t ->
        x :: Fr s -> f x :: Fr (fmap f s).

Arguments valid {v} {w} {e} {e'} _ _.

(* f is valid for t iff it is valid for every sub-term of t                     *)
Lemma valid_sub : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (t:T v),
    valid f t <-> forall (s:T v), s <<= t -> valid f s.
Proof.
    intros v w e e' f t. split.
    - intros H s H1. unfold valid. intros r x H2 H3. apply H.
        + apply Sub_tran with s; assumption.
        + assumption.
    - intros H. apply H. apply Sub_refl.
Qed.

Lemma valid_var : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (x:v),
    valid f (Var x).
Proof.
    unfold valid. intros v w e e' f x s y H1 H2. destruct H1 as [H1|H1].
    - subst. simpl. left. destruct H2 as [H2|H2].
        + subst. reflexivity.
        + inversion H2.
    - inversion H1.
Qed.

Lemma valid_app : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (t1 t2:T v),
    valid f (App t1 t2) <-> valid f t1 /\ valid f t2.
Proof.
    intros v w e e' f t1 t2. split.
    - intros H. split; apply (valid_sub v w e e' f (App t1 t2)).
        + assumption.
        + right. apply in_or_app. left. apply Sub_refl.
        + assumption.
        + right. apply in_or_app. right. apply Sub_refl.
    - intros [H1 H2] s x [H|H].
        + subst. simpl. intros H.
          apply in_or_app. apply in_app_or in H.
          destruct H as [H|H].
            { left.  revert H. apply H1. apply Sub_refl. }
            { right. revert H. apply H2. apply Sub_refl. }
        + apply in_app_or in H. destruct H as [H|H].
            { apply H1. assumption. }
            { apply H2. assumption. }
Qed.

Lemma valid_lam : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (t1:T v) (x:v),
    valid f (Lam x t1) <->
    valid f t1 /\
    forall (y:v), y :: Fr (Lam x t1) -> f x <> f y.
Proof.
    intros v w e e' f t1 x. split.
    - intros H. split.
        + apply (valid_sub v w e e' f (Lam x t1)).
            { assumption. }
            { right. apply Sub_refl. }
        + intros y H1 H2.
            assert (f y :: Fr (fmap f (Lam x t1))) as H3.
                { apply H.
                    { apply Sub_refl. }
                    { assumption. }
                }
            assert (~ f x :: Fr (fmap f (Lam x t1))) as H4.
                { simpl. apply remove_x_gone. }
            apply H4. rewrite H2. assumption.
    - intros [H1 H2] s y H3 H4. destruct H3 as [H3|H3].
        + subst. simpl. apply remove_charac. split.
            { apply H1.
                { apply Sub_refl. }
                { simpl in H4. apply remove_charac in H4.
                  destruct H4. assumption.
                }
            }
            { apply H2. assumption. }
        + apply H1; assumption.
Qed.

(* We cannot follow the set theoretic proof as this is a stronger result,       *)
(* due to the order being preserved in lists. Structural induction on t.        *)
Lemma valid_free : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (t:T v),
    valid f t <-> forall (s:T v), s <<= t -> Fr (fmap f s) = map f (Fr s).
Proof.
    intros v w e e' f t. split.
    - induction t as [x|t1 IH1 t2 IH2|x t1 IH1]; simpl; intros H s H'.
        + destruct H' as [H'|H'].
            { subst. reflexivity. }
            { inversion H'. }
        + destruct H' as [H'|H'].
            { subst. simpl. rewrite map_app. rewrite IH1, IH2.
                { reflexivity. }
                { apply valid_sub with (App t1 t2).
                    { assumption. }
                    { right. apply in_or_app. right. apply Sub_refl. }
                }
                { apply Sub_refl. }
                { apply valid_sub with (App t1 t2).
                    { assumption. }
                    { right. apply in_or_app. left. apply Sub_refl. }
                }
                { apply Sub_refl. }
            }
            { apply in_app_or in H'. destruct H' as [H'|H'].
                { apply IH1.
                    { apply valid_sub with (App t1 t2).
                        { assumption. }
                        { right. apply in_or_app. left. apply Sub_refl. }
                    }
                    { assumption. }
                }
                { apply IH2.
                    { apply valid_sub with (App t1 t2).
                        { assumption. }
                        { right. apply in_or_app. right. apply Sub_refl. }
                    }
                    { assumption. }
                }
            }
        + destruct H' as [H'|H'].
            { subst. simpl. rewrite IH1.
                { apply remove_map. intros y H1 H2 H3.
                    assert (~ f x :: Fr (Lam (f x) (fmap f t1))) as Ex.
                        { simpl. apply remove_x_gone. }
                    assert (f y :: Fr (Lam (f x) (fmap f t1))) as Ey.
                        { unfold valid in H. apply (H (Lam x t1) y).
                            { apply Sub_refl. }
                            { simpl. apply remove_charac. split; assumption. }
                        }
                    rewrite <- H3 in Ey. apply Ex. assumption.
                }
                apply (valid_sub v w e e' f (Lam x t1)).
                    { assumption. }
                    { right. apply Sub_refl. }
                    { apply Sub_refl. }
            }
            { apply IH1.
                { apply (valid_sub v w e e' f (Lam x t1)).
                    { assumption. }
                    { right. apply Sub_refl. }
                }
                { assumption. }
            }
    - induction t as [x|t1 IH1 t2 IH2|x t1 IH1]; simpl; intros H.
        + apply valid_var.
        + apply valid_app. split.
            { apply IH1. intros s H'. apply H. right.
              apply in_or_app. left. assumption. }
            { apply IH2. intros s H'. apply H. right.
              apply in_or_app. right. assumption. }
        + apply valid_lam. split.
            { apply IH1.  intros s H'. apply H. right. assumption. }
            { intros y H1 H2.
              assert (~ f x :: Fr (fmap f (Lam x t1))) as Ex.
                { simpl. apply remove_x_gone. }
              assert (f y :: Fr (fmap f (Lam x t1))) as Ey.
                { rewrite H.
                    { apply in_map_iff. exists y. split.
                        { reflexivity. }
                        { assumption. }}
                    { left. reflexivity. }}
              rewrite <- H2 in Ey. apply Ex. assumption. }
Qed.

Lemma valid_inj : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (t:T v),
    injective_on (var t) f -> valid f t.
Proof.
    intros v w e e' f t H. apply valid_free. intros s H'. apply free_inj.
    apply injective_on_incl with (var t).
    - apply Sub_var. assumption.
    - assumption.
Qed.

Lemma valid_charac : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (t:T v),
    valid f t <-> forall (t1:T v) (x y:v),
        (Lam x t1) <<= t -> y :: Fr (Lam x t1) -> f x <> f y.
Proof.
    intros v w e e' f t. split.
    - intros H t1 x y H1 H2 H3.
      assert (f y :: Fr (fmap f (Lam x t1))) as H4.
        { apply H; assumption. }
      assert (~ f x :: Fr (fmap f (Lam x t1))) as H5.
        { simpl. apply remove_x_gone. }
      rewrite <- H3 in H4. apply H5. assumption.
    - induction t as [z|t1' IH1 t2' IH2|z t1' IH1]; intros H.
        + apply valid_var.
        + apply valid_app. split.
            { apply IH1. intros t1 x y H1. apply H. apply Sub_tran with t1'.
                { assumption. }
                { right. apply in_or_app. left. apply Sub_refl. }
            }
            { apply IH2. intros t1 x y H1. apply H. apply Sub_tran with t2'.
                { assumption. }
                { right. apply in_or_app. right. apply Sub_refl. }
            }
        + apply valid_lam. split.
            { apply IH1. intros t1 x y H1. apply H. apply Sub_tran with t1'.
                { assumption. }
                { right. apply Sub_refl. }
            }
            { intros y H1. apply H with t1'.
                { apply Sub_refl. }
                { assumption. }
            }
Qed.

Lemma valid_replace : forall (v:Type) (e:Eq v) (x y:v) (t:T v),
    ~ y :: var t -> valid (y // x) t.
Proof.
    intros v e x y t H. apply valid_inj. apply replace_inj. assumption.
Qed.

Lemma valid_compose : forall (u v w:Type) (e:Eq u) (e':Eq v) (e'':Eq w),
    forall (f:u -> v) (g:v -> w) (t:T u),
    (valid f t) /\ (valid g (fmap f t)) <-> valid (g;f) t.
Proof.
    intros u v w e e' e'' f g t. split.
    - intros [Hf Hg]. apply valid_free. intros s H.
      rewrite fmap_comp. unfold comp.
      rewrite valid_free in Hg. rewrite Hg.
        + rewrite valid_free in Hf. rewrite Hf.
            { rewrite map_map. reflexivity. }
            { assumption. }
        + rewrite Sub_fmap. apply in_map_iff.
          exists s. split.
            { reflexivity. }
            { assumption. }
    - intros H. assert (valid f t) as H'.
        { revert H. induction t as [x|t1 IH1 t2 IH2|x t1 IH1]; intros H.
            + apply valid_var.
            + apply valid_app. apply valid_app in H. destruct H as [H1 H2]. split.
                { apply IH1. assumption. }
                { apply IH2. assumption. }
            + apply valid_lam. apply valid_lam in H. destruct H as [H1 H2]. split.
                { apply IH1. assumption. }
                { intros y H3 H4. apply (H2 y H3).
                  unfold comp. rewrite H4. reflexivity.
                }
        }
      split.
        + assumption.
        + apply valid_free. intros s' H1.
          rewrite Sub_fmap in H1.
          rewrite in_map_iff in H1. destruct H1 as [s [H1 H2]].
          rewrite <- H1. fold (comp (fmap g) (fmap f) s).
          rewrite <- fmap_comp. rewrite valid_free in H.
          rewrite H.
            { unfold comp. rewrite <- map_map. rewrite valid_free in H'.
              rewrite H'.
                { reflexivity. }
                { assumption. }
            }
            { assumption. }
Qed.

Lemma valid_fmap : forall (v w:Type) (e:Eq v) (e':Eq w) (f g:v -> w) (t:T v),
    (fmap f t) = (fmap g t) -> valid f t -> valid g t.
Proof.
    intros v w e e' f g t H H' s x H1 H2. apply var_support in H.
    assert (f x = g x) as H3.
        { apply (coincide_incl v w f g (var t) (var s)).
            { apply Sub_var. assumption. }
            { assumption. }
            { apply (free_var v e s). assumption. }
        }
    assert (fmap f s = fmap g s) as H4.
        { apply var_support. apply coincide_incl with (var t).
            { apply Sub_var. assumption. }
            { assumption. }
        }
    rewrite <- H3, <- H4. apply H'; assumption.
Qed.

Lemma valid_bnd : forall (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) (t:T v),
    (exists (xs:list v),
        bnd t <= xs /\
        injective_on xs f /\
        (forall (x y:v), x :: xs -> y :: var t -> ~ y :: xs -> f x <> f y))
        -> valid f t.
Proof.
    intros v w e e' f t [xs [H1 [H2 H3]]]. apply valid_charac.
    intros t1 x y H4 H5.
    assert (x :: xs) as H0.
        { apply H1. apply Sub_bnd in H4. apply H4. left. reflexivity. }
    destruct (in_dec eqDec y xs) as [H6|H6].
    - intros H7. simpl in H5. apply remove_charac in H5.
      destruct H5 as [_ H5]. apply H5. apply H2; assumption.
    - apply H3.
        + assumption.
        + apply Sub_var in H4. apply H4. apply (free_var v e). assumption.
        + assumption.
Qed.

(* valid defined as an inductive predicate.                                     *)
Inductive valid' (v w:Type) (e:Eq v) (e':Eq w) (f:v -> w) : T v -> Prop :=
| VVar  : forall (x:v), valid' v w e e' f (Var x)
| VApp  : forall (t1 t2:T v),
    valid' v w e e' f t1 ->
    valid' v w e e' f t2 ->
    valid' v w e e' f (App t1 t2)
| VLam : forall (x:v) (t1:T v),
    valid' v w e e' f t1 ->
    (forall (y:v), y :: Fr (Lam x t1) -> f x <> f y) ->
    valid' v w e e' f (Lam x t1)
.

Arguments valid' {v} {w} {e} {e'}.

Lemma valid_equivalence : forall (v w:Type)(e:Eq v)(e':Eq w)(f:v -> w)(t:T v),
    valid f t <-> valid' f t.
Proof.
    intros v w e e' f t. split.
    - induction t as [x|t1 IH1 t2 IH2|x t1 IH1].
        + intros _. constructor.
        + intros H. apply valid_app in H. destruct H as [H1 H2]. constructor.
            { apply IH1. assumption. }
            { apply IH2. assumption. }
        + intros H. apply valid_lam in H.  destruct H as [H1 H2]. constructor.
            { apply IH1. assumption. }
            { assumption. }
    - intros H. induction H as [x|t1 t2 H1 IH1 H2 IH2|x t1 H1 IH1 H2].
        + apply valid_var.
        + apply valid_app. split; assumption.
        + apply valid_lam. split; assumption.
Qed.


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

(************************************************************************)
(* Copyright 2005 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(************************************************************************)

(* $Id$ *)

(** We start by some general notions for expressing the bijection *)

Definition identity (A:Set) := fun a:A=> a.
Definition compose (A B C:Set) (g:B->C) (f:A->B) := fun a:A=>g(f a).

Section Denumerability.

(** What it means to have the same cardinality *)
Definition same_cardinality (A:Set) (B:Set) := {f:A->B & { g:B->A | (forall b,(compose _ _ _ f g) b= (identity B) b)
                                                                /\ forall a,(compose _ _ _ g f) a = (identity A) a}}.

(** What it means to be a denumerable *)
Definition is_denumerable A := same_cardinality A nat.

Lemma same_cardinality_transitive:forall A B C, same_cardinality A B -> same_cardinality B C -> same_cardinality A C.
Proof.
 intros A B C [f [g [HAB1 HAB2]]] [h [k [HBC1 HBC2]]];
 repeat (match goal with [id1: forall (_:_), compose _ _ _ _ _ _  = identity _ _  |- _ ]=>
                            unfold compose in id1; unfold identity in id1 end);
 exists (compose _ _ _ h f);
 exists (compose _ _ _ g k);
 unfold compose; unfold identity;
 split;
  [ intro c; rewrite (HAB1 (k c))
  | intro a; rewrite (HBC2 (f a))
  ]; trivial.
Defined.

Lemma is_denumerable_transitive:forall A B, is_denumerable A -> same_cardinality B A -> is_denumerable B.
Proof.
 intros A B HA HBA; apply (same_cardinality_transitive B A nat HBA HA).
Defined.

End Denumerability.

(** We first prove that [Z] is denumerable *)

Require Div2.
Require Import ZArith.

(** An injection from [Z] to [nat] *)
Definition Z_to_nat_i (z:Z) :nat :=
   match z with
   | Z0 => O
   | Zpos p => Div2.double (nat_of_P p)
   | Zneg p => pred (Div2.double (nat_of_P p))
   end.

(** Some lemmas about parity. They could be added to [Arith.Div2] *)
Lemma odd_pred2n: forall n : nat, Even.odd n -> {p : nat | n = pred (Div2.double p)}.
Proof.
 intros n H_odd;
 rewrite (Div2.odd_double _ H_odd);
 exists (S (Div2.div2 n));
 generalize (Div2.div2 n);
 clear n H_odd; intros n;
 rewrite Div2.double_S;
 reflexivity.
Defined.

Lemma even_odd_exists_dec:forall n, {p : nat | n = Div2.double p} + {p : nat | n = pred (Div2.double p)}.
Proof.
 intro n;
 destruct (Even.even_odd_dec n) as [H_parity|H_parity];
 [ left; apply (Div2.even_2n _ H_parity)
 | right; apply (odd_pred2n _ H_parity)].
Defined.

(** An injection from [nat] to [Z] *)
Definition nat_to_Z_i (n:nat) :=
  match even_odd_exists_dec n with
  | inl s => let (k, _) := s in Z_of_nat k
  | inr s => let (k, _) := s in Zopp (Z_of_nat k)
  end.

Lemma double_eq_half_eq:forall m n, Div2.double m = Div2.double n -> m =n.
Proof.
 unfold Div2.double; intros m n; omega.
Defined.

Lemma parity_mismatch_not_eq:forall m n, Even.even m -> Even.odd n -> ~m=n.
Proof.
 intros m n H_even H_odd H_eq; subst m;
 apply (Even.not_even_and_odd n); trivial.
Defined.

Lemma even_double:forall n, Even.even (Div2.double n).
Proof.
 intro n;
 unfold Div2.double;
 replace (n + n) with (2*n); auto with arith; omega.
Defined.

Lemma double_S_neq_pred:forall m n, ~Div2.double (S m) = pred (Div2.double n).
Proof.
 intros m [|n].
 unfold Div2.double; omega.
 apply (parity_mismatch_not_eq (Div2.double (S m)) (pred (Div2.double (S n))));
 try apply even_double;
 replace (pred (Div2.double (S n))) with (S (Div2.double n));
 [ constructor; apply even_double
 | unfold Div2.double; omega].
Defined.

Lemma eq_add_pred : forall n m : nat, pred n = pred m -> {n = m} + {n<2/\m<2}.
Proof.
 intros [|[|n]] m;
 simpl;
 intros H;
 try (right; omega);
 left;
 rewrite (f_equal S H);
 symmetry; apply S_pred with 0;
 omega.
Defined.

(** We prove that the maps [Z_to_nat_i] is the right inverse of [nat_to_Z_i].*)

Lemma nat_to_Z_to_nat_i : forall (z:Z), nat_to_Z_i (Z_to_nat_i z) = z.
Proof.
 intros [|p|p];
 unfold nat_to_Z_i.
 simpl;
   case (even_odd_exists_dec 0); intros [k Hk];
     [transitivity (Z_of_nat 0)
       |transitivity (Zopp (Z_of_nat 0))
     ]; trivial;
  try apply (f_equal Zopp);
    apply (f_equal Z_of_nat);
      unfold Div2.double in Hk; omega.

 case (even_odd_exists_dec (Z_to_nat_i (Zpos p)) ); intros [k Hk].
  unfold Z_to_nat_i in Hk;
  rewrite <- (double_eq_half_eq _ _ Hk);
  symmetry; apply Zpos_eq_Z_of_nat_o_nat_of_P.

  apply False_ind;
  unfold Z_to_nat_i in Hk;
  destruct (ZL4 p) as [m Hm];
  rewrite Hm in Hk;
  apply (double_S_neq_pred m k);
  assumption.

 case (even_odd_exists_dec (Z_to_nat_i (Zneg p)) ); intros [k Hk].
  unfold Z_to_nat_i in Hk;
  unfold Div2.double in Hk;
  destruct (ZL4 p) as [m Hm]; omega.

  unfold Z_to_nat_i in Hk;
  case (eq_add_pred _ _ Hk).
   intro Hk';
   rewrite <- (double_eq_half_eq _ _ Hk');
   symmetry;
   apply Zopp_inj;
   rewrite Zopp_neg;
   rewrite Zopp_involutive;
   apply Zpos_eq_Z_of_nat_o_nat_of_P.

   intros [H_nat_p_lt_2 _];
   apply False_ind;
   destruct (ZL4 p) as [m Hm];
   rewrite Hm in H_nat_p_lt_2;
   rewrite Div2.double_S in H_nat_p_lt_2;
   omega.
Defined.

(** We prove that the maps [Z_to_nat_i] is the left inverse of [nat_to_Z_i].*)

Lemma Z_to_nat_to_Z_i : forall (n:nat), Z_to_nat_i (nat_to_Z_i n) = n.
Proof.
 intros [|n];
 unfold nat_to_Z_i.
 case (even_odd_exists_dec 0);
 intros [k Hk];
 transitivity (Z_to_nat_i (Z_of_nat 0)); trivial;
 apply (f_equal Z_to_nat_i);
 simpl; unfold Div2.double in Hk; omega.

 case (even_odd_exists_dec (S n)); intros [[|k] Hk]; rewrite Hk; trivial; simpl;
 [apply (f_equal Div2.double);
  apply nat_of_P_o_P_of_succ_nat_eq_succ
 |transitivity (pred (Div2.double (S k))); trivial;
  apply (f_equal pred);
  apply (f_equal Div2.double);
  apply nat_of_P_o_P_of_succ_nat_eq_succ
 ].
Defined.

(** And hence [Z] is denumerable: *)

Theorem Z_is_denumerable:is_denumerable Z.
Proof.
 exists Z_to_nat_i; exists nat_to_Z_i;
 split;
 [ apply Z_to_nat_to_Z_i
 | apply nat_to_Z_to_nat_i
 ].
Defined.

(** Next we prove that [Q] and [Z] have the same cardinality *)

Require Import Q_field.

(** Here there is not much to prove, as [Z] and [Q] are isomorphic data-types.*)

(** An injection from [positive] to [Qpositive]: *)
Fixpoint positive_to_Qpositive_i (p:positive) : Qpositive :=
   match p with
   | xI p => nR (positive_to_Qpositive_i p)
   | xO p => dL (positive_to_Qpositive_i p)
   | xH => One
   end.

(** An injection from [Z] to [Q] *)
Definition Z_to_Q_i (z:Z) :=
   match z with
   | Z0 => Zero
   | Zpos p => Qpos (positive_to_Qpositive_i p)
   | Zneg p => Qneg (positive_to_Qpositive_i p)
   end.

(** An injection from [Qpositive] to [positive] *)
Fixpoint Qpositive_to_positive_i (qp:Qpositive) : positive :=
   match qp with
   | nR qp => xI (Qpositive_to_positive_i qp)
   | dL qp => xO (Qpositive_to_positive_i qp)
   | One => xH
   end.

(** An injection from [Q] to [Z] *)
Definition Q_to_Z_i (q:Q) :=
   match q with
   | Zero => Z0
   | Qpos qp => Zpos (Qpositive_to_positive_i qp)
   | Qneg qp => Zneg (Qpositive_to_positive_i qp)
   end.

(** Proof that [Qpositive_to_positive_i] is the left inverse of [positive_to_Qpositive_i]:*)
Lemma Qpositive_to_positive_to_Qpositive_i : forall (p:positive), Qpositive_to_positive_i (positive_to_Qpositive_i p) = p.
Proof.
 intros p;
 induction p as [p|p|]; trivial;
 simpl;
 rewrite IHp; trivial.
Defined.

(** Proof that [Qpositive_to_positive_i] is the right inverse of [positive_to_Qpositive_i]:*)
Lemma positive_to_Qpositive_to_positive_i : forall qp, positive_to_Qpositive_i (Qpositive_to_positive_i qp) = qp.
Proof.
 intros p;
 induction p as [p|p|]; trivial;
 simpl;
 rewrite IHp; trivial.
Defined.

(** Proof that [Q_to_Z_i] is the left inverse of [Z_to_Q_i]:*)
Lemma Q_to_Z_to_Q_i : forall (z:Z), Q_to_Z_i (Z_to_Q_i z) = z.
Proof.
 intros [|p|p]; trivial;
 simpl;
 rewrite Qpositive_to_positive_to_Qpositive_i; trivial.
Defined.

(** Proof that [Q_to_Z_i] is the right inverse of [Z_to_Q_i]:*)
Lemma Z_to_Q_to_Z_i : forall (q:Q), Z_to_Q_i (Q_to_Z_i q) = q.
Proof.
 intros [|qp|qp]; trivial;
 simpl;
 rewrite positive_to_Qpositive_to_positive_i; trivial.
Defined.

(** And hence [Q] is denumerable: *)
Theorem Q_is_denumerable: is_denumerable Q.
Proof.
 apply is_denumerable_transitive with Z.
 apply Z_is_denumerable.
 exists Q_to_Z_i; exists Z_to_Q_i;
 split;
 [ apply Q_to_Z_to_Q_i
 | apply Z_to_Q_to_Z_i
 ].
Defined.


Require Import ExtLib.Data.Fun.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require MirrorCore.syms.SymEnv.
Require MirrorCore.syms.SymSum.
Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Simple.
Require Import MirrorCore.Reify.Reify.

Require Import McExamples.Cancel.Monoid.

Set Implicit Arguments.
Set Strict Implicit.

Module Syntax (M : Monoid).

  (** Define the reified language *)
  (********************************)

  (* The syntax of types *)
  Inductive typ : Set :=
  | tyArr : typ -> typ -> typ
  | tyNat | tyM
  | tyProp.

  (* The meaning of types *)
  Fixpoint typD (t : typ) : Type@{Urefl} :=
    match t with
    | tyNat => nat
    | tyM => M.M
    | tyProp => Prop
    | tyArr a b => typD a -> typD b
    end.

  (* The accessibility relation *)
  Inductive tyAcc' : typ -> typ -> Prop :=
  | tyArrL : forall a b, tyAcc' a (tyArr a b)
  | tyArrR : forall a b, tyAcc' b (tyArr a b).

  Definition typ_eq_dec : forall a b : typ, {a = b} + {a <> b}.
  Proof. decide equality. Defined.

  (* Instantiate the RType interface *)
  Instance RType_typ : RType typ := RType_simple typD tyAcc' typ_eq_dec.
  Instance RTypeOk_typ : RTypeOk := RTypeOk_simple _.
  Proof. prove_simple_acc. Defined.

  (* Build instances for describing functions and Prop *)
  Instance Typ2_tyArr : Typ2 RType_typ Fun :=
  { typ2 := tyArr
  ; typ2_cast := fun _ _ => eq_refl
  ; typ2_match T t tr :=
      match t as t return T (typD t) -> T (typD t) with
      | tyArr a b => fun _ => tr a b
      | _ => fun fa => fa
      end }.

  Instance Typ2Ok_tyArr : Typ2Ok Typ2_tyArr.
  Proof. prove_TypOk. Defined.

  Instance Typ0_tyProp : Typ0 RType_typ Prop :=
  { typ0 := tyProp
  ; typ0_cast := eq_refl
  ; typ0_match T t :=
      match t with
      | tyProp => fun tr _ => tr
      | _ => fun _ fa => fa
      end }.

  Instance Typ0Ok_tyProp : Typ0Ok Typ0_tyProp.
  Proof. prove_TypOk. Defined.

  (* The syntax of terms *)
  Inductive func' : Set :=
  | Eq : typ -> func' (* polymorphic equality *)
  | Ex : typ -> func' | All : typ -> func' (* polymorphic quantification *)
  | And | Or | Impl
  | mU | mP | mR
  | NatC : nat -> func'.

  Definition func'_eq_dec : forall a b : func', {a = b} + {a <> b}.
  Proof. decide equality; try eapply typ_eq_dec. decide equality. Defined.

  (* The meaning of symbols *)
  Definition RSym_func' : RSym func'.
  refine (
    RSym_simple
      (fun f => Some
         match f with
         | mU => mkTypedVal tyM M.U
         | mP => mkTypedVal (tyArr tyM (tyArr tyM tyM)) M.P
         | mR => mkTypedVal (tyArr tyM (tyArr tyM tyProp)) M.R
         | Eq t => mkTypedVal (tyArr t (tyArr t tyProp)) (@eq _)
         | And => mkTypedVal (tyArr tyProp (tyArr tyProp tyProp)) and
         | Or => mkTypedVal (tyArr tyProp (tyArr tyProp tyProp)) or
         | Impl => mkTypedVal (tyArr tyProp (tyArr tyProp tyProp)) Basics.impl
         | Ex t => mkTypedVal (tyArr (tyArr t tyProp) tyProp) (@ex _)
         | All t => mkTypedVal (tyArr (tyArr t tyProp) tyProp) _
         | NatC n => mkTypedVal tyNat n
         end)
      func'_eq_dec).
  refine (fun P : _ -> Prop => forall x : typD t, P x).
  Defined.

  Instance RSymOk_func' : RSymOk RSym_func' := _.

  Definition func : Set := sum func' SymEnv.func.

  Instance RSym_func fs : RSym func :=
    SymSum.RSym_sum RSym_func' (@SymEnv.RSym_func _ _ fs).

  Instance RSymOk_func fs : RSymOk (RSym_func fs).
  Proof.
    apply SymSum.RSymOk_sum; eauto with typeclass_instances.
  Qed.

  Definition known (f : func') : expr typ func := Inj (inl f).
  Definition other (f : SymEnv.func) : expr typ func := Inj (inr f).

  (** Reification **)
  (*****************)

  Local Notation "x @ y" := (@RApp x y) (only parsing, at level 30).
  Local Notation "'!!' x" := (@RExact _ x) (only parsing, at level 25).
  Local Notation "'?' n" := (@RGet n RIgnore) (only parsing, at level 25).
  Local Notation "'?!' n" := (@RGet n RConst) (only parsing, at level 25).
  Local Notation "'#'" := RIgnore (only parsing, at level 0).

  (* Declare patterns **)
  Reify Declare Patterns patterns_monoid_typ : typ.
  Reify Declare Patterns patterns_monoid : (expr typ func).

  (* Declare the syntax for the types *)
  Definition reify_monoid_typ' :=
    CPatterns patterns_monoid_typ.
  Reify Declare Syntax reify_monoid_typ :=
    reify_monoid_typ'.

  Reify Declare Typed Table table_terms : BinNums.positive => typ.

  (* Declare syntax **)
  Definition reify_monoid' : Command@{Set} (expr typ func) :=
    CFix
      (CFirst (CPatterns patterns_monoid ::
               CApp (CRec 0) (CRec 0) (@ExprCore.App typ func) ::
               CAbs (CCall reify_monoid_typ) (CRec 0) (@ExprCore.Abs typ func) ::
               CVar (@ExprCore.Var typ func) ::
               CMap other (CTypedTable reify_monoid_typ table_terms) :: nil)).

  Reify Declare Syntax reify_monoid := reify_monoid'.

  (* Pattern rules for reifying types *)
  Reify Pattern patterns_monoid_typ += (@RExact _ nat)  => tyNat.
  Reify Pattern patterns_monoid_typ += (@RExact _ M.M) => tyM.
  Reify Pattern patterns_monoid_typ += (@RExact _ Prop) => tyProp.
  Reify Pattern patterns_monoid_typ += (@RImpl (@RGet 0 RIgnore) (@RGet 1 RIgnore)) => (fun (a b : function (CCall reify_monoid_typ)) => tyArr a b).

  (* Pattern rules for reifying terms *)
  Reify Pattern patterns_monoid += (RHasType nat (RGet 0 RConst)) => (fun n : @id nat => known (NatC n)).
  Reify Pattern patterns_monoid += (@RExact _ M.P) => (known mP).
  Reify Pattern patterns_monoid += (@RExact _ M.U) => (known mU).
  Reify Pattern patterns_monoid += (@RExact _ M.R) => (known mR).
  Reify Pattern patterns_monoid += (RApp (@RExact _ (@eq)) (RGet 0 RIgnore)) =>
  (fun (t : function (CCall reify_monoid_typ)) => Inj (typ:=typ) (Eq t)).
  Reify Pattern patterns_monoid += (RPi (RGet 0 RIgnore) (RGet 1 RIgnore)) =>
    (fun (t : function (CCall reify_monoid_typ)) (b : function (CCall reify_monoid)) => (App (known (All t)) (Abs t b))).
  Reify Pattern patterns_monoid += (@RImpl (@RGet 0 RIgnore) (@RGet 1 RIgnore)) => (fun (a b : function (CCall reify_monoid)) => App (App (known Impl) a) b).

  Global Instance Reify_typ : Reify typ :=
  { reify_scheme := CCall reify_monoid_typ }.

  Global Instance Reify_expr_typ_func : Reify (expr typ func) :=
  { reify_scheme := CCall reify_monoid }.

End Syntax.


(** * Functional model of hash tables *)
Require Import VST.floyd.proofauto.

Definition string := list byte.
Instance EqDec_string: EqDec string := list_eq_dec Byte.eq_dec.

Fixpoint hashfun_aux (h: Z) (s: string) : Z :=
 match s with
 | nil => h
 | c :: s' =>  hashfun_aux ((h * 65599 + Byte.signed c) mod Int.modulus) s'
end.

Definition hashfun (s: string) := hashfun_aux 0 s.

Definition hashtable_contents := list (list (string * Z)).

Definition N := 109.
Lemma N_eq : N = 109.
Proof. reflexivity. Qed.
Hint Rewrite N_eq : rep_omega.
Global Opaque N.

Definition empty_table : hashtable_contents :=
  list_repeat (Z.to_nat N) nil.

Fixpoint list_get (s: string) (al: list (string * Z)) : Z :=
  match al with
 | (k,i) :: al' => if eq_dec s k then i else list_get s al'
 | nil => 0
 end.

Fixpoint list_incr (s: string) (al: list (string * Z)) :  list (string * Z) :=
  match al with
 | (k,i) :: al' => if eq_dec s k
                      then (k, i +1)::al'
                      else (k,i)::list_incr s al'
 | nil => (s, 1)::nil
 end.

Definition hashtable_get  (s: string) (contents: hashtable_contents) : Z :=
  list_get s (Znth (hashfun s mod (Zlength contents)) contents).

Definition hashtable_incr (s: string) (contents: hashtable_contents) : hashtable_contents :=
  let h := hashfun s mod (Zlength contents)
  in let al := Znth h contents
  in upd_Znth h contents (list_incr s al).

Lemma hashfun_inrange: forall s, 0 <= hashfun s <= Int.max_unsigned.
Proof.
  intros s. unfold hashfun. set (n := 0).
  unfold n at 1.
  assert (0 <= n <= Int.max_unsigned) by rep_omega.
  generalize dependent n.
  induction s.
  * (* s = [] *)
     simpl. intros. rep_omega.
  * (* s = .. *)
    simpl. intros.
    apply IHs.
    enough (0 <= (n * 65599 + Byte.signed a) mod Int.modulus < Int.modulus).
    rep_omega.
    apply Z.mod_pos_bound.
    rep_omega.
Qed.

Lemma hashtable_get_unfold:
 forall sigma (cts: list (list (string * Z) * val)),
 hashtable_get sigma (map fst cts) =
  list_get sigma (Znth (hashfun sigma mod (Zlength cts)) (map fst cts)).
Proof.
  unfold hashtable_get.
  intros. rewrite Zlength_map.
  reflexivity.
Qed.

Lemma Zlength_hashtable_incr:
 forall sigma cts,
      0 < Zlength cts ->
      Zlength (hashtable_incr sigma cts) = Zlength cts.
Proof.
  intros. unfold hashtable_incr.
  apply upd_Znth_Zlength. apply Z.mod_pos_bound. auto.
Qed.
Hint Rewrite Zlength_hashtable_incr using list_solve : sublist.

Module Int.
Lemma repr_mod_modulus_eq: forall x,
  Int.repr (x mod Int.modulus) = Int.repr x.
Proof.
  intros. apply unsigned_eq_eq. unfold Int.unsigned. simpl.
  do 2 rewrite Int.Z_mod_modulus_eq.
  apply Z.mod_mod. rep_omega.
Qed.
End Int.

Lemma hashfun_snoc:
  forall sigma h lo i,
    0 <= lo ->
    lo <= i < Zlength sigma ->
  Int.repr (hashfun_aux h (sublist lo (i + 1) sigma)) =
  Int.repr (hashfun_aux h (sublist lo i sigma) * 65599 + Byte.signed (Znth i sigma)).
Proof.
  intros. remember (Z.to_nat (i-lo)) as len.
  assert (0 <= i-lo) by omega.
  apply Z2Nat.id in H1. rewrite <- Heqlen in *. clear Heqlen.
  revert h lo i H H0 H1.
  induction len; intros.
  * (* len = 0 *)
    simpl in H1. assert (i = lo) by omega. subst.
    rewrite sublist_one; try omega.
    rewrite sublist_nil.
    simpl. apply Int.repr_mod_modulus_eq.
  * (* len > 0 *)
    assert (i - lo > 0). { rewrite <- H1. simpl. apply Zgt_pos_0. }
    erewrite sublist_split; [rewrite sublist_one | ..]; auto; try omega.
    erewrite (sublist_split lo); [rewrite (sublist_one lo) | .. ]; auto; try omega.
    simpl. apply IHlen; try rep_omega.
    rewrite Nat2Z.inj_succ in H1. unfold Z.succ in H1. omega.
Qed.

Module Type COUNT_TABLE.
 Parameter table: Type.
 Parameter key : Type.
 Parameter empty: table.
 Parameter get: key -> table -> Z.
 Parameter incr: key -> table -> table.
 Axiom gempty: forall k,   (* get-empty *)
       get k empty = 0.
 Axiom gss: forall k t,      (* get-set-same *)
      get k (incr k t) = 1+(get k t).
 Axiom gso: forall j k t,    (* get-set-other *)
      j <> k -> get j (incr k t) = get j t.
End COUNT_TABLE.

(** This means:  in any [Module] that satisfies this [Module Type],
   there's a type [table] of count-tables,
   and operators [empty], [get], [set] that satisfy the axioms
   [gempty], [gss], and [gso].

  It's easy to make a slow implementation of [COUNT_TABLE], using functions. *)

Module FunTable <: COUNT_TABLE.
 Definition table: Type := nat -> Z.
 Definition key : Type := nat.
 Definition empty: table := fun k => 0.
 Definition get (k: key) (t: table) : Z := t k.
 Definition incr (k: key) (t: table) : table :=
    fun k' => if Nat.eqb k' k then 1 + t k' else t k'.
 Lemma gempty: forall k,  get k empty = 0.
 Proof. auto. Qed.
 Lemma gss: forall k t,  get k (incr k t) = 1+(get k t).
 Proof. intros. unfold incr, get. rewrite Nat.eqb_refl. auto. Qed.
 Lemma gso: forall j k t,  j <> k -> get j (incr k t) = get j t.
 Proof. intros. unfold incr, get. replace (j =? k)%nat with false. auto. symmetry. rewrite Nat.eqb_neq. auto.
Qed.
End FunTable.

(**  Now we make a "fast" implementation using hash tables.  We
  put "fast" in quotes because, unlike the imperative implementation,
 the purely functional implementation takes linear time, not constant time,
 to select the the i'th bucket.  That is, [Znth i al] takes time proportional to [i].
 But that is no problem, because we are not using [hashtable_get] and
 [hashtable_incr] as our real implementation; they are serving as the
 _functional model_ of the fast implementation in C.  *)

Module IntHashTable <: COUNT_TABLE.
 Definition hashtable_invariant (cts: hashtable_contents) : Prop :=
  Zlength cts = N /\
  forall i, 0 <= i < N ->
             list_norepet (map fst (Znth i cts))
             /\ Forall (fun s => hashfun s mod N = i) (map fst (Znth i cts)).
 Definition table := sig hashtable_invariant.
 Definition key := string.

 Lemma empty_invariant: hashtable_invariant empty_table.
 Proof.
  unfold hashtable_invariant.
  split; auto. intros.
  assert (Znth i empty_table = []). { unfold empty_table. apply Znth_list_repeat_inrange; auto. }
  rewrite H0.
  simpl. split; auto. constructor.
 Qed.

 Lemma incr_invariant: forall k cts, hashtable_invariant cts -> hashtable_invariant (hashtable_incr k cts).
 Proof.
  unfold hashtable_invariant. intros.
  destruct H.
  split. rewrite Zlength_hashtable_incr; rep_omega.
  intros. specialize (H0 i H1).
  unfold hashtable_incr.
  set (h := hashfun k mod Zlength cts).
  assert (0 <= h < N). { subst h. rewrite H. apply Z.mod_pos_bound. rep_omega. }
  destruct (i =? h) eqn:Heqb;
    [ apply Z.eqb_eq in Heqb | apply Z.eqb_neq in Heqb ];
    subst;
    [ rewrite upd_Znth_same; try omega | rewrite upd_Znth_diff; try omega ];
    auto.
  assert (In_list_incr: forall s al, In s (map fst (list_incr k al)) -> s = k \/ In s (map fst al)). {
    intros. induction al; simpl in *.
    - destruct H3; auto.
    - destruct a. destruct (EqDec_string k s0) eqn:?; auto.
      inversion H3; auto. apply IHal in H4. destruct H4; auto.
  }
  remember (Znth h cts) as al.
  clear Heqal.
  induction al; simpl.
  - (* al = [] *)
    split.
    (* list_norepet [k] *)
    repeat constructor; auto.
    (* Forall (fun s : string => hashfun s mod N = h) [k] *)
    repeat constructor. subst h. rewrite H. auto.
  - (* al = .. *)
    destruct a. destruct (EqDec_string k s) eqn:?.
    + (* k = s *)
      auto.
    + (* k <> s *)
      simpl. destruct H0. inversion H0. inversion H3.
      split; constructor; auto.
      * intro. apply In_list_incr in H12. destruct H12; auto.
      * eapply proj1. apply IHal. auto.
      * eapply proj2. apply IHal. auto.
 Qed.

 Definition empty : table := exist _ _ empty_invariant.
 Definition get : key -> table -> Z := fun k tbl => hashtable_get k (proj1_sig tbl).
 Definition incr : key -> table -> table :=
       fun k tbl => exist _ _ (incr_invariant k _ (proj2_sig tbl)).

 Theorem gempty: forall k, get k empty = 0.
 Proof.
  intros. unfold get. simpl. unfold empty_table. unfold hashtable_get.
  rewrite Znth_list_repeat_inrange; auto. rewrite Zlength_list_repeat; try rep_omega.
  apply Z.mod_pos_bound; try rep_omega.
 Qed.

 Theorem gss: forall k t,  get k (incr k t) =  1 + (get k t).
 Proof.
  intros. unfold get. simpl.
  remember (proj1_sig t) as ht.
  pose proof (proj2_sig t). rewrite <- Heqht in *. unfold hashtable_invariant in *.
  unfold hashtable_get, hashtable_incr.
  rewrite upd_Znth_Zlength by (apply Z.mod_pos_bound; rep_omega).
  remember (hashfun k mod Zlength ht) as h.
  rewrite upd_Znth_same by (subst h; apply Z.mod_pos_bound; rep_omega).
  remember (Znth h ht) as al.
  clear Heqal Heqh h H Heqht ht t.
  induction al.
  - (* al = [] *)
    simpl. destruct (EqDec_string k k) eqn:?; auto. contradiction.
  - (* al = .. *)
    simpl. destruct a. destruct (EqDec_string k s) eqn:?.
    + (* k = s *)
      subst s. simpl. destruct (EqDec_string k k) eqn:?; auto; try omega. contradiction.
    + (* k <> s *)
      simpl. rewrite Heqs0. auto.
 Qed.

 Theorem gso: forall j k t,    (* get-set-other *)
      j <> k -> get j (incr k t) = get j t.
 Proof.
  intros. unfold get. simpl.
  remember (proj1_sig t) as ht.
  pose proof (proj2_sig t). rewrite <- Heqht in *. unfold hashtable_invariant in *.
  unfold hashtable_get, hashtable_incr.
  rewrite upd_Znth_Zlength by (apply Z.mod_pos_bound; rep_omega).
  remember (hashfun k mod Zlength ht) as h.
  remember (hashfun j mod Zlength ht) as h'.
  destruct (h =? h') eqn:Heqb;
    [ apply Z.eqb_eq in Heqb | apply Z.eqb_neq in Heqb ].
  2: rewrite upd_Znth_diff; auto; subst h; subst h'; apply Z.mod_pos_bound; rep_omega.
  rewrite <- Heqb. rewrite upd_Znth_same by (subst h; apply Z.mod_pos_bound; rep_omega).
  remember (Znth h ht) as al.
  clear Heqal Heqb Heqh Heqh' h h' H0 Heqht ht t.
  induction al.
  - (* al = [] *)
    simpl. destruct (EqDec_string j k) eqn:?; auto. contradiction.
  - (* al = .. *)
    simpl. destruct a. destruct (EqDec_string k s) eqn:?.
    + (* k = s *)
      subst s. simpl. destruct (EqDec_string j k) eqn:?; auto; try omega. contradiction.
    + (* k <> s *)
      simpl. destruct (EqDec_string j s) eqn:?; auto; try omega.
 Qed.

End IntHashTable.


(*
Federal University of Pernambuco
TAES's Project
Professor: Gustavo Carvalho
MSc Student: Iverson Luis Pereira
*)

(*Definicao do modulo Map que especifica elementos relacionados ao mapa e funcoes para gerencia-lo*)
Module Map.

Require Import Arith.
Require Import Vector.
Require Import Bool.
Import VectorNotations.
Require Import List.
Require Import PeanoNat.

(* Tipo para representar coisas presentes em cada celula do mapa
    - Obs representa obstaculos
    - Empty representa celulas vazias
    - Start representa a posicao inicial do robo
    - Final representa a posicao final do robo (opcional no mapa)
    - Unknow utilizado para controle de erro no mapa *)

Inductive Things : Type :=
  | Empty : Things
  | Obs : Things
  | Start : Things
  | Final: Things
  | Unknow : Things.

(*Tipo que representa uma linha do mapa, ou seja, uma lista com os elementos de linha*)

Inductive rowmap : Type :=
  | empty : rowmap
  | c : Things -> rowmap -> rowmap.

Notation "x :: l" := (c x l) (at level 60, right associativity).
Notation "[ x ; .. ; y ]" := (c x .. (c y empty) ..).
Notation "[ ]" := empty.

(* Tipo que representa um mapa completo, isto e, varias listas do tipo rowmap *)
Inductive map: Type :=
  | null : map
  | row : rowmap -> map -> map.

Notation "{ x ; .. ; y }" := (row x .. (row y null) ..).
Notation "{ }" := null.

(* Exemplo da representacao do mapa no RoboMind.
  map:
  AAAAA   A, Q -> Obstacles
  A@  A   @ -> Start position
  A Q A
  AAAAA
 Abaixo um exemplo em coq de um mapa equivalente ao exemplo anterior do RoboMind.
*)

Definition raw_map :=
{
  [Final;Empty;Obs;Obs;Obs];
  [Obs;Start;Empty;Empty;Obs];
  [Obs;Empty;Obs;Empty;Obs];
  [Obs;Obs;Obs;Obs;Obs]
}.

(* Tipos para representar um map_new com x, y e o elemento na posicao*)

Inductive cell : Type :=
  | none: cell
  | pos : nat -> nat -> Things -> cell.

Notation "( x , y , z )" := (pos x y z).

Inductive map_new: Type :=
  | nil : map_new
  | r : cell -> map_new -> map_new.

Inductive map_new2: Type :=
  | nil2 : map_new2
  | p : map_new -> map_new -> map_new2.

Notation "{ x , .. , z }" := (r x .. (r z nil) ..).
Notation "{ }" := nil.

Notation "x !! l" := (r x l)
                     (at level 60, right associativity).
Notation "x !!! l" := (p x l)
                     (at level 60, right associativity).
(* Funcao que processa cada linha do mapa e converte em (x,y,thing) *)
Fixpoint process_line (line : rowmap) (x : nat) (y : nat) : map_new :=
  match line with
    | empty => nil
    (*| Empty :: tail => process_line tail (S x) y*)
    | element :: tail => (x, y, element) !! process_line tail (S x) y
  end.

Fixpoint map2seq (m: map) (y : nat) : map_new :=
  match m with
    | null => { }
    | row line tail => process_line line 0 (S 0)
  end.

Definition init_map (m: map) : map_new2 :=
  match m with
    | null => nil2
    | row line tail => map2seq tail 0 !!! map2seq tail 0
  end.

(*Exemplo de mapa na representação final de coq, as celulas vazias nao sao colocadas, apenas as celulas com objetos *)

Definition map_example :=
{
 (0, 0, Obs), (0, 1, Obs), (0, 2, Obs), (0, 3, Obs), (0, 4, Obs),
 (0, 5, Obs), (0, 6, Obs), (1, 0, Obs), (1, 1, Obs), (1, 2, Obs),
 (1, 3, Obs), (1, 4, Obs), (1, 5, Obs), (1, 6, Obs), (2, 0, Obs),
 (2, 1, Obs), (2, 3, Start), (2, 5, Obs), (2, 6, Obs), (3, 0, Obs),
 (3, 1, Obs), (3, 5, Obs), (3, 6, Obs), (4, 0, Obs), (4, 1, Obs),
 (4, 2, Obs), (4, 4, Obs), (4, 5, Obs), (4, 6, Obs), (5, 0, Obs),
 (5, 1, Obs), (5, 4, Obs), (5, 5, Obs), (5, 6, Obs), (6, 0, Obs),
 (6, 1, Obs), (6, 2, Obs), (6, 4, Obs), (6, 5, Obs), (6, 6, Obs),
 (7, 0, Obs), (7, 1, Obs), (7, 4, Final), (7, 5, Obs), (7, 6, Obs), (8, 0, Obs),
 (8, 1, Obs), (8, 2, Obs), (8, 3, Obs), (8, 4, Obs), (8, 5, Obs),
 (8, 6, Obs), (9, 0, Obs), (9, 1, Obs), (9, 2, Obs), (9, 3, Obs),
 (9, 4, Obs), (9, 5, Obs), (9, 6, Obs)
}.

End Map.

(*Modulo que possui a especificacao dos comandos de ROBO, como movimentacao e verificacao de celulas pelo robo.*)
Module RoboModel.
Require Import PeanoNat.
Local Open Scope nat_scope.
Import Map.

(*Tipo para representar uma lista com tres valores *)
Inductive memory : Type :=
  | mem : nat -> nat -> nat -> memory.

Notation "( x ; y ; o )" := (mem x y o).

(* Funcao que busca a posicao inicial x do robo dado um mapa como entrada*)
Fixpoint get_start_pos_x (m : map_new) : nat :=
  match m with
    | nil => 0
    | r i tail => match i with
                    | none => get_start_pos_x tail
                    | pos x y Start => x
                    | pos x y z => get_start_pos_x tail
                  end
  end.

(* Funcao que busca a posicao inicial y do robo dado um amapa como entrada*)
Fixpoint get_start_pos_y (m : map_new) : nat :=
  match m with
    | nil => 0
    | r i tail => match i with
                    | none => get_start_pos_y tail
                    | pos x y Start => y
                    | pos x y z => get_start_pos_y tail
                  end
  end.

(* Definicoes das posicoes x e y inicial do robo, e 'constantes' para representar as orientacoes possiveis do robo*)

Definition start_x := get_start_pos_x map_example.
Definition start_y := get_start_pos_y map_example.
Definition north : nat := 0.
Definition east :nat := 1.
Definition south :nat := 2.
Definition west :nat := 3.

(*Funcao para verificar igualdade entre dois numeros*)
Fixpoint eqb n m : bool :=
  match n, m with
    | 0, 0 => true
    | 0, S _ => false
    | S _, 0 => false
    | S n', S m' => eqb n' m'
  end.

(* Funcao retorna o objeto presente em determinada posicao x,y do mapa*)
Fixpoint things_at (m: map_new) (x: nat) (y: nat) : Things :=
  match m with
    | nil => Unknow
    | r i tail => match i with
                    | none => things_at tail x y
                    | pos a b thing => if eqb a x then
                                          if eqb b y then thing
                                          else things_at tail x y
                                       else things_at tail x y
                  end
  end.

(* Exemplo utilizando map_example que busca o objeto na posicacao x,y*)
Example things_at_1  :
  things_at map_example 2 3 = Start.
Proof. reflexivity. Qed.
Example things_at_2  :
  things_at map_example 2 5 = Obs.
Proof. reflexivity. Qed.

(* Funcao que procura por objetos na celula a frente do robo dado uma orientacao*)
Definition things_in_front (m : map_new) (x : nat) (y: nat) (o : nat) : Things :=
  match o with
    | 0 => things_at m x (minus y 1)
    | 1  => things_at m (plus x 1) y
    | 2 => things_at m x (plus y 1)
    | _  => things_at m (minus x 1) y
  end.

(* Funcao que retorna true ou false se existe obstaculo na frente do robo*)
Definition member_map (t: Things) : bool :=
  match t with
    | Obs => true
    | _   => false
  end.

(* Espefificacao do comando fronIsObstacle do RoboMind*)
Definition front_is_obstacle (m: map_new) (x : nat) (y: nat) (o : nat) : bool :=
 member_map (things_in_front m x y o).

(* Funcao que busca um elemento da memoria*)
Definition get_element_mem (pos: nat) (mem: memory) : nat :=
  match pos with
    | 1 => match mem with
            | (x;y;o) => x
           end
    | 2 => match mem with
            | (x;y;o) => y
           end
    | _ => match mem with
            | (x;y;o) => o
           end
  end.

(* Funcao que atualiza na memoria a posicao atual x,y do robo quando o comando forward eh executado*)
Fixpoint move_steps (mem: memory) (m: map_new) (n : nat) (i: nat) : memory :=
   match i with
    | O => mem
    | S i' =>
      match n with
        | 0 => mem
        | _ => match mem with
                | (x;y;0) => if front_is_obstacle m x y north then
                                move_steps mem m 0 i'
                             else
                                move_steps (x;(minus y 1);0) m (minus n 1) i'
                | (x;y;1) => if front_is_obstacle m x y 1 then
                                move_steps mem m 0 i'
                             else
                                move_steps ((plus x 1);y;1) m (minus n 1) i'
                | (x;y;2) => if front_is_obstacle m x y 2 then
                                move_steps mem m 0 i'
                             else
                                move_steps (x;(plus y 1);2) m (minus n 1) i'
                | (x;y;_) => if front_is_obstacle m x y 3 then
                                move_steps mem m 0 i'
                             else
                                move_steps ((minus x 1);y;3) m (minus n 1) i'
               end
      end
  end.

(* Especificao do comando forward do RoboMind*)
Definition forward_command (mem: memory) (m: map_new) (n: nat) : memory :=
  move_steps mem m n n.

(*Example: forward(2)
 Quando o robo esta na posicao (2, 3) com orientacao norte (0) entao move 2 celulas para frente e espera-se que esteja posicao (2,2)*)
Example forward_1 :
  forward_command (2;3;0) map_example 2 = (2;2;0).
Proof. reflexivity. Qed.

(* Funcao equivalente ao move_steps, no entanto, atualiza na posicao contraria, pois eh utilizado o backward*)
Fixpoint move_steps_back (mem: memory) (m: map_new) (n : nat) (i: nat) : memory :=
   match i with
    | O => mem
    | S i' =>
      match n with
        | 0 => mem
        | _ => match mem with
                | (x;y;0) => if front_is_obstacle m x y 2 then
                                move_steps_back mem m 0 i'
                             else
                                move_steps_back (x;(plus y 1);0) m (minus n 1) i'
                | (x;y;1) => if front_is_obstacle m x y 3 then
                                move_steps_back mem m 0 i'
                             else
                                move_steps_back ((minus x 1);y;1) m (minus n 1) i'
                | (x;y;2) => if front_is_obstacle m x y 0 then
                                move_steps_back mem m 0 i'
                             else
                                move_steps_back (x;(minus y 1);2) m (minus n 1) i'
                | (x;y;_) => if front_is_obstacle m x y 1 then
                                move_steps_back mem m 0 i'
                             else
                                move_steps_back ((plus x 1);y;3) m (minus n 1) i'
               end
      end
  end.

(* Especificao do comando backward do RoboMind*)
Definition backward_command (mem: memory) (m: map_new) (n: nat) : memory :=
  move_steps_back mem m n n.

(*Example: backward(2)
 Quando o robo esta na posicao (2, 3) com orientacao norte (0) entao move 2 celulas e espera-se que esteja na posicao (2,4)*)
Example backward_1 :
  backward_command (2;3;0) map_example 2 = (2;4;0).
Proof. reflexivity. Qed.

(* Especificacao do comando right que altera a orientacao do robo a direta*)
Definition right_command (mem : memory) : memory :=
  match mem with
    | (x;y;0) => (x;y;1)
    | (x;y;1) => (x;y;2)
    | (x;y;2) => (x;y;3)
    | (x;y;_) => (x;y;0)
  end.

(*Exemplos de provas para chamadas do comando right e o que se espera apos sua execucao, utilizando apenas reflexivity eh suficiente*)
Example right_0 :
  right_command (2;3;north) = (2;3;east).
Proof. reflexivity. Qed.
Example right_1 :
  right_command (2;3;east) = (2;3;south).
Proof. reflexivity. Qed.
Example right_2 :
  right_command (2;3;south) = (2;3;west).
Proof. reflexivity. Qed.
Example right_3 :
  right_command (2;3;west) = (2;3;north).
Proof. reflexivity. Qed.

(* Especificacao do comando left que altera a orientacao do robo a esquerda*)
Definition left_command (mem : memory) : memory :=
  match mem with
    | (x;y;0) => (x;y;3)
    | (x;y;1) => (x;y;0)
    | (x;y;2) => (x;y;1)
    | (x;y;_) => (x;y;2)
  end.

(*Exemplos de provas para chamadas do comando left e o que se espera apos sua execucao, utilizando apenas reflexivity eh suficiente*)
Example left_0 :
  left_command (2;3;north) = (2;3;west).
Proof. reflexivity. Qed.
Example left_1 :
  left_command (2;3;east) = (2;3;north).
Proof. reflexivity. Qed.
Example left_2 :
  left_command (2;3;south) = (2;3;east).
Proof. reflexivity. Qed.
Example left_3 :
  left_command (2;3;west) = (2;3;south).
Proof. reflexivity. Qed.

End RoboModel.

(*Modulo para representar uma execucao de um programa e sua verificacao*)
Module Program.

Import Map.
Import RoboModel.

(* Tipo para representar os possiveis comandos utilizaveis no programa*)
Inductive Command: Type :=
  | forward : nat -> Command
  | backward : nat -> Command
  | right : Command
  | left : Command.

(* Tipo para representar um programa, isto e, uma lista de comandos com um fim de arquivo*)
Inductive Program : Type :=
  | EOF : Program
  | c : Command -> Program -> Program.

Notation "c1 ;; c2" :=
  (c c1 c2) (at level 80, right associativity).

(*Tipo para representar atributos do robo quando o programa termina sua execucao (pos final x, pos final y, orientacao final)*)
Inductive result : Type :=
  | res : nat -> nat -> nat -> result.

Notation "( x & y & o )" := (res x y o).

(*Exemplo de definicao de um programa*)
Definition example_program1 :=
  forward 1;;
  backward 2;;
  forward 1;;
  right;;
  left;;
  EOF.

(* Funcao que retorna a quantidade de comandos de um programa*)
Fixpoint length_commands (p: Program) : nat :=
  match p with
    | EOF => O
    | fst ;; tail => S (length_commands tail)
  end.

(* Funcao para leitura e execucao do programa, le cada comando individuamente e atualiza a memoria a cada chamada dos comandos*)
Fixpoint read_program (p: Program) (m: map_new) (mem: memory): memory :=
  match p with
    | EOF => mem
    | c c1 tail => match c1 with
                    | forward n  => read_program tail m (forward_command mem m n)
                    | backward n => read_program tail m (backward_command mem m n)
                    | right      => read_program tail m (right_command mem)
                    | left       => read_program tail m (left_command mem)
                  end
  end.

(* Funcao que inicia o programa, retornando o resultado final apos a execucao da leitura do programa *)
Definition start_program (p: Program) (m: map_new) (mem: memory) : result :=
  match read_program p m mem with
    | (x;y;o) => (x & y & o)
  end.

(*sample of program ROBO*)
Definition example :=
  right;;
  forward 3;;
  backward 1;;
  EOF.

Example teste_map_example_program_example :
  start_program example map_example ( (get_start_pos_x map_example); (get_start_pos_y map_example); north ) = (4 & 3 & east).
Proof. reflexivity. Qed.

(* Exemplo de mapa *)
Definition map1 :=
{
 (0, 0, Obs), (0, 1, Obs), (0, 2, Obs), (0, 3, Obs), (0, 4, Obs),
 (0, 5, Obs), (0, 6, Obs), (1, 0, Obs), (1, 1, Obs), (1, 2, Obs),
 (1, 3, Obs), (1, 4, Obs), (1, 5, Obs), (1, 6, Obs), (2, 0, Obs),
 (2, 1, Obs), (2, 3, Start), (2, 5, Obs), (2, 6, Obs), (3, 0, Obs),
 (3, 1, Obs), (3, 5, Obs), (3, 6, Obs), (4, 0, Obs), (4, 1, Obs),
 (4, 2, Obs), (4, 4, Obs), (4, 5, Obs), (4, 6, Obs), (5, 0, Obs),
 (5, 1, Obs), (5, 4, Obs), (5, 5, Obs), (5, 6, Obs), (6, 0, Obs),
 (6, 1, Obs), (6, 2, Obs), (6, 4, Obs), (6, 5, Obs), (6, 6, Obs),
 (7, 0, Obs), (7, 1, Obs), (7, 5, Obs), (7, 6, Obs), (8, 0, Obs),
 (8, 1, Obs), (8, 2, Obs), (8, 3, Obs), (8, 4, Obs), (8, 5, Obs),
 (8, 6, Obs), (9, 0, Obs), (9, 1, Obs), (9, 2, Obs), (9, 3, Obs),
 (9, 4, Obs), (9, 5, Obs), (9, 6, Obs)
}.

(*Exemplo de programas*)
Definition program1 :=
  right;;
  forward 3;;
  left;;
  forward 1;;
  EOF.

Definition program2 :=
  right;;
  forward 5;;
  EOF.

(*Iniciando memoria com dados do robo, lembrando que a orientacao do robo no RoboMind sempre comeca no norte*)
Definition init_memory := ( (get_start_pos_x map1); (get_start_pos_y map1); north ).

(*Exemplos de definicoes de objetivos para as provas*)
Definition goal1 := (5 & 2 & north).
Definition goal2 := (7 & 3 & east).

(* Exemplos de prova para um programa e mapa, verifica dado um objetivo (posicao final e orientacao) se o retorno
da execucao do programa e igual, sendo assim, bastando utiliza reflexivity para provar*)
Example program1_map1:
 start_program program1 map1 init_memory = goal1.
Proof. reflexivity. Qed.

Example program2_map1:
 start_program program2 map1 init_memory = goal2.
Proof. reflexivity. Qed.

End Program.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e389m21_15limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job prosa.classic.model.priority.
Require Import prosa.classic.model.schedule.global.workload.
Require Import prosa.classic.model.schedule.global.basic.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module Interference.

  Import Schedule ScheduleOfSporadicTask Priority Workload.

  Section InterferenceDefs.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Assume any job arrival sequence...*)
    Variable arr_seq: arrival_sequence Job.

    (* ... and any schedule. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    (* Consider any job j that incurs interference. *)
    Variable j: Job.

    (* Recall the definition of backlogged (pending and not scheduled). *)
    Let job_is_backlogged (t: time) :=
      backlogged job_arrival job_cost sched j t.

    (* First, we define total interference. *)
    Section TotalInterference.

      (* The total interference incurred by job j during [t1, t2) is the
         cumulative time in which j is backlogged in this interval. *)
      Definition total_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2) job_is_backlogged t.

    End TotalInterference.

    (* Next, we define job interference. *)
    Section JobInterference.

      (* Let job_other be a job that interferes with j. *)
      Variable job_other: Job.

      (* The interference caused by job_other during [t1, t2) is the cumulative
         time in which j is backlogged while job_other is scheduled. *)
      Definition job_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2)
          \sum_(cpu < num_cpus)
            (job_is_backlogged t && scheduled_on sched job_other cpu t).

    End JobInterference.

    (* Next, we define task interference. *)
    Section TaskInterference.

      (* In order to define task interference, consider any interfering task tsk_other. *)
      Variable tsk_other: sporadic_task.

      (* The interference caused by tsk during [t1, t2) is the cumulative time
         in which j is backlogged while tsk is scheduled. *)
      Definition task_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2)
          \sum_(cpu < num_cpus)
            (job_is_backlogged t &&
            task_scheduled_on job_task sched tsk_other cpu t).

    End TaskInterference.

    (* Next, we define an approximation of the total interference based on
       each per-task interference. *)
    Section TaskInterferenceJobList.

      Variable tsk_other: sporadic_task.

      Definition task_interference_joblist (t1 t2: time) :=
        \sum_(j <- jobs_scheduled_between sched t1 t2 | job_task j == tsk_other)
         job_interference j t1 t2.

    End TaskInterferenceJobList.

    (* Now we prove some basic lemmas about interference. *)
    Section BasicLemmas.

      (* First, we show that the total interference cannot be larger than the interval length. *)
      Lemma total_interference_le_delta :
        forall t1 t2,
          total_interference t1 t2 <= t2 - t1.
      Proof.
        unfold total_interference; intros t1 t2.
        apply leq_trans with (n := \sum_(t1 <= t < t2) 1);
          first by apply leq_sum; ins; apply leq_b1.
        by rewrite big_const_nat iter_addn mul1n addn0 leqnn.
      Qed.

      (* Next, we show that job interference is bounded by the service of the interfering job. *)
      Lemma job_interference_le_service :
        forall j_other t1 t2,
          job_interference j_other t1 t2 <= service_during sched j_other t1 t2.
      Proof.
        intros j_other t1 t2; unfold job_interference, service_during.
        apply leq_sum; intros t _.
        unfold service_at; rewrite [\sum_(_ < _ | scheduled_on _ _ _  _)_]big_mkcond.
        apply leq_sum; intros cpu _.
        destruct (job_is_backlogged t); [rewrite andTb | by rewrite andFb].
        by destruct (scheduled_on sched j_other cpu t).
      Qed.

      (* We also prove that task interference is bounded by the workload of the interfering task. *)
      Lemma task_interference_le_workload :
        forall tsk t1 t2,
          task_interference tsk t1 t2 <= workload job_task sched tsk t1 t2.
      Proof.
        unfold task_interference, workload; intros tsk t1 t2.
        apply leq_sum; intros t _.
        apply leq_sum; intros cpu _.
        destruct (job_is_backlogged t); [rewrite andTb | by rewrite andFb].
        unfold task_scheduled_on, service_of_task.
        by destruct (sched cpu t).
      Qed.

    End BasicLemmas.

    (* Now we prove some bounds on interference for sequential jobs. *)
    Section InterferenceSequentialJobs.

      (* If jobs are sequential, ... *)
      Hypothesis H_sequential_jobs: sequential_jobs sched.

      (* ... then the interference incurred by a job in an interval
         of length delta is at most delta. *)
      Lemma job_interference_le_delta :
        forall j_other t1 delta,
          job_interference j_other t1 (t1 + delta) <= delta.
      Proof.
        rename H_sequential_jobs into SEQ.
        unfold job_interference, sequential_jobs in *.
        intros j_other t1 delta.
        apply leq_trans with (n := \sum_(t1 <= t < t1 + delta) 1);
          last by rewrite big_const_nat iter_addn mul1n addn0 addKn leqnn.
        apply leq_sum; intros t _.
        destruct ([exists cpu, scheduled_on sched j_other cpu t]) eqn:EX.
        {
          move: EX => /existsP [cpu SCHED].
          rewrite (bigD1 cpu) // /=.
          rewrite big_mkcond (eq_bigr (fun x => 0)) /=;
            first by simpl_sum_const; rewrite leq_b1.
          intros cpu' _; des_if_goal; last by done.
          destruct (scheduled_on sched j_other cpu' t) eqn:SCHED'; last by rewrite andbF.
          move: SCHED SCHED' => /eqP SCHED /eqP SCHED'.
          by specialize (SEQ j_other t cpu cpu' SCHED SCHED'); rewrite SEQ in Heq.
        }
        {
          apply negbT in EX; rewrite negb_exists in EX.
          move: EX => /forallP EX.
          rewrite (eq_bigr (fun x => 0)); first by simpl_sum_const.
          by intros cpu _; specialize (EX cpu); apply negbTE in EX; rewrite EX andbF.
        }
      Qed.

    End InterferenceSequentialJobs.

    (* Next, we show that the cumulative per-task interference bounds the total
       interference. *)
    Section BoundUsingPerJobInterference.

      Lemma interference_le_interference_joblist :
        forall tsk t1 t2,
          task_interference tsk t1 t2 <= task_interference_joblist tsk t1 t2.
      Proof.
        intros tsk t1 t2.
        unfold task_interference, task_interference_joblist, job_interference, job_is_backlogged.
        rewrite [\sum_(_ <- _ sched _ _ | _) _]exchange_big /=.
        rewrite big_nat_cond [\sum_(_ <= _ < _ | true) _]big_nat_cond.
        apply leq_sum; move => t /andP [LEt _].
        rewrite exchange_big /=.
        apply leq_sum; intros cpu _.
        destruct (backlogged job_arrival job_cost sched j t) eqn:BACK;
          last by rewrite andFb (eq_bigr (fun x => 0));
            first by rewrite big_const_seq iter_addn mul0n addn0.
        rewrite andTb.
        destruct (task_scheduled_on job_task sched tsk cpu t) eqn:SCHED; last by done.
        unfold scheduled_on, task_scheduled_on in *.
        destruct (sched cpu t) as [j' |] eqn:SOME; last by done.
        rewrite big_mkcond /= (bigD1_seq j') /=; last by apply undup_uniq.
        {
          by rewrite SCHED eq_refl.
        }
        {
          unfold jobs_scheduled_between.
          rewrite mem_undup; apply mem_bigcat_nat with (j := t); first by done.
          apply mem_bigcat_ord with (j := cpu); first by apply ltn_ord.
          by unfold make_sequence; rewrite SOME mem_seq1 eq_refl.
        }
      Qed.

    End BoundUsingPerJobInterference.

  End InterferenceDefs.

End Interference.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Record graph := mkGraph
  { T :> finType
  ; e : rel T
  ; active : {set T}}.

Section basics.
  Variable g : graph.

  Definition rem (s : {set g}) : graph :=
    mkGraph
      [rel y z : g | if (y \in s) || (z \in s) then false else e y z]
      (active g :\: s).

  Definition ind :=
    [pred s : {set g} | [forall x in s, forall y in s, ~~e x y]].

  Lemma indP (s : {set g}) :
    reflect (forall x y, x \in s -> y \in s -> ~e x y) (ind s).
  Proof.
    case H: (ind s); constructor.
    { move=> x y H0 H1 H2.
      move: (forallP H); move/(_ x)/implyP/(_ H0)/forallP/(_ y)/implyP/(_ H1).
        by rewrite H2. }
    have H0: negb (ind s) by rewrite H.
    clear H; rewrite negb_forall in H0; case: (existsP H0)=> x.
    rewrite negb_imply; case/andP=> H1.
    rewrite negb_forall; case/existsP=> y.
    rewrite negb_imply; case/andP=> H2; move/negbNE=> H3 H4.
    by move: (H4 x y H1 H2).
  Qed.

  Definition mis :=
    [pred s : {set g} |
     [&& ind s
      & [forall x, (x \notin s) ==> (x \in active g) ==> ~~ind (x |: s)]]].

  Lemma mis_ind s : mis s -> ind s.
  Proof. by case/andP. Qed.

  Lemma misP (s : {set g}) :
    reflect [/\ ind s & forall x, x \notin s -> x \in active g -> ~ind (x |: s)]
            (mis s).
  Proof.
    case H: (mis s); constructor.
    { split; first by apply: mis_ind.
      move=> x H2 H3; case: (andP H)=> H4; move/forallP/(_ x).
      by move/implyP/(_ H2)/implyP/(_ H3)/negP. }
    have H0: ~~ mis s by rewrite H.
    move=> []H1 H2; rewrite negb_and in H0; case: (orP H0); first by rewrite H1.
    move/forallP; apply=> x; apply/implyP=> H3; apply/implyP=> H4.
    by apply/negP; apply: H2.
  Qed.

  Definition neighborhood (x : g) := x |: [set y | e x y].

  Lemma neighborhoodP x y : reflect (x = y \/ e x y) (y \in neighborhood x).
  Proof.
    case H: (y \in neighborhood x); constructor.
    { move: H; rewrite /neighborhood in_setU1; case/orP.
      by case/eqP=> ->; left.
      by rewrite in_set=> H; right. }
    move=> H2; move: H; rewrite /neighborhood in_set; case: H2.
    { by move=> ->; rewrite in_set1 eq_refl. }
    by move=> H; rewrite in_set H orbC.
  Qed.
End basics.

Section mis_lems.
  Variable g : graph.
  Hypothesis esym : forall x y, e (g:=g) x y -> e (g:=g) y x.
  Hypothesis eirrefl : forall x, ~e (g:=g) x x.

  Lemma m_neigh_in x (s : {set g}) :
    mis g s -> x \in s -> mis (rem (neighborhood x)) (s :\: neighborhood x).
  Proof.
    case/misP; move/indP=> H0 H1 H2; apply/misP; split.
    { apply/indP=> y z H3 H4 H5.
      rewrite in_setD in H3; case: (andP H3)=> Hx Hy. clear H3.
      rewrite in_setD in H4; case: (andP H4)=> Hz Hw. clear H4.
      apply: (H0 y z)=> //; move: H5=> /=; move: Hx Hz.
      case: (_ \in _)=> //.
      case: (_ \in _)=> //. }
    move=> y H3 H4; move/indP=> H5.
    have H6: y \in active g.
    { by move: H4; rewrite /active /= in_setD; case/andP. }
    case H7: (y \in neighborhood (g:=g) x).
    { by move: H4; rewrite /active /=; rewrite in_setD H7. }
    have H8: y \notin s.
    { by rewrite in_setD H7 /= in H3. }
    apply: (H1 y)=> //; apply/indP=> z w H9 H10.
    rewrite in_setU1 in H9; rewrite in_setU1 in H10=> H11; case: (orP H9).
    { move/eqP=> e; subst z; case: (orP H10).
      { by move/eqP=> e; subst w; apply: (eirrefl H11). }
      move=> H12; case: (neighborhoodP x w).
      { case=> H13.
        { subst w; move: H7; case: (neighborhoodP x y)=> //.
          by move=> H13 _; apply: H13; right; apply: esym. }
        apply: (H0 x w)=> //. }
      move=> H13.
      apply: (H5 y w); first by rewrite in_setU1 eq_refl.
      rewrite in_setU1; apply/orP; right.
      rewrite in_setD; apply/andP; split=> //.
      by case: (neighborhoodP x w).
        by rewrite /rem /= H7 /=; case: (neighborhoodP x w). }
    move=> H12; case: (orP H10).
    { move/eqP=> H13; subst w; case: (neighborhoodP x z).
      { case.
        { move=> H13; subst z.
          move: H7; case: (neighborhoodP x y)=> // H13 _.
          by apply: H13; right. }
        by move=> H13; apply: (H0 x z). }
      move=> H13; apply: (H5 y z).
      by rewrite in_setU1; apply/orP; left.
      rewrite in_setU1; apply/orP; right; rewrite in_setD.
      apply/andP; split=> //; first by case: (neighborhoodP x z).
      rewrite /rem /= H7 /=; case: (neighborhoodP x z)=> //.
      by move=> _; apply: esym. }
    move=> H13; case: (neighborhoodP x w).
    { case=> H14; first by by subst w; apply: (H0 z x).
      by apply: (H0 x w). }
    move=> H14; case: (neighborhoodP x z).
    { case=> H15; first by subst z; apply: (H0 x w).
      by apply: (H0 x z). }
    move=> H15; apply: (H5 z w).
    rewrite in_setU1; apply/orP; right; rewrite in_setD.
    apply/andP; split=> //; first by case: (neighborhoodP x z).
    rewrite in_setU1; apply/orP; right; rewrite in_setD.
    apply/andP; split=> //; first by case: (neighborhoodP x w).
    rewrite /rem /=; case: (neighborhoodP x z)=> //.
    by case: (neighborhoodP x w).
  Qed.

  Lemma m_neigh_nin x (s : {set g}) :
    mis g s -> x \notin s -> mis (rem (set1 x)) s.
  Proof.
    case/misP; move/indP=> H0 H1 H2; apply/misP; split.
    { apply/indP=> y z H5 H6 H7.
      apply: (H0 y z)=> //.
      move: H7; rewrite /rem /= 2!in_set1.
      by case: (y == x)=> //; case: (z == x). }
    move=> y; rewrite in_setD1; move/negP=> H3 H4; move/indP=> H5.
    case H6: (y == x).
    { move: (eqP H6)=> eq; subst y; clear H6.
      by move: H4; rewrite /rem /= eq_refl. }
    case H7: (y \in s); first by apply: H3.
    apply: (H1 y); first by rewrite H7.
    { by move: H4; rewrite /rem /=; case/andP. }
    apply/indP => z w; rewrite !in_setU1 => H8 H9 H10.
    case: (orP H8).
    { move/eqP => e; subst y.
      case: (orP H9); first by move/eqP=> e; subst w; apply: (eirrefl H10).
      move=> H11; case H12: (w == x).
      { by move: (eqP H12)=> e; subst w; rewrite H11 in H2. }
      apply: (H5 z w); first by rewrite in_setU1; apply/orP; left.
      by rewrite in_setU1; apply/orP; right.
      by rewrite /rem /= !in_set1 H6 H12. }
    move=> H11; case: (orP H9).
    { move/eqP => e; subst w; case H12: (z == x).
      { by move: (eqP H12) => e; subst z; rewrite H11 in H2. }
      apply: (H5 z y); first by rewrite in_setU1; apply/orP; right.
      by rewrite in_setU1; apply/orP; left.
      by rewrite /rem /= !in_set1 H12 H6. }
    by move=> H12; apply: (H0 z w).
  Qed.

  Lemma m_neighborhood x :
    #|mis g| <= #|mis (rem (set1 x))| + #|mis (rem (g:=g) (neighborhood x))|.
  Proof.
    have H: forall s,
      mis g s ->
      (x \notin s /\ mis (rem (set1 x)) s) \/
      (x \in s /\ mis (rem (g:=g) (neighborhood x)) (s :\: neighborhood x)).
    { move=> s H; case H1: (x \in s).
      by right; split=> //; apply: m_neigh_in.
      by left; split=> //; apply: m_neigh_nin=> //; rewrite H1. }
  Admitted.
End mis_lems.


Require Import StateMachines.Preliminaries.
Import ListNotations.
Require Import StateMachines.Concepts.

Definition mover := mkMachine bool nat
                              (fun s i => match i with true  => s
                                                     | false => S s end) _.

Compute run mover 0 [true; false; true; true; false].

Definition even : Acceptor
:= mkAcceptor mover
              (fix f s := match s with
                          | 0    => True
                          | S s' => match s' with 0     => False
                                                | S s'' => f s'' end
                          end).

Compute acceptable even 0 [true; false; true; false; true].
Compute acceptable even 0 [true; false; true; false; false; true].

Inductive rgb : Set :=
| red : rgb
| green : rgb
| blue : rgb.

Instance rgb_fin_cert : Finitary rgb.
Admitted.