(************************************************************************************)
(**                                                                                *)
(**                             The DatalogCert Library                             *)
(**                                                                                *)
(**             CNRS & Université Paris-Sud, Université Paris-Saclay                *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Original authors: Véronique Benzaken                                    *)
(**                           Évelyne Contejean                                     *)
(**                           Stefania Dumbrava                                     *)
(**                                                                                *)
(************************************************************************************)

(** This is the first part of the original file "pengine.v" with some modifications *)

From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun choice fintype.
From mathcomp
Require Import tuple finset bigop finfun.

Require Import bigop_aux.
Require Import utils.
(** Added *)
Require Import finseqs.

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

(** * Standard Datalog in Coq

We define the *syntax* and *model-theoretic semantics*, as well as a bottom-up fixpoint evaluation
engine, for standard Datalog. The syntactic primitives of the language are terms (constants or variables),
atoms, clauses and programs. Semantically, *interpretations* (ground atom sets) are the main building blocks.
The bottom-up engine iteratively extends an initial seed substitution into one that matches all clause body atoms to an
existing interpretations (candidate model) and provably grounds the corresponding clause head, i.e, instantiates all of
its variables. To ease the proof-engineering effort, we distinguish between ground and non-ground constructs.
As such, we define corresponding separate types, both for the language primitives and for substitutions (we call
grounding substitutions "groundings"). *)

(** maximal number of program variables *)
Parameter n : nat.

(** program signature: constants and symbols as finite types and arities as finitely-supported functions *)
Parameter constype : finType.
Parameter symtype : finType.
Parameter arity : {ffun symtype -> nat}.

(** ** Hypothesis added for the development *)
(** max size for rule bodies *)
Parameter bn : nat.

(** ** Predicate kinds *)
(** Kind of a predicate. A predicate is either extensional or intensional *)
Inductive pred_type := Edb | Idb.

(** Decidable equality on pred kind *)
Definition pred_type_eq (x y : pred_type) := match x,y with
  | Edb,Edb | Idb,Idb => true
  | _,_ => false end.

(** pred_type_eq is an equality *)
Lemma pred_type_eq_axiom : Equality.axiom pred_type_eq.
Proof.
by case ; case ; apply Bool.iff_reflect ; split.
Qed.

(** From which we derive an Equality mixin *)
Definition pred_type_eqMixin := EqMixin pred_type_eq_axiom.

Canonical pred_type_eqType := Eval hnf in EqType pred_type pred_type_eqMixin.

(** Predicate symbols have a kind *)
Parameter predtype : {ffun symtype -> pred_type}.

(** ** Constants *)
(** A constant *)
Inductive constant := C of constype.
(** Extract the value of a constant*)
Definition of_constant c := let: C c := c in c.

(** instances for the type of constants *)
Canonical cons_subType := Eval hnf in [newType for of_constant].
Canonical cons_eqType := Eval hnf in EqType _ [eqMixin of constant by <: ].
Canonical cons_choiceType := Eval hnf in ChoiceType _ [choiceMixin of constant by <:].
Canonical cons_countType := Eval hnf in CountType _ [countMixin of constant by <:].
Canonical cons_subCountType := Eval hnf in [subCountType of constant].
Canonical cons_finType := Eval hnf in FinType _ [finMixin of constant by <:].
Canonical cons_subFinType := Eval hnf in [subFinType of constant].
Canonical cons_optionFinType := option_finType cons_finType.

Coercion opt_constant (c : option constant) : (option_finType cons_finType) := c.

(** ** Ground raw atoms *)
(** "raw" ground atoms pack a symbol and an argument list of constants *)
Inductive raw_gatom := RawGAtom of symtype & seq constant.

(** extractors for the corresponding symbols and arguments of a "raw" ground atom *)
Definition sym_gatom ga := let: RawGAtom s_ga _ := ga in s_ga.
Definition arg_gatom ga := let: RawGAtom _ arg_ga := ga in arg_ga.

Lemma gatom_eta ga : ga = RawGAtom (sym_gatom ga) (arg_gatom ga).
Proof. by case: ga. Qed.

(** *** Ground Atom Instances *)
(** Ground raw atoms are a finite type *)
Section RawGAtomInstances.

(** packing and unpacking of a "raw" ground atom; needed for the canonical inference of its instances *)
Definition raw_gatom_rep l := let: RawGAtom s a := l in (s, a).
Definition raw_gatom_pre l := let: (s, a) := l in RawGAtom s a.

(** cancelation lemma for "raw" ground atoms *)
Lemma raw_gatom_repK : cancel raw_gatom_rep raw_gatom_pre.
Proof. by case. Qed.

(** "raw" ground atom instances *)
Canonical raw_gatom_eqType :=
  Eval hnf in EqType raw_gatom (CanEqMixin raw_gatom_repK).

Canonical raw_gatom_choiceType :=
  Eval hnf in ChoiceType raw_gatom (CanChoiceMixin raw_gatom_repK).

Canonical raw_gatom_countType :=
  Eval hnf in CountType raw_gatom (CanCountMixin raw_gatom_repK).

End RawGAtomInstances.

(** ** Ground Atoms:
A ground atom [gatom] packs a "raw" ground atom and a boolean well-formedness condition *)

(** ground atom well-formedness condition: argument size and symbol arity have to match *)
Definition wf_gatom ga := size (arg_gatom ga) == arity (sym_gatom ga).

(** ground atom record *)
Structure gatom : Type := GAtom {uga :> raw_gatom; _ : wf_gatom uga}.

(** ground atom instances *)
Canonical gatom_subType := Eval hnf in [subType for uga].
Canonical gatom_eqType := Eval hnf in EqType _ [eqMixin of gatom by <:].
Canonical gatom_choiceType := Eval hnf in ChoiceType _ [choiceMixin of gatom by <:].
Canonical gatom_countType := Eval hnf in CountType _ [countMixin of gatom by <:].
Canonical gatom_subCountType := Eval hnf in [subCountType of gatom].

(** Gives back the arguments of the atom as a tuple of the right length
   using the well formedness constraint *)
Definition arg_wf_gatom (a : gatom) : ((arity (sym_gatom a)).-tuple constant).
destruct a as [a Ha]. simpl.
rewrite <- (eqP Ha).
apply (in_tuple (arg_gatom a)).
Defined.

(** Given an i smaller than the arity gives back the ith argument *)
Definition nth_cons (a : gatom) (i : 'I_(arity (sym_gatom a))) : constant :=
  tnth (arg_wf_gatom a) i.

(** maximal symbol arity *)
Notation max_ar := (\max_(s in symtype) arity s).

Lemma max_ar_bound y : arity y < max_ar.+1.
Proof. exact/leq_bigmax_cond. Qed.

(** Ground atoms are a finite type (uses the max arity) *)
Section GatomFinType.

(** corresponding finite type for ground atoms, packing a symbol type and a tuple of constants
    of length bounded by the maximal symbol arity *)
Notation gatom_enc := ({x : 'I_(max_ar.+1) & (symtype * x.-tuple constant)%type}).

(** injecting a ground atom [ga] into its corresponding finite type encoding [gatom_enc] *)
Definition gatom_fenc (ga : gatom) : gatom_enc :=
  let: GAtom ga proof := ga in

  existT _ (Ordinal (max_ar_bound (sym_gatom ga))) (sym_gatom ga, Tuple proof).

(** conversely converting a ground atom finite type encoding [gatom_enc] into a ground atom [gatom] *)
Definition fenc_gatom (e : gatom_enc): option gatom.
case: e => x [s]; case: (val x == arity s) / eqP => [-> | _] [tup proof];
[exact: (Some (@GAtom (RawGAtom s tup) proof)) | exact/None].
Defined.
(** partial cancelation lemma for ground atoms *)
Lemma fenc_gatomK : pcancel gatom_fenc fenc_gatom.
Proof. by case=> [[s args] proof] /=; case: eqP => // ?; rewrite !eq_axiomK. Qed.

End GatomFinType.

(** canonical instances for ground atoms *)
Canonical gatom_finType := Eval hnf in FinType gatom (PcanFinMixin fenc_gatomK).
Canonical gatom_subFinType := [subFinType of gatom].

(** We can access the ith argument of a gatom with predicate whose
  arity is greater than i *)
Lemma oob_gatom_args (ga : gatom) (ind : 'I_(arity (sym_gatom ga))) :
  nth_error (arg_gatom ga) ind <> None.
Proof.
destruct ga as [[f args] Hwf].
unfold wf_gatom in Hwf. move:ind.
rewrite -(eqP Hwf).
apply oob_nth_error.
Qed.

(** ** Ground Clauses:
A ground clause [gclause] packs a ground atom head and a body list of ground atoms *)
(** *Important:* Our definition differs from the original one to keep a bound on the size of bodies *)
Inductive gclause := GClause of gatom & wlistn_finType gatom_finType bn.

(** head and body extractors for ground clauses *)
Definition head_gcl gcl := let: GClause h b := gcl in h.
Definition body_gcl gcl := let: GClause h b := gcl in b.

(** ** Canonical instances for ground clauses (Added) *)
(** Boolean equality on clauses *)
Definition gclause_eq gcl1 gcl2 := match gcl1,gcl2 with
  | GClause h1 l1, GClause h2 l2 => (h1 == h2) && (l1 == l2) end.

Lemma gclause_eq_refl gcl : gclause_eq gcl gcl.
Proof.
case:gcl.
move => g l /=.
by apply/andP.
Qed.

(** This is indeed an equality for clauses *)
Lemma gclause_eq_inv gcl1 gcl2 : gclause_eq gcl1 gcl2 -> gcl1 = gcl2.
Proof.
case:gcl1. case: gcl2.
move => g l g2 l2 /= /andP [Heqg Heql].
by rewrite (eqP Heqg) (eqP Heql).
Qed.

Lemma gclause_eq_axiom : Equality.axiom gclause_eq.
Proof.
move => x y; apply Bool.iff_reflect.
split.
  - move => -> ; apply/gclause_eq_refl.
  - apply gclause_eq_inv.
Qed.

Definition gclause_eqMixin := EqMixin gclause_eq_axiom.

(** Definition of the equality type *)
Canonical gclause_eqType := Eval hnf in EqType _ gclause_eqMixin.

(** Projection of the clause to a pair head, body list *)
Definition gclause_rep cl := let: GClause hd bd := cl in (hd, bd).
Definition gclause_pre cl := let: (hd, bd) := cl in GClause hd bd.

Lemma gclause_repK : cancel gclause_rep gclause_pre.
Proof. by case. Qed.

Canonical gclause_choiceType := Eval hnf in ChoiceType gclause (CanChoiceMixin gclause_repK).
Canonical gclause_countType := Eval hnf in CountType gclause (CanCountMixin gclause_repK).
Canonical gclause_finType := Eval hnf in FinType gclause (CanFinMixin gclause_repK).

(** ** Interpretation *)
(** interpretations are finite sets of ground atoms *)
Notation interp := {set gatom}.

Implicit Types (i m : interp) (gcl : gclause).

(** set of all symbols of a given interpretation *)
Definition sym_i (i : interp) := [set sym_gatom (uga ga) | ga in i].

(** satisfiability of a ground clause [gcl] w.r.t a given interpretation [i]:
    if all body atoms belong to [i], the head should also belong to [i] *)
Definition gcl_true gcl i :=
  all (mem i) (body_gcl gcl) ==> (head_gcl gcl \in i).

(** ** Terms *)
(** Terms are either
    - variables, i.e, integers bound by a maximal (computable) index [n]
      - to which we assign the _finite_ ordinal type ['I_n]
    - constants to which we assign the _finite_ [constype]
*)
Inductive term : Type :=
  | Var of 'I_n
  | Val of constant.

(** Injection of constants in terms *)
Definition term_of_cons (c : constant) : term := Val c.

(** corresponding sigma type encoding for terms; needed for canonical instance inference *)
Notation termRep := ('I_n + constant)%type.

(** injecting a term [t] into its [termRep] encoding *)
Definition term_rep (t : term) : termRep :=
  match t with
  | Var i => inl i
  | Val c => inr c
  end.

(** converting a [termRep] encoding into the corresponding term type  *)
Definition term_con (r : termRep) : term :=
  match r with
  | inl i => Var i
  | inr c => Val c
  end.

(** cancelation lemma for terms *)
Lemma term_repK : cancel term_rep term_con.
Proof. by case. Qed.

(** canonical instances for terms *)
Canonical term_eqType := Eval hnf in EqType term (CanEqMixin term_repK).
Canonical term_choiceType := Eval hnf in ChoiceType term (CanChoiceMixin term_repK).

Canonical term_countType := Eval hnf in CountType term (CanCountMixin term_repK).
Canonical term_finType := Eval hnf in FinType term (CanFinMixin term_repK).

(** ** Raw atoms *)
(** Atoms are represented as records packing:
   - a base type [raw_atom]
     - which pairs a symbol with its term list argument
   - a _boolean_ well-formedness condition [wf_atom]
     - which ensures symbol arity and argument size agree *)
Inductive raw_atom : Type := RawAtom of symtype & seq term.

(** Inject raw ground atoms in raw atoms*)
Definition to_raw_atom gra :=
  RawAtom (sym_gatom gra) [seq Val x | x <- arg_gatom gra].

Section RawAtomInstances.

(** packing and unpacking of raw atoms *)
Definition raw_atom_rep l := let: RawAtom s a := l in (s, a).
Definition raw_atom_pre l := let: (s, a) := l in RawAtom s a.

(** cancelation lemma for raw atoms *)
Lemma raw_atom_repK : cancel raw_atom_rep raw_atom_pre.
Proof. by case. Qed.

(** canonical instances for raw atoms *)
Canonical raw_atom_eqType := Eval hnf in EqType raw_atom (CanEqMixin raw_atom_repK).
Canonical raw_atom_choiceType := Eval hnf in ChoiceType raw_atom (CanChoiceMixin raw_atom_repK).

(*
Canonical raw_atom_choiceType := Eval hnf in ChoiceType raw_atom
  (@CanChoiceMixin (prod_choiceType symtype (seq_choiceType term_choiceType)) _ _ _ raw_atom_repK).
*)

Canonical raw_atom_countType :=
  Eval hnf in CountType raw_atom (@CanCountMixin (prod_countType symtype (seq_countType term_finType)) _ _ _ raw_atom_repK).

End RawAtomInstances.

(** extractors for the corresponding symbols and arguments of an atom *)
Definition sym_atom a := let: RawAtom s_a _ := a in s_a.
Definition arg_atom a := let: RawAtom _ arg_a := a in arg_a.

(** ** Atoms *)
(** atom well-formedness condition: argument size and symbol arity must match *)
Definition wf_atom a := size (arg_atom a) == arity (sym_atom a).

(** ** Atoms are records packing a "raw" atom and a corresponding boolean well-formedness condition *)
Structure atom : Type := Atom {ua :> raw_atom; _ : wf_atom ua}.

(** *** A few useful lemmas and auxiliary functions *)
(** Preservation of well formedness by the translation to raw atom *)
Lemma to_atom_proof (ga : gatom) : wf_atom (to_raw_atom ga).
Proof. by case: ga => ra pf; rewrite /wf_atom /= size_map. Qed.

(** Translates ground atom to atom using lemma above *)
Definition to_atom ga := Atom (to_atom_proof ga).

(** Extract the args as a tuple from an atom *)
Definition arg_wf_atom (a : atom) : ((arity (sym_atom a)).-tuple term).
destruct a as [a Ha]. simpl.
rewrite <- (eqP Ha).
apply (in_tuple (arg_atom a)).
Defined.

(** Given an atom and i smaller than the arity, gets the ith arg *)
Definition nth_term (a : atom) (i : 'I_(arity (sym_atom a))) : term :=
  tnth (arg_wf_atom a) i.

(** Given a predicate and a ground atom having this pred, access one
   argument of this ground atom (using dependent type on arity) *)
Definition nth_cons_rew_dep pred (ga : {x : gatom | sym_gatom x == pred}) (i : 'I_(arity pred)) : constant.
destruct ga as [ga Hga].
rewrite <- (eqP Hga) in i.
apply (@nth_cons ga i).
Defined.

(** We can access the ith argument of an atom with predicate whose
  arity is greater than i *)
Lemma oob_atom_args (a : atom) (ind : 'I_(arity (sym_atom a))) : nth_error (arg_atom a) ind <> None.
Proof.
destruct a as [[f args] Hwf].
unfold wf_atom in Hwf. move:ind.
rewrite -(eqP Hwf).
apply oob_nth_error.
Qed.

(** atom instances *)
Canonical atom_subType := Eval hnf in [subType for ua].
Canonical atom_eqType := Eval hnf in EqType _ [eqMixin of atom by <: ].
Canonical atom_choiceType := Eval hnf in ChoiceType _ [choiceMixin of atom by <:].

Canonical atom_countType := Eval hnf in CountType _ [countMixin of atom by <:].

(** *** Atoms are a finite type *)
Section AtomFinType.

(** We use as represention the triple with
      - number of arguments (smaller than max_r)
      - symbol
      - |args|-tuples of terms *)
Notation atom_enc := ({x : 'I_(max_ar.+1) & (symtype * x.-tuple term_finType)%type}).

(** We can inject atom in this encoding *)
Definition atom_fenc (a : atom) : atom_enc :=
  let: Atom a proof := a in
  existT _ (Ordinal (max_ar_bound (sym_atom a))) (sym_atom a, Tuple proof).

(** We can invert this encoding as long as we respect arity *)
Definition fenc_atom (e : atom_enc): option atom.
case: e => x [s]; case: (val x == arity s) / eqP => [-> | _] [tup proof];
[exact: (Some (@Atom (RawAtom s tup) proof)) | exact/None].
Defined.

(** This is a true injection *)
Lemma fenc_atomK : pcancel atom_fenc fenc_atom.
Proof. by case=> [[s args] proof] /=; case: eqP => // ?; rewrite !eq_axiomK. Qed.

End AtomFinType.
Canonical atom_finType := Eval hnf in FinType atom (PcanFinMixin fenc_atomK).
Canonical atom_subFinType := [subFinType of atom].

(** ** Clauses and programs *)
(** A list of size at most n of atoms (for the body) *)
Definition tail := wlistn_finType atom_finType bn.

(** A clause pack an atom head and a list of at most size n of atoms.
  Our definition differs from the original one *)
Inductive clause : Type := Clause of atom & tail.

Section ClauseInstances.

(** packing and unpacking of clauses *)
Definition clause_rep cl := let: Clause hd bd := cl in (hd, bd).
Definition clause_pre cl := let: (hd, bd) := cl in Clause hd bd.

(** cancelation lemma for clauses *)
Lemma clause_repK : cancel clause_rep clause_pre.
Proof. by case. Qed.

(** clause instances *)
Canonical clause_eqType := Eval hnf in EqType clause (CanEqMixin clause_repK).
Canonical clause_choiceType := Eval hnf in ChoiceType clause (CanChoiceMixin clause_repK).

(** Added instances using the bound on the size of the body *)
Canonical clause_countType := Eval hnf in CountType clause (CanCountMixin clause_repK).
Canonical clause_finType := Eval hnf in FinType clause (CanFinMixin clause_repK).

End ClauseInstances.

(** ** Programs are clause lists. *)
Definition program := seq clause.

(** extractors for the corresponding head, body and atoms of a clause *)
Definition head_cl cl := let: Clause h b := cl in h.
Definition body_cl cl := let: Clause h b := cl in b.
Definition atoms_cl cl := [:: head_cl cl & body_cl cl].

(** clause head symbols *)
Definition hsym_cl cl := sym_atom (head_cl cl).

(** all clause symbols *)
Definition sym_cl  cl := [seq sym_atom (val a) | a <- atoms_cl cl].

(** all head symbols of a program *)
Definition hsym_prog  p := [seq hsym_cl cl | cl <- p].

(** all program symbols *)
Definition sym_prog   p := flatten [seq sym_cl cl   | cl <- p].

(** all program atoms *)
Definition atoms_prog p := flatten [seq atoms_cl cl | cl <- p].

(** ** Grounding *)
Section Grounding.

(** *** Ground valuations and their application  *)

(** type of groundings: finitely-supported functions mapping variables to constants *)
Definition gr := finfun_finType (ordinal_finType n) cons_finType.

Implicit Types (g : gr) (t : term) (ra : raw_atom) (a : atom)
               (cl : clause) (hd : atom) (tl : seq atom).

(** term grounding *)
Definition gr_term g t :=
  match t with
  | Var v => g v
  | Val c => c
  end.

(** raw atom grounding *)
Definition gr_raw_atom g ra :=
  RawGAtom (sym_atom ra) [seq gr_term g x | x <- arg_atom ra].

(** the grounding of a well-formed ground atom is well-formed *)
Definition gr_atom_proof g a : wf_gatom (gr_raw_atom g a).
Proof. by case: a => s arg; rewrite /wf_gatom size_map. Qed.

(** atom grounding *)
Definition gr_atom g a := GAtom (gr_atom_proof g a).

(** Grounding on a list of atoms *)
Definition gr_tl g (tl : seq atom) :=
  map (gr_atom g) tl.

(** clause grounding *)
Definition gr_cl g cl :=
  GClause (gr_atom g (head_cl cl)) (wmap (gr_atom g) (body_cl cl)).

End Grounding.

Section Theory.

(** *** Collecting Constants *)

Section Constants.

(** Extract constant from term (as a list of at most one element) *)
Definition const_term t : seq constant :=
  if t is Val e then [:: e] else [::].

(** atom constants *)
Definition const_atom a : seq constant :=
  flatten [seq const_term x | x <- arg_atom a].

(** atom list constants *)
Definition const_tail (tl : seq atom) : seq constant :=
  flatten [seq const_atom (val x) | x <- tl].

(** clause constants *)
Definition const_cl cl : seq constant :=
  const_tail [:: head_cl cl & body_cl cl].

End Constants.

(** *** Collecting Variables *)
Section Variables.

(** term variables *)
Definition term_vars t : {set 'I_n} := if t is Var v then [set v] else set0.

(** "raw" atom variables *)
Definition raw_atom_vars (ra : raw_atom) : {set 'I_n} :=
  \bigcup_(t <- arg_atom ra) term_vars t.

(** atom variables *)
Definition atom_vars (a : atom) : {set 'I_n} := raw_atom_vars a.

(** atom list variables *)
Definition tail_vars tl : {set 'I_n} := \bigcup_(t <- tl) atom_vars t.

(** Extract variables from a clauses (as a set) *)
Definition cl_vars (cl : clause) : {set 'I_n} := tail_vars (body_cl cl).

Lemma raw_atom_vars_cons_sub g args h :
raw_atom_vars (RawAtom g args) \subset raw_atom_vars (RawAtom g (h::args)).
Proof.
apply/subsetP=>x /bigcup_seqP [t H1 /andP [H2 _]].
apply/bigcup_seqP. exists t. apply/mem_body/H1.
apply/andP;split;auto.
Qed.

(** if [x] in the variables of [tl], then [x] is also a var of [a:: tl] *)
Lemma tail_vars_cons x a tl : x \in tail_vars tl -> x \in tail_vars (a :: tl).
Proof.
unfold tail_vars. move=> /bigcup_seqP [ga Hga1 Hga2].
apply/bigcup_seqP. exists ga.
rewrite in_cons. apply/orP. right. apply Hga1.
apply Hga2.
Qed.

Lemma tail_vars_sub_cons a tl : tail_vars tl \subset tail_vars (a :: tl).
Proof.
apply/subsetP=>x Hx. apply/tail_vars_cons/Hx.
Qed.

Lemma tail_vars_consUP (tl : seq atom) (a : atom) :
  tail_vars (a :: tl) = tail_vars [:: a] :|: tail_vars tl.
Proof.
apply/eqP;rewrite eqEsubset. apply/andP;split.
- apply/subsetP=>x /bigcup_seqP [b Hbin /andP [H _]].
  rewrite in_cons in Hbin. destruct (orP Hbin) as [Hbinb|Hbinb].
  + apply/setUP;left. apply/bigcup_seqP. rewrite (eqP Hbinb) in H.
    exists a. by rewrite mem_seq1. apply/andP;split;auto.
  + apply/setUP;right. apply/bigcup_seqP. exists b.
    apply Hbinb. apply/andP;split;auto.
- apply/subsetP=>x /setUP [/bigcup_seqP [b Hbin /andP [H _]] | /bigcup_seqP [b Hbin /andP [H _]] ].
  + apply/bigcup_seqP. rewrite mem_seq1 in Hbin. exists a. apply/mem_head.
    rewrite -(eqP Hbin). apply/andP;split;auto.
  + apply/bigcup_seqP. exists b. apply/mem_body/Hbin.
    apply/andP;split;auto.
Qed.

(** if [x] is a variable of [a] it is a variable of [a:: tl] *)
Lemma tail_vars_head x a tl : x \in atom_vars a -> x \in tail_vars (a :: tl).
Proof.
move=>Hx. unfold tail_vars. apply/bigcup_seqP. exists a.
rewrite in_cons. apply/orP. by left.
by apply/andP;split.
Qed.

(** If [v] is in the vars of a raw atom, adding a new term to the list of
  arguments does not change this fact (note raw atoms are untyped) *)
Lemma raw_atom_vars_cons v fa args h : v \in raw_atom_vars (RawAtom fa args)
                                -> v \in raw_atom_vars (RawAtom fa (h::args)).
Proof.
unfold raw_atom_vars. move=>/bigcup_seqP [ga Hga1 Hga2].
apply/bigcup_seqP. exists ga.
rewrite in_cons. apply/orP. by right. apply Hga2.
Qed.

(** If a var is in an atom and the atom in a body (list of atom),
   then the var is in the body *)
Lemma tailvars_trans v ato tl :
  v \in atom_vars ato -> ato \in tl -> v \in tail_vars tl.
Proof.
move=> /bigcup_seqP [t Htin Hvt] Hatoin.
apply/bigcup_seqP. exists ato. apply Hatoin.
apply/andP;split;auto.
apply/bigcup_seqP. exists t;auto.
Qed.

(** The vars of an empty body is the empty set *)
Lemma tail_vars_nil : tail_vars [::] = set0.
Proof.
apply/eqP. rewrite -subset0. apply/subsetP. move=>x /bigcup_seqP [ato Hatoin].
by rewrite in_nil in Hatoin.
Qed.

Lemma tail_vars_1 (a:atom) : tail_vars [:: a] = atom_vars a.
Proof.
apply/eqP. rewrite eqEsubset;apply/andP;split;
apply/subsetP=>x /bigcup_seqP [y Hy1 /andP [Hy2 Htriv]].
rewrite mem_seq1 in Hy1. rewrite -(eqP Hy1). apply Hy2.
apply/bigcup_seqP. exists a. by rewrite mem_seq1. apply/andP;split;auto.
apply/bigcup_seqP. exists y. apply Hy1. apply/andP;split;auto.
Qed.

(** ** Program Safety Condition *)

(** clause safety: all head variables should appear among the body variables *)
Definition safe_cl cl :=
  atom_vars (head_cl cl) \subset tail_vars (body_cl cl).

(** program safety: all clauses should be safe *)
Definition prog_safe p := all safe_cl p.

(** *** Safety of deduced facts (in the IDB) - added *)
(** A clause has a safe head if its head predicate is of kind IDB *)
Definition safe_cl_hd cl :=
  predtype (hsym_cl cl) == Idb.

Definition prog_safe_hds p := all safe_cl_hd p.

(** An interpretation is a "safe edb" if all its atoms have symbols
  of type edb *)
Definition safe_edb i := [forall ga in i, predtype (sym_gatom ga) == Edb].

End Variables.

(** *** No sharing of variables between clauses - added *)
(** Clauses sharing variables *)
Definition clauses_var_intersect (cl1 cl2 : clause) : bool :=
  tail_vars (body_cl cl1) :&: tail_vars (body_cl cl2) != set0.

(** Constraint on P: clauses sharing variables in a program would
   mean they are equals *)
Definition vars_not_shared (p : program) : bool :=
  [forall cl1 in p, forall cl2 in p,
    (clauses_var_intersect cl1 cl2) ==> (cl1 == cl2)].

(** If the constraint vars_not_shared is fullfilled on P and if we
   have a variable  v that is in both cl1 and cl2 clauses of P, then
   cl1 and cl2 are the same clause. *)
Lemma vns_cl_eq (p : program) (cl1 cl2 : clause) (v : 'I_n) :
  v \in (tail_vars (body_cl cl1)) -> v \in (tail_vars (body_cl cl2)) ->
  cl1 \in p -> cl2 \in p -> vars_not_shared p -> cl1 = cl2.
Proof.
move => vcl1 vcl2 Hcl1 Hcl2 vns.
unfold vars_not_shared in vns.
induction p.
- inversion Hcl1.
- rewrite in_cons in Hcl1 ; rewrite in_cons in Hcl2.
  destruct (orP Hcl1) as [Hcl1IsA | Hcl1InP] ; destruct (orP Hcl2) as [Hcl2IsA | Hcl2InP] ; clear Hcl1 ; clear Hcl2.
  + by rewrite (eqP Hcl1IsA) (eqP Hcl2IsA).
  + assert (Hcl1In : cl1 \in a::p).
    - rewrite (eqP Hcl1IsA) ; apply/mem_head.
    assert (Hcl2In : cl2 \in a::p).
    - apply/mem_body/Hcl2InP.
    assert (Hinters : clauses_var_intersect cl1 cl2).
    - apply/set0Pn. exists v. by apply/setIP ; split.
    pose Heq := (eqP (implyP (implyP (forallP (implyP ((forallP vns) cl1) Hcl1In) cl2) Hcl2In) Hinters)).
    by inversion Heq.
  + assert (Hcl1In : cl1 \in a::p).
    - apply/mem_body/Hcl1InP.
    assert (Hcl2In : cl2 \in a::p).
    - rewrite (eqP Hcl2IsA) ; apply/mem_head.
    assert (Hinters : clauses_var_intersect cl1 cl2).
    - apply/set0Pn. exists v. by apply/setIP ; split.
    pose Heq := (eqP (implyP (implyP (forallP (implyP ((forallP vns) cl1) Hcl1In) cl2) Hcl2In) Hinters)).
    by inversion Heq.
  + apply/(IHp Hcl1InP Hcl2InP)/forallP=>x.
    apply/implyP=>Hx.
    apply/forallP=>y. apply/implyP=>Hy.
    assert (Hcl1In : x \in a::p).
    - apply/mem_body/Hx.
    assert (Hcl2In : y \in a::p).
    - apply/mem_body/Hy.
    apply (implyP (forallP (implyP (forallP vns _) Hcl1In) _) Hcl2In).
Qed.

Definition is_var (t : term) :=
  match t with
    Val _ => false
  | Var _ => true end.

Definition only_variables_atom (a : atom) :=
  all is_var (arg_atom a).

Definition only_variables_head (cl : clause) :=
  only_variables_atom (head_cl cl).

Definition only_variables_in_heads (p : program) :=
  all only_variables_head p.

(** ** Program Satisfiability *)

(** a clause [c] is satisfied by an interpretation [i], if for all groundings [g]
its corresponding instantiation is satisfied by [i] *)
Definition cl_true cl i := forall g : gr, gcl_true (gr_cl g cl) i.

(** A program is true in i, if all grounding of its clauses are  true *)
Definition prog_true p i :=
  forall g : gr, all (fun cl => gcl_true (gr_cl g cl) i) p.

End Theory.


Section Graph.

  Variable A : Type.

  Definition graph := A -> A -> Type.

  Definition edge (G:graph) s d := G s d.

End Graph.

Arguments edge {_} _ _ _.


Require Import Coq.ZArith.BinInt.
Require Import Coq.Program.Program.
Require Poulet4.Utils.Utils.
Require Import ProD3.core.Coqlib.
Require Import ProD3.examples.sbf.Utils.
Require Import ProD3.examples.cms.AbsModel.
Require Import Hammer.Plugin.Hammer.
Import ListNotations.
Open Scope Z_scope.
Open Scope program_scope.

Section LightModel.

Context {header_type : Set}.
Context (num_frames num_rows num_slots frame_time : Z).
Hypothesis H_num_slots : 0 < num_slots.
Hypothesis H_num_rows : 0 < num_rows.
Hypothesis H_num_frames : 1 < num_frames.
Context (hashes : list (header_type -> Z)).
Hypothesis H_Zlength_hashes : Zlength hashes = num_rows.
Hypothesis H_hashes : Forall (fun hash => forall h, 0 <= hash h < num_slots) hashes.

Context (tick_time : Z).
Hypothesis (H_tick_time : 0 < tick_time).

Hypothesis (H_frame_time : 0 < frame_time).
Hypothesis (H_tick_time_div : (tick_time * 2 | frame_time)).

Definition cms := option (@cms header_type).

Notation abs_insert := (@cms_insert header_type num_frames num_slots frame_time tick_time).
Notation abs_query := (@cms_query header_type num_frames num_slots frame_time hashes tick_time).
Notation abs_clear := (@cms_clear header_type num_frames num_slots frame_time tick_time).
Notation abs_refresh := (@cms_refresh header_type num_frames num_slots frame_time tick_time).

(* The time of guaranteed query, e.g. 59s. *)
Definition T := frame_time * (num_frames - 2).

(* The maximum time interval between consecutive packets, e.g. 112us. *)
Definition Tc := frame_time / num_slots.

(* This should be provable *)
Lemma Tc_mul_num_slots_le_frame_time : Tc * num_slots <= frame_time.
Proof. unfold Tc. rewrite Z.mul_comm. apply Z.mul_div_le. assumption. Qed.
(* This seems NOT provable. *)
Axiom Tc_le_tick_time : Tc <= tick_time.

Lemma Tc_le_frame_time : Tc <= frame_time.
Proof.
  unfold Tc. apply Z.div_le_upper_bound; auto.
  rewrite Z.mul_comm. apply Z.le_mul_diag_r; lia.
Qed.

Axiom H_Tc : 0 < Tc.
(* Lemma Tc_le_T : Tc <= T.
Admitted. *)

Definition cms_insert (f : cms) (th : Z * header_type) : cms :=
  match f with
  | Some f => abs_insert f th
  | None => None
  end.

Definition cms_query (f : cms) '((t, h) : Z * header_type) : option Z :=
  match f with
  | Some (mk_cms window_hi last_timestamp num_clears normal_frames) =>
      if last_timestamp <=? t then
        let num_invalid_frames := Z.min (Z.max ((t - window_hi) / frame_time + 1) 0) (num_frames - 1) in
        let valid_frames := sublist num_invalid_frames (num_frames - 1) normal_frames in
        let res := Zsum (map (fun hs => list_min (map (fun hash => Zsum (map (Z.b2z ∘ Z.eqb (hash h) ∘ hash) hs)) hashes)) valid_frames) in
        Some res
      else
        None
  | None => None
  end.

Definition cms_clear (f : cms) (t : Z) : cms :=
  match f with
  | Some f =>
      abs_clear f t
  | None => None
  end.

(* Axiom cms_empty : cms. *)

Definition weak_cms_inv (f : cms) : Prop :=
  match f with
  | Some (mk_cms window_hi last_timestamp num_clears normal_frames) =>
      window_hi - frame_time <= last_timestamp < window_hi /\
      Zlength normal_frames = num_frames - 1
  | None => False
  end.

Definition cms_inv (f : cms) : Prop :=
  match f with
  | Some (mk_cms window_hi last_timestamp num_clears normal_frames) =>
      last_timestamp < window_hi /\
      (window_hi - 1 - last_timestamp) / Tc + num_clears >= num_slots /\
      Zlength normal_frames = num_frames - 1
  | None => False
  end.

Definition ok_until (f : cms) (t : Z) : Prop :=
  (* cms_inv f /\ *)
  match f with
  | Some (mk_cms window_hi last_timestamp num_clears normal_frames) =>
      0 <= t - last_timestamp <= Tc /\ cms_inv f
        (* last_timestamp < window_hi /\
        (window_hi - 1 - last_timestamp) / Tc + num_clears >= num_slots *)
  | None => False
  end.

Definition weak_cms_inv1 (f : cms) (new_timestamp : Z) : Prop :=
  match f with
  | Some (mk_cms window_hi last_timestamp num_clears normal_frames) =>
      window_hi - frame_time <= new_timestamp < window_hi /\
      Zlength normal_frames = num_frames - 1
  | None => False
  end.

Definition cms_inv1 (f : cms) (new_timestamp : Z) : Prop :=
  match f with
  | Some (mk_cms window_hi last_timestamp num_clears normal_frames) =>
      new_timestamp < window_hi /\
      (window_hi - 1 - new_timestamp) / Tc + (num_clears + 1) >= num_slots /\
      Zlength normal_frames = num_frames - 1
  | None => False
  end.

Definition ok_until1 (f : cms) (new_timestamp : Z) (t : Z) : Prop :=
  match f with
  | Some (mk_cms window_hi _ num_clears normal_frames) =>
      0 <= t - new_timestamp <= Tc /\ cms_inv1 f new_timestamp
        (* new_timestamp < window_hi /\
        (window_hi - 1 - new_timestamp) / Tc + (num_clears + 1) >= num_slots *)
  | None => False
  end.

Lemma weak_cms_inv1_abs_refresh : forall f t,
  weak_cms_inv (Some f) ->
  match abs_refresh f t with
  | Some f =>
      weak_cms_inv1 (Some f) t
  | None => True
  end.
Proof.
  intros.
  unfold weak_cms_inv, weak_cms_inv1 in *.
  destruct f.
  unfold abs_refresh.
  destruct (last_timestamp <=? t) eqn:?H; only 2 : simpl; auto.
  destruct (t <=? last_timestamp + tick_time) eqn:?H; only 2 : simpl; auto.
  simpl andb. cbn match.
  destruct (t >=? window_hi) eqn:?H.
  - destruct (num_clears >=? num_slots); only 2 : auto.
    split.
    + assert (tick_time <= frame_time). {
        destruct H_tick_time_div as [z ?]. subst.
        replace (z * (tick_time * 2)) with (tick_time * (2 * z)) by lia.
        apply Z.le_mul_diag_r; lia. } lia.
    + list_solve.
  - lia.
Qed.

(* This lemma shows cms_query (cms_clear ..) is equal to abs_query. *)
Lemma abs_query_pattern_ok : forall f t h res,
  weak_cms_inv (Some f) ->
  cms_query (cms_clear (Some f) t) (t, h) = Some res ->
  exists f', abs_query f (t, h) = Some (f', res).
Proof.
  intros * ?H H_cms_query.
  unfold cms_clear, cms_query, abs_clear, abs_query in *.
  pose proof (weak_cms_inv1_abs_refresh f t ltac:(auto)).
  destruct (abs_refresh f t) as [[window_hi last_timestamp num_clears normal_frames] | ].
    2 : inv H_cms_query.
  unfold weak_cms_inv1 in *.
  assert ((t - window_hi) / frame_time + 1 = 0). {
    rewrite <- Zdiv.Z_div_plus by lia.
    apply Z.div_small; lia.
  }
  destruct (t <=? t) eqn:?H.
    2 : inv H_cms_query.
  eexists. f_equal. f_equal.
  inv H_cms_query.
  f_equal. list_solve.
Qed.

Lemma ok_refresh : forall f t t',
  t <= t' <= t + Tc ->
  ok_until (Some f) t ->
  ok_until1 (abs_refresh f t) t t'.
Proof.
  intros * H_t' H_ok_until.
  destruct f as [window_hi last_timestamp num_clears normal_frames].
  simpl in *.
  replace (last_timestamp <=? t) with true by lia.
  replace (t <=? last_timestamp + tick_time) with true by (pose Tc_le_tick_time; lia).
  destruct (t >=? window_hi) eqn:?H.
  - assert (0 <= window_hi - 1 - last_timestamp < Tc) by (pose Tc_le_tick_time; lia).
    rewrite Z.div_small in H_ok_until by lia.
    replace (num_clears >=? num_slots) with true by lia.
    simpl.
    split; only 1 : lia.
    split; only 1 : (pose Tc_le_frame_time; lia).
    split; only 2 : list_solve.
    pose proof Tc_mul_num_slots_le_frame_time.
    assert (window_hi - t >= 1 - Tc) by lia.
    assert ((window_hi + frame_time - 1 - t) / Tc + 1 >= frame_time / Tc). {
      replace (frame_time / Tc) with ((frame_time - Tc) / Tc + 1).
      - apply Z.le_ge, Z.add_le_mono_r, Z.ge_le, Zdiv.Z_div_ge; lia.
      - rewrite <- Z.add_opp_r. change (- Tc) with ((- 1) * Tc).
        rewrite Z.div_add; lia. }
    apply Zorder.Zge_trans with (frame_time / Tc); auto.
    apply Z.div_le_mono with (c := Tc) in H1. 2: lia.
    rewrite Z.mul_comm, Z.div_mul in H1; lia.
  - simpl.
    split; only 1 : lia.
    split; only 1 : lia.
    split; only 2 : lia.
    assert ((window_hi - 1 - last_timestamp + (-1) * Tc) / Tc <= (window_hi - 1 - t) / Tc). {
      apply Z.div_le_mono. 2 : lia.
      apply H_Tc.
    }
    rewrite Zdiv.Z_div_plus in * by (pose proof H_Tc; lia).
    lia.
Qed.

Lemma query_clear : forall f t t' h,
  t <= t' ->
  ok_until f t ->
  cms_query f (t', h) = cms_query (cms_clear f t) (t', h).
Proof.
  intros * H_t' H_ok_until.
  destruct f. 2 : inv H_ok_until.
  destruct c as [window_hi last_timestamp num_clears normal_frames].
  unfold cms_clear, abs_clear, abs_refresh, ok_until, cms_inv in *.
  replace (last_timestamp <=? t) with true by lia.
  replace (t <=? last_timestamp + tick_time) with true by (pose Tc_le_tick_time; lia).
  destruct (t >=? window_hi) eqn:?H.
  - assert (0 <= window_hi - 1 - last_timestamp < Tc) by (pose Tc_le_tick_time; lia).
    rewrite Z.div_small in H_ok_until by lia.
    replace (num_clears >=? num_slots) with true by lia.
    cbn -[cms_query sublist].
    unfold cms_query.
    replace (last_timestamp <=? t') with true by lia.
    replace (t <=? t') with true by lia.
    remember (Z.max ((t' - window_hi) / frame_time + 1) 0) as k eqn:?H.
    assert ((t' - window_hi) / frame_time >= 0). {
      apply Zdiv.Z_div_ge0; lia.
    }
    replace (Z.max ((t' - (window_hi + frame_time)) / frame_time + 1) 0) with (k - 1). 2 : {
      replace (t' - (window_hi + frame_time)) with (t' - window_hi + (-1) * frame_time) by lia.
      rewrite Z.div_add by lia.
      lia.
    }
    destruct (k - 1 >=? (num_frames - 1)) eqn:?H.
    { replace (sublist (Z.min k (num_frames - 1)) (num_frames - 1) _)
        with (@nil (list header_type)) by list_solve.
      replace (sublist (Z.min (k - 1) (num_frames - 1)) (num_frames - 1) _)
        with (@nil (list header_type)) by list_solve.
      auto.
    }
    destruct (k >=? (num_frames - 1)) eqn:?H.
    { replace (sublist (Z.min k (num_frames - 1)) (num_frames - 1) _)
        with (@nil (list header_type)) by list_solve.
      replace (sublist (Z.min (k - 1) (num_frames - 1)) (num_frames - 1) _)
        with ([@nil header_type]) by list_solve.
      destruct hashes as [ | hash0 hashes']. 1 : list_solve. unfold Zsum. simpl.
      clear. induction hashes'; simpl; auto.
    }
    replace (sublist (Z.min k (num_frames - 1)) (num_frames - 1) _)
        with (sublist k (num_frames - 1) normal_frames) by list_solve.
    replace (sublist (Z.min (k - 1) (num_frames - 1)) (num_frames - 1) _)
      with (sublist k (num_frames - 1) normal_frames ++ [[]]) by list_solve.
    rewrite map_app. simpl.
    replace (list_min (map (fun _ : header_type -> Z => Zsum []) hashes)) with 0.
    2: { unfold Zsum. simpl. destruct hashes as [ | hash0 hashes']. 1 : list_solve.
         simpl. clear. induction hashes'; simpl; auto. }
    rewrite Zsum_app. replace (Zsum [0]) with 0 by (unfold Zsum; now simpl).
    rewrite Z.add_0_r. auto.
  - simpl.
    replace (last_timestamp <=? t') with true by lia.
    replace (t <=? t') with true by lia.
    auto.
Qed.

Lemma ok_until_query_some : forall f t t' h,
    t <= t' ->
    ok_until f t ->
    exists k, cms_query f (t', h) = Some k.
Proof.
  intros f t t' h Ht' H_ok_until.
  destruct f. 2: inv H_ok_until. red in H_ok_until. destruct c.
  destruct H_ok_until as [[Ht _] _]. simpl.
  destruct (last_timestamp <=? t') eqn:Hlt. 2: lia.
  match goal with
  | |- exists _, Some ?i = Some _ => exists i; reflexivity
  end.
Qed.

Lemma query_insert_same : forall f t t' h k,
  t <= t' <= t + T ->
  ok_until f t ->
  cms_query f (t', h) = Some k ->
  cms_query (cms_insert f (t, h)) (t', h) = Some (k + 1).
Proof.
  intros f t t' h k Ht' H_ok_until H_cms_query.
  assert (H_query_clear : cms_query (cms_clear f t) (t', h) = Some k). {
    erewrite <- query_clear; eauto. lia.
  }
  clear H_cms_query.
  unfold cms_clear, abs_clear, cms_insert, abs_insert in *.
  destruct f. 2 : inv H_ok_until.
  pose proof (H_ok_refresh := ok_refresh c t t ltac:(pose proof H_Tc; lia) ltac:(auto)).
  destruct (abs_refresh c t) as [f' | ] in *. 2 : inv H_ok_refresh.
  destruct f'.
  unfold cms_query, ok_until1, cms_inv1 in *.
  destruct (t <=? t') eqn:?H. 2 : inv H_query_clear.
  injection H_query_clear; clear H_query_clear; intros H_query_clear. f_equal.
  remember (fun hs: list header_type => _) as f.
  remember (Z.min (Z.max ((t' - window_hi) / frame_time + 1) 0) (num_frames - 1)) as lo.
  assert ((t' - window_hi) / frame_time < num_frames - 2). {
    apply Z.div_lt_upper_bound. 1 : lia.
    fold T.
    lia.
  }
  assert (0 <= lo < num_frames - 1) by (subst lo; lia).
  rewrite (sublist_split lo (num_frames - 2) (num_frames - 1)) in H_query_clear |- *
      by list_solve.
  rewrite map_app, Zsum_app in *.
  rewrite sublist_upd_Znth_l by lia.
  replace (num_frames - 1) with (num_frames - 2 + 1) in H_query_clear |- * by lia.
  rewrite sublist_len_1 in * by list_solve.
  remember (Zsum (map f (sublist lo (num_frames - 2) normal_frames))) as m. clear Heqm.
  unfold Zsum in H_query_clear |- *. simpl in H_query_clear |- *.
  rewrite upd_Znth_same in * by lia. subst f.
  remember (fun hash : header_type -> Z =>
              Zsum (map (Z.b2z ∘ Z.eqb (hash h) ∘ hash)
                      (Znth (num_frames - 2) normal_frames ++ [h]))) as f.
  remember (fun hash : header_type -> Z =>
              Zsum (map (Z.b2z ∘ Z.eqb (hash h) ∘ hash)
                      (Znth (num_frames - 2) normal_frames))) as g.
  assert (forall hash, f hash = g hash + 1). {
    intros. subst. rewrite map_app, Zsum_app. f_equal. unfold Zsum, compose. simpl.
    rewrite Z.eqb_refl. reflexivity. }
  rewrite <- (map_ext (fun hash => g hash + 1)).
  2: { intros; rewrite H2; reflexivity. }
  rewrite list_min_map_add; lia.
Qed.

Lemma list_min_diff_at_most_one: forall (l1 l2: list Z),
    0 < Zlength l1 ->
    Zlength l1 = Zlength l2 ->
    (forall i, 0 <= i < Zlength l1 -> Znth i l1 = Znth i l2 \/ Znth i l1 = Znth i l2 + 1) ->
    list_min l1 = list_min l2 \/ list_min l1 = list_min l2 + 1.
Proof.
  intros l1 l2 Hgt Hl Hd. destruct l1. 1: list_solve. simpl.
  destruct l2. 1: list_solve. simpl.
  assert (Hl': Zlength l1 = Zlength l2) by list_solve.
  assert (Hd': forall i, 0 <= i < Zlength l1 ->
                    Znth i l1 = Znth i l2 \/ Znth i l1 = Znth i l2 + 1). {
    intros. assert (Hp: 0 <= i + 1 < Zlength (z :: l1)) by list_solve. specialize (Hd _ Hp).
    list_solve. }
  specialize (Hd 0 ltac:(lia)). rewrite !Znth_0_cons in Hd. clear Hgt Hl.
  revert l1 l2 z z0 Hd Hl' Hd'. induction l1; intros l2 z z0 Hd1 Hl Hd; simpl.
  - destruct l2. 2: list_solve. simpl. assumption.
  - destruct l2 as [|b l2]. 1: list_solve. simpl. apply IHl1. 2: list_solve.
    + specialize (Hd 0 ltac:(list_solve)). list_solve.
    + intros. specialize (Hd (i + 1) ltac:(list_solve)). list_solve.
Qed.

Lemma query_insert_other : forall f t t' h h' k,
  t <= t' ->
  ok_until f t ->
  cms_query f (t', h') = Some k ->
  cms_query (cms_insert f (t, h)) (t', h') = Some k \/
    cms_query (cms_insert f (t, h)) (t', h') = Some (k + 1).
Proof.
  intros f t t' h h' k H_t' H_ok_until H_cms_query.
  assert (H_query_clear : cms_query (cms_clear f t) (t', h') = Some k). {
    erewrite <- query_clear; eauto.
  }
  clear H_cms_query.
  unfold cms_clear, abs_clear, cms_insert, abs_insert in *.
  destruct f. 2 : inv H_ok_until.
  pose proof (H_ok_refresh := ok_refresh c t t ltac:(pose proof H_Tc; lia) ltac:(auto)).
  destruct (abs_refresh c t) as [f' | ] eqn:?H. 2 : inv H_query_clear.
  destruct f' as [window_hi last_timestamp num_clears normal_frames].
  unfold cms_query in *.
  destruct (t <=? t') eqn:?H. 2 : inv H_query_clear.
  injection H_query_clear; clear H_query_clear; intros H_query_clear.
  remember (fun hs: list header_type => _) as f.
  assert (Hl: Zlength normal_frames = num_frames - 1) by apply H_ok_refresh.
  remember (Z.min (Z.max ((t' - window_hi) / frame_time + 1) 0) (num_frames - 1)) as lo.
  destruct (Z_le_lt_dec (num_frames - 2) ((t' - window_hi) / frame_time)).
  - assert (num_frames - 1 <= lo) by lia.
    rewrite sublist_over in H_query_clear |- * by list_solve.
    left. f_equal. assumption.
  - assert (0 <= lo < num_frames - 1) by (subst lo; lia).
    rewrite (sublist_split lo (num_frames - 2) (num_frames - 1)) in H_query_clear |- *
        by list_solve.
    rewrite map_app, Zsum_app in *.
    rewrite sublist_upd_Znth_l by lia.
    replace (num_frames - 1) with (num_frames - 2 + 1) in H_query_clear |- * by lia.
    rewrite sublist_len_1 in * by list_solve.
    remember (Zsum (map f (sublist lo (num_frames - 2) normal_frames))) as m. clear Heqm.
    unfold Zsum in H_query_clear |- *. simpl in H_query_clear |- *.
    rewrite upd_Znth_same in * by lia. subst f.
    remember (fun hash : header_type -> Z =>
                Zsum (map (Z.b2z ∘ Z.eqb (hash h') ∘ hash)
                        (Znth (num_frames - 2) normal_frames ++ [h]))) as f.
    remember (fun hash : header_type -> Z =>
                Zsum (map (Z.b2z ∘ Z.eqb (hash h') ∘ hash)
                        (Znth (num_frames - 2) normal_frames))) as g.
    assert (forall hash, f hash = g hash \/ f hash = g hash + 1). {
      intros. subst. rewrite map_app, Zsum_app. unfold Zsum, compose. simpl.
      destruct (hash h' =? hash h); simpl; lia. }
    cut (list_min (map f hashes) = list_min (map g hashes) \/
           list_min (map f hashes) = list_min (map g hashes) + 1).
    + intros Hmin. destruct Hmin; [left | right]; f_equal; lia.
    + apply list_min_diff_at_most_one; list_solve.
Qed.

Lemma ok_insert : forall f t t' h,
  t <= t' <= t + Tc ->
  ok_until f t ->
  ok_until (cms_insert f (t, h)) t'.
Proof.
  intros * H_t' H_ok_until.
  destruct f. 2 : inv H_ok_until.
  pose proof (H_ok_refresh := ok_refresh c t t' ltac:(auto) ltac:(auto)).
  unfold cms_insert, abs_insert in *.
  destruct (abs_refresh c t). 2 : inv H_ok_refresh.
  destruct c0.
  unfold ok_until, cms_inv.
  rewrite Zlength_upd_Znth.
  apply H_ok_refresh.
Qed.

Lemma ok_clear : forall f t t',
  t <= t' <= t + Tc ->
  ok_until f t ->
  ok_until (cms_clear f t) t'.
Proof.
  intros * H_t' H_ok_until.
  destruct f. 2 : inv H_ok_until.
  pose proof (H_ok_refresh := ok_refresh c t t' ltac:(auto) ltac:(auto)).
  unfold cms_clear, abs_clear in *.
  destruct (abs_refresh c t). 2 : inv H_ok_refresh.
  destruct c0. apply H_ok_refresh.
Qed.

End LightModel.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.arrival_sequence rt.model.arrival.basic.task rt.model.arrival.basic.job.
Require Import rt.model.schedule.global.schedulability.
Require Import rt.model.schedule.global.basic.schedule.
Require Import rt.model.schedule.partitioned.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module PartitionSchedulability.

  Require rt.model.schedule.uni.schedule.
  Module uni_sched := rt.model.schedule.uni.schedulability.Schedulability.
  Import ArrivalSequence Partitioned Schedule Schedulability.

  Section PartitionedAsUniprocessor.

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

    (* Consider any job arrival sequence that is to be scheduled. *)
    Variable arr_seq: arrival_sequence Job.
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    (* Assume that all jobs in the arrival sequence come from a task set ts. *)
    Variable ts: list Task.
    Hypothesis H_all_jobs_from_ts:
      forall j, arrives_in arr_seq j -> job_task j \in ts.

    (* Also assume that every task is assigned to a processor, ... *)
    Variable assigned_cpu: Task -> processor num_cpus.

    (* ...forming a partitioned schedule. *)
    Hypothesis H_partitioned: partitioned_schedule job_task sched ts assigned_cpu.

    (* Next, we related total service with per-processor service received by each job. *)
    Section SameService.

      (* Consider the partition where each job is assigned to. *)
      Let partition_of j := assigned_cpu (job_task j).

      (* Let j be any job. *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.

      (* We prove that the service received by job j (on the multiprocessor)
         is the same as the service received by job j in its partition. *)
      Lemma same_per_processor_service :
        forall t1 t2,
          service_during sched j t1 t2 =
          uni.service_during (sched (partition_of j)) j t1 t2.
      Proof.
        intros t1 t2.
        unfold partitioned_schedule, task_local_to_processor,
               job_local_to_processor, service_during, service_at,
               uni.service_during, uni.service_at,
               uni.scheduled_at, scheduled_on, partition_of in *.
        rename H_partitioned into PART, H_all_jobs_from_ts into FROMTS.
        apply eq_bigr; intros t _.
        unfold uni.service_at, uni.scheduled_at.
        feed (PART (job_task j)); first by apply FROMTS.
        feed (PART j); first by done.
        specialize (PART t).
        destruct (scheduled sched j t) eqn:SCHED; last first.
        {
          apply negbT in SCHED; rewrite negb_exists in SCHED.
          move: SCHED => /forallP SCHED.
          have SCHEDcpu := SCHED (assigned_cpu (job_task j)); apply negbTE in SCHEDcpu.
          unfold scheduled_on in *; rewrite SCHEDcpu.
          rewrite big1; first by done.
          move => cpu /eqP SCHED'.
          by specialize (SCHED cpu); rewrite SCHED' eq_refl in SCHED.
        }
        {
          move: SCHED => /existsP [cpu SCHED].
          rewrite (bigD1 cpu) /=; last by done.
          have SAME := PART cpu SCHED; rewrite -SAME.
          unfold scheduled_on in *; rewrite SCHED.
          rewrite add1n; apply/eqP; rewrite eqSS; apply/eqP.
          rewrite big1; first by done.
          move => cpu' /andP [SCHED' NEQ].
          have SAME' := (PART cpu' SCHED'); subst cpu cpu'.
          by rewrite eq_refl in NEQ.
        }
      Qed.

    End SameService.

    Section Schedulability.

      (* Recall the definitions of schedulability on a uniprocessor and on
         a multiprocessor. *)
      Let schedulable_on tsk cpu :=
        uni_sched.task_misses_no_deadline job_arrival job_cost job_deadline job_task
                                                               arr_seq (sched cpu) tsk.
      Let schedulable :=
        task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.

      (* Here we prove that if every task is schedulable in their assigned processors, ...*)
      Hypothesis H_locally_schedulable:
        forall tsk,
          tsk \in ts -> schedulable_on tsk (assigned_cpu tsk).

      (* ...then every task is schedulable at the level of the multiprocessor system. *)
      Lemma schedulable_at_system_level:
        forall tsk,
          tsk \in ts -> schedulable tsk.
      Proof.
        have SAME := same_per_processor_service.
        unfold partitioned_schedule, task_local_to_processor,
               job_local_to_processor, schedulable, schedulable_on,
               task_misses_no_deadline, job_misses_no_deadline,
               completed, uni_sched.task_misses_no_deadline,
               uni_sched.job_misses_no_deadline, uni.completed_by in *.
        rename H_locally_schedulable into SCHED,
               H_partitioned into PART.
        intros tsk IN j ARRj JOBtsk.
        specialize (SCHED tsk IN j ARRj JOBtsk).
        move: SCHED => /eqP <-.
        unfold service, uni.service, service_during, uni.service_during in *.
        by apply/eqP; rewrite SAME // JOBtsk.
      Qed.

    End Schedulability.

  End PartitionedAsUniprocessor.

End PartitionSchedulability.


Require Import Coq.Reals.Reals.
Require Import ExtLib.Tactics.
Require Import Logic.Logic.
Require Import Logic.ProofRules.
Require Import Logic.Inductively.
Require Import Logic.EnabledLemmas.
Require Import Logic.Tactics.
Require Import Examples.System.

Set Implicit Arguments.
Set Strict Implicit.

Local Open Scope string_scope.

Section quadcopter.
  Variable delta : R.
  Hypothesis delta_gt_0 : (delta > 0)%R.
  Variable gravity : R.
  Variable angle_min : R.
  Hypothesis angle_min_lt_0 : (angle_min < 0)%R.
  Definition angle_max := (-angle_min)%R.

  Local Open Scope HP_scope.

  Definition small_angle : StateFormula :=
           angle_min <= "pitch" <= angle_max
      //\\ angle_min <= "roll" <= angle_max
      //\\ 0 <= "A".

  Definition W_quad : Evolution := fun st' =>
          st' "x" = "vx" //\\ st' "y" = "vy" //\\
          st' "z" = "vz"
     //\\ st' "vx" = "A" * cos("pitch")*sin("roll")
     //\\ st' "vy" = --"A" * sin("pitch")
     //\\ st' "vz" = "A" * cos("pitch")*cos("roll") - gravity
     //\\ st' "pitch" = 0 //\\ st' "roll" = 0 //\\
          st' "A" = 0.

  Lemma quadcopter_evolve_enabled :
    |-- Enabled (World W_quad).
  Admitted.

  Definition Quadcopter (D : ActionFormula) :=
    Sys (D //\\ next small_angle) W_quad delta.

  Lemma Enabled_small_angle :
    |-- Enabled (next small_angle).
  Proof.
    enable_ex_st. unfold angle_max. exists R0. exists R0.
    exists R0. solve_linear.
  Qed.

  Theorem Quadcopter_refine :
    forall D W I,
      |-- TimedPreserves delta I (Sys D W delta) ->
      |-- SysNeverStuck delta I (Sys D W delta) ->
      D |-- next small_angle ->
      W_quad |-- W ->
      |-- TimedPreserves delta I (Quadcopter D) //\\
          SysNeverStuck delta I (Quadcopter D).
  Proof.
    intros.
    assert (D //\\ next small_angle -|- D)
      by (split; charge_tauto).
    charge_split.
    { unfold Quadcopter, TimedPreserves, Preserves in *.
      rewrite H3. charge_intros. charge_apply H. rewrite H2.
      charge_tauto. }
    { unfold Quadcopter, SysNeverStuck, Sys in *.
      charge_intros. rewrite limplValid in H0. rewrite H0.
      repeat (rewrite <- Enabled_and_push; [| intuition]).
      charge_split; [ charge_assumption | ].
      repeat rewrite <- Enabled_or. charge_cases.
      { rewrite H3. charge_tauto. }
      { charge_right. charge_clear.
        apply quadcopter_evolve_enabled. } }
  Qed.

  Theorem Quadcopter_refine_SafeAndReactive :
    forall D W I,
      |-- SafeAndReactive delta I (Sys D W delta) ->
      D |-- next small_angle ->
      W_quad |-- W ->
      |-- SafeAndReactive delta I (Quadcopter D).
  Proof.
    unfold SafeAndReactive. intros.
    eapply Quadcopter_refine; eauto.
    rewrite landL1 in H. eassumption. reflexivity.
    rewrite landL2 in H. eassumption. reflexivity.
  Qed.

  Lemma SysDisjoin_Quadcopter' :
    forall I1 I2 D1 D2,
        Quadcopter
          (Sys_D (SysDisjoin I1 (Quadcopter D1)
                             I2 (Quadcopter D2)))
    -|- SysDisjoin I1 (Quadcopter D1) I2 (Quadcopter D2).
  Proof.
    unfold SysDisjoin, Quadcopter, Sys, Sys_D, Discr. intros.
    split; charge_cases; try charge_tauto.
  Qed.

  Lemma SysDisjoin_Quadcopter :
    forall I1 I2 D1 D2,
        Quadcopter (SysDisjoin I1 (Sys D1 W_quad delta)
                               I2 (Sys D2 W_quad delta))
    -|- SysDisjoin I1 (Quadcopter D1) I2 (Quadcopter D2).
  Proof.
    unfold SysDisjoin, Quadcopter, Sys, Sys_D, Discr. intros.
    split; charge_cases; try charge_tauto.
  Qed.

  Require Import Coq.Classes.Morphisms.
  Lemma Proper_Quadcopter_lequiv :
    Proper (lequiv ==> lequiv) Quadcopter.
  Proof.
    morphism_intro. unfold Quadcopter. rewrite H.
    reflexivity.
  Qed.

  Lemma Proper_Quadcopter_lentails :
    Proper (lentails ==> lentails) Quadcopter.
  Proof.
    morphism_intro. unfold Quadcopter. rewrite H.
    reflexivity.
  Qed.

End quadcopter.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.SeparationLogic.Complete.ContextProperty_Flat.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section TruthLemma.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {GammaP: Provable L}
        {GammaD: Derivable L}
        {SC: NormalSequentCalculus L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {ipSC: IntuitionisticPropositionalSequentCalculus L GammaD}
        {AX: NormalAxiomatization L GammaP GammaD}
        {minAX: MinimumAxiomatization L GammaP}
        {ipAX: IntuitionisticPropositionalLogic L GammaP}
        {sepconAX: SepconAxiomatization L GammaP}
        {wandAX: WandAxiomatization L GammaP}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {J: Join (Kworlds M)}
        {SM: Semantics L MD}
        {fsepconSM: SepconSemantics L MD M SM}
        {fwandSM: WandSemantics L MD M SM}.

Context (cP: context -> Prop)
        (rel: bijection (Kworlds M) (sig cP)).

Hypothesis H_R: forall m n Phi Psi, rel m Phi -> rel n Psi -> (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).

Hypothesis H_J: forall m1 m2 m Phi1 Phi2 Phi, rel m1 Phi1 -> rel m2 Phi2 -> rel m Phi -> (join m1 m2 m <-> Included _ (context_sepcon (proj1_sig Phi1) (proj1_sig Phi2)) (proj1_sig Phi)).

Lemma truth_lemma_sepcon
      (AL_DC: at_least derivable_closed cP)
      (LIN_SL: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_l Phi (proj1_sig Psi)) cP)
      (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP)
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x * y <-> proj1_sig Phi (x * y)).
Proof.
  intros.
  rewrite sat_sepcon.
  split; intros.
  + destruct H0 as [m1 [m2 [? [? ?]]]].
    destruct (im_bij _ _ rel m1) as [Phi1 ?].
    destruct (im_bij _ _ rel m2) as [Phi2 ?].
    erewrite IHx in H1 by eauto.
    erewrite IHy in H2 by eauto.
    erewrite H_J in H0 by eauto.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
    apply derivable_assum.
    apply H0.
    exists x, y; split; [| split]; auto; apply derivable_assum; auto.
  + apply derivable_assum in H0.
    assert (Included _ (context_sepcon (Union _ empty_context (Singleton _ x))
             (Union _ empty_context (Singleton _ y))) (proj1_sig Phi)).
    {
      hnf; intros z ?.
      destruct H1 as [x0 [y0 [? [? ?]]]].
      rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)).
      rewrite deduction_theorem, <- provable_derivable in H2, H3.
      subst z; rewrite <- H2, <- H3.
      auto.
    }
    apply LIN_SL in H1.
    destruct H1 as [Phi1 [? ?]].
    apply LIN_SR in H2.
    destruct H2 as [Phi2 [? ?]].
    destruct (su_bij _ _ rel Phi1) as [m1 ?].
    destruct (su_bij _ _ rel Phi2) as [m2 ?].
    exists m1, m2.
    erewrite H_J, IHx, IHy by eauto.
    split; [| split]; auto.
    - apply H1; right; constructor.
    - apply H2; right; constructor.
Qed.

Lemma truth_lemma_wand
      (AL_DC: at_least derivable_closed cP)
      (LIN_CD: forall x, Lindenbaum_constructable (cannot_derive x) cP)
      (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP)
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x -* y <-> proj1_sig Phi (x -* y)).
Proof.
  intros.
  rewrite sat_wand.
  split; intros.
  + rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)); auto.
    rewrite <- wand_deduction_theorem.
    apply NNPP; intro.
    apply LIN_CD in H1.
    destruct H1 as [Phi2 [? ?]].
    apply H2; clear H2.
    rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi2)); auto.
    apply LIN_SR in H1.
    destruct H1 as [Phi1 [? ?]].
    destruct (su_bij _ _ rel Phi1) as [m1 ?].
    destruct (su_bij _ _ rel Phi2) as [m2 ?].
    erewrite <- IHy by eauto.
    unfold context_sepcon_included_r in H2; erewrite <- H_J in H2 by eauto.
    apply (H0 _ _ H2).
    erewrite IHx by eauto.
    apply H1; right; constructor.
  + destruct (im_bij _ _ rel m1) as [Phi1 ?].
    destruct (im_bij _ _ rel m2) as [Phi2 ?].
    erewrite IHy by eauto.
    erewrite IHx in H2 by eauto.
    erewrite H_J in H1 by eauto.
    rewrite derivable_closed_element_derivable in H0 by (apply AL_DC, (proj2_sig Phi)).
    rewrite derivable_closed_element_derivable in H2 by (apply AL_DC, (proj2_sig Phi1)).
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi2)).
    rewrite <- provable_wand_sepcon_modus_ponens1 with (x0 := x).
    apply derivable_assum; apply H1.
    exists (x -* y), x; split; [| split]; auto.
Qed.

Context {empL: EmpLanguage L}
        {empAX: EmpAxiomatization L GammaP}
        {fempSM: EmpSemantics L MD M SM}.

Lemma truth_lemma_emp
      (AL_DC: at_least derivable_closed cP)
      (LIN_CD: forall x, Lindenbaum_constructable (cannot_derive x) cP)
      (LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= emp <-> proj1_sig Phi emp).
Proof.
  intros.
  rewrite sat_emp.
  split; intros.
  + rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi)); auto.
    rewrite <- (provable_wand_sepcon_modus_ponens1 emp).
    rewrite sepcon_emp.
    apply wand_deduction_theorem.
    apply NNPP; intro.
    apply LIN_CD in H1.
    destruct H1 as [Phi2 [? ?]].
    apply H2; clear H2.
    rewrite <- derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi2)); auto.
    apply LIN_SR in H1.
    destruct H1 as [Phi1 [? ?]].
    destruct (su_bij _ _ rel Phi1) as [m1 ?].
    destruct (su_bij _ _ rel Phi2) as [m2 ?].
    unfold context_sepcon_included_r in H2; erewrite <- H_J in H2 by eauto.
    apply H0 in H2.
    erewrite H_R in H2 by eauto.
    apply H2, H1; right; constructor.
  + hnf; intros n1 n2 ?.
    destruct (im_bij _ _ rel n1) as [Phi1 ?].
    destruct (im_bij _ _ rel n2) as [Phi2 ?].
    erewrite H_R by eauto.
    erewrite H_J in H1 by eauto.
    intros x; unfold Ensembles.In; intros.
    rewrite derivable_closed_element_derivable by (apply AL_DC, (proj2_sig Phi2)); auto.
    rewrite derivable_closed_element_derivable in H4 by (apply AL_DC, (proj2_sig Phi1)); auto.
    rewrite derivable_closed_element_derivable in H0 by (apply AL_DC, (proj2_sig Phi)); auto.
    rewrite <- sepcon_emp, sepcon_comm.
    apply derivable_assum; apply H1.
    exists emp, x; split; [| split]; auto.
Qed.

End TruthLemma.


Require Import Bitoychain.Coqlib.
Require Import List. Import ListNotations.
Require Import Bitoychain.Integers.
Require Import Bitoychain.Coqlib2.
Require Import Bitoychain.coqlib3.
Require Import Bitoychain.sublist.

Local Open Scope nat.

Fixpoint map2 {A B C: Type} (f: A -> B -> C) (al: list A) (bl: list B) : list C :=
 match al, bl with
  | a::al', b::bl' => f a b :: map2 f al' bl'
  | _, _ => nil
  end.

Lemma length_map2:
 forall A B C (f: A -> B -> C) al bl n,
  length al = n -> length bl = n ->
  length (map2 f al bl) = n.
Proof.
induction al; destruct bl,n; simpl; intros; auto.
inv H.
Qed.

Lemma list_repeat_injective {A} (a a':A) n: (0<n)%nat ->
      list_repeat n a = list_repeat n a' -> a=a'.
  Proof. intros.
    destruct n. omega. simpl in H0. inversion H0. trivial.
  Qed.

Local Open Scope Z.

Definition roundup (a b : Z) := (a + (b-1))/b*b.

Lemma roundup_minus:
   forall a b,  b > 0 -> roundup a b - a = (- a) mod b.
Proof.
unfold roundup; intros.
replace (a+(b-1)) with (a-1+1*b) by omega.
rewrite Z_div_plus_full by omega.
rewrite Z.mul_add_distr_r.
assert (H4 := Zmod_eq a b H).
assert (a mod b = 0 \/ a mod b <> 0) by omega.
destruct H0; [rewrite Z.mod_opp_l_z | rewrite Z.mod_opp_l_nz]; try omega.
rewrite H0 in H4.
assert (a = a/b*b) by omega.
rewrite H1 at 1.
replace (a/b*b-1) with (a/b*b+ -1) by omega.
rewrite Z_div_plus_full_l by omega.
rewrite Z.mul_add_distr_r.
rewrite <- H1.
assert (b=1 \/ b>1) by omega.
destruct H2.
subst b. simpl. omega.
rewrite (Z_div_nz_opp_full 1) by (rewrite Z.mod_small; omega).
rewrite  Z.div_small by omega.
omega.
rewrite H4.
assert ( (a-1)/b*b = a/b*b); [ | omega].
f_equal.
assert (a = a mod b + a/b*b) by omega.
replace (a-1) with (a mod b - 1 + a/b*b) by omega.
rewrite Z_div_plus_full by omega.
rewrite Z.div_small; try omega.
pose proof (Z_mod_lt a b H).
omega.
Qed.

Definition isbyteZ (i: Z) := (0 <= i < 256)%Z.

Definition Shr b x := Int.shru x (Int.repr b).

Lemma isbyteZ_testbit:
  forall i j, 0 <= i < 256 -> j >= 8 -> Z.testbit i j = false.
Proof.
intros; erewrite Byte.Ztestbit_above with (n:=8%nat); auto.
Qed.

Fixpoint intlist_to_Zlist (l: list int) : list Z :=
 match l with
 | nil => nil
 | i::r =>
     Int.unsigned (Shr 24 i) ::
     Int.unsigned (Int.and (Shr 16 i) (Int.repr 255)) ::
     Int.unsigned (Int.and (Shr 8 i) (Int.repr 255)) ::
     Int.unsigned (Int.and i (Int.repr 255)) ::
     intlist_to_Zlist r
 end.

(*combining four Z into a Integer*)
Definition Z_to_Int (a b c d : Z) : Int.int :=
  Int.or (Int.or (Int.or (Int.shl (Int.repr a) (Int.repr 24)) (Int.shl (Int.repr b) (Int.repr 16)))
            (Int.shl (Int.repr c) (Int.repr 8))) (Int.repr d).

Fixpoint Zlist_to_intlist (nl: list Z) : list int :=
  match nl with
  | h1::h2::h3::h4::t => Z_to_Int h1 h2 h3 h4 :: Zlist_to_intlist t
  | _ => nil
  end.

Lemma int_min_signed_eq: Int.min_signed = -2147483648.
Proof. reflexivity. Qed.

Lemma int_max_signed_eq: Int.max_signed = 2147483647.
Proof. reflexivity. Qed.

Lemma int_max_unsigned_eq: Int.max_unsigned = 4294967295.
Proof. reflexivity. Qed.

Ltac rep_omega' :=
   pose proof int_min_signed_eq;
   pose proof int_max_signed_eq;
   pose proof int_max_unsigned_eq;
   omega.

Hint Rewrite Int.bits_or using omega : testbit.
Hint Rewrite Int.bits_shl using omega : testbit.
Hint Rewrite Int.bits_and using omega : testbit.
Hint Rewrite Int.bits_shru using omega : testbit.
Hint Rewrite Int.unsigned_repr using omega : testbit.
Hint Rewrite Int.testbit_repr using omega : testbit.
Hint Rewrite if_false using omega : testbit.
Hint Rewrite if_true using omega : testbit.
Hint Rewrite Z.ones_spec_low using omega : testbit.
Hint Rewrite Z.ones_spec_high using omega : testbit.
Hint Rewrite orb_false_r orb_true_r andb_false_r andb_true_r : testbit.
Hint Rewrite orb_false_l orb_true_l andb_false_l andb_true_l : testbit.
Hint Rewrite Z.add_simpl_r : testbit.
Hint Rewrite Int.unsigned_repr using rep_omega' : testbit.

Lemma Ztest_Inttest:
 forall a, Z.testbit (Int.unsigned a) = Int.testbit a.
Proof. reflexivity. Qed.
Hint Rewrite Ztest_Inttest : testbit.

Definition swap (i: int) : int :=
 Int.or (Int.shl (Int.and i (Int.repr 255)) (Int.repr 24))
   (Int.or (Int.shl (Int.and (Shr 8 i) (Int.repr 255)) (Int.repr 16))
      (Int.or (Int.shl (Int.and (Shr 16 i) (Int.repr 255)) (Int.repr 8))
         (Shr 24 i))).

Lemma swap_swap: forall w, swap (swap w) = w.
Proof.
unfold swap, Shr; intros.
apply Int.same_bits_eq; intros.
assert (Int.zwordsize=32) by reflexivity.
change 255 with (Z.ones 8).
assert (32 < Int.max_unsigned) by (compute; auto).
autorewrite with testbit.
if_tac; [if_tac; [if_tac | ] | ]; autorewrite with testbit; f_equal; omega.
Qed.

Lemma map_swap_involutive:
 forall l, map swap (map swap l)  = l.
Proof. intros.
 rewrite map_map.
 replace (fun x => swap (swap x)) with (@Datatypes.id int).
 apply map_id. extensionality x. symmetry; apply swap_swap.
Qed.

Lemma length_intlist_to_Zlist:
  forall l, length (intlist_to_Zlist l) = (4 * length l)%nat.
Proof.
induction l.
simpl. reflexivity. simpl. omega.
Qed.

Lemma intlist_to_Zlist_Z_to_int_cons:
  forall a b c d l,
      isbyteZ a -> isbyteZ b -> isbyteZ c -> isbyteZ d ->
     intlist_to_Zlist (Z_to_Int a b c d :: l) =
     a::b::c::d:: intlist_to_Zlist l.
Proof.
intros. simpl.
unfold isbyteZ in *.
assert (Int.zwordsize=32)%Z by reflexivity.
unfold Z_to_Int, Shr; simpl.
change 255%Z with (Z.ones 8).
repeat f_equal; auto;
match goal with |- _ = ?A => transitivity (Int.unsigned (Int.repr A));
   [f_equal | apply Int.unsigned_repr; rep_omega']
end;
apply Int.same_bits_eq; intros;
autorewrite with testbit.
*
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
rewrite (isbyteZ_testbit b) by omega.
rewrite (isbyteZ_testbit c) by omega.
rewrite (isbyteZ_testbit d) by omega.
autorewrite with testbit; auto.
*
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
rewrite (isbyteZ_testbit c) by omega.
rewrite (isbyteZ_testbit d) by omega.
autorewrite with testbit; auto.
*
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
rewrite (isbyteZ_testbit d) by omega.
autorewrite with testbit; auto.
*
destruct (zlt i 8); autorewrite with testbit;  [ | symmetry; apply isbyteZ_testbit; omega].
auto.
Qed.

Lemma intlist_to_Zlist_to_intlist:
  forall il: list int,
   Zlist_to_intlist (intlist_to_Zlist il) = il.
Proof.
induction il.
reflexivity.
simpl.
f_equal; auto. clear.
assert (Int.zwordsize=32)%Z by reflexivity.
unfold Z_to_Int, Shr; simpl.
change 255%Z with (Z.ones 8).
apply Int.same_bits_eq; intros.
rewrite Int.repr_unsigned.
autorewrite with testbit.
if_tac; autorewrite with testbit; [ | f_equal; omega].
if_tac; autorewrite with testbit; [ | f_equal; omega].
if_tac; autorewrite with testbit; [ | f_equal; omega].
auto.
Qed.

Lemma intlist_to_Zlist_app:
 forall al bl, intlist_to_Zlist (al++bl) = intlist_to_Zlist al ++ intlist_to_Zlist bl.
Proof. intros; induction al; simpl; auto. repeat f_equal; auto. Qed.
Local Open Scope nat.

Local Open Scope Z.

Lemma isbyte_intlist_to_Zlist : forall l, Forall isbyteZ (intlist_to_Zlist l).
Proof.
induction l; simpl; intros.
constructor.
assert (forall i, Int.unsigned (Int.and i (Int.repr 255)) < 256).
clear; intro.
eapply Z.lt_le_trans.
apply (Int.and_interval i (Int.repr (Z.ones 8))).
change (Int.size  (Int.repr (Z.ones 8))) with 8.
rewrite Zmin_spec.
if_tac.
eapply Z.le_trans with (two_p 8).
apply two_p_monotone.
split; [ | omega].
apply Int.size_range.
compute; congruence.
compute; congruence.
unfold Shr, isbyteZ; repeat constructor; try apply Int.unsigned_range; auto; clear IHl.
rewrite <- (Int.divu_pow2 a (Int.repr (2 ^ 24)) (Int.repr 24) (eq_refl _)).
unfold Int.divu.
rewrite Int.unsigned_repr.
rewrite Int.unsigned_repr by (compute; split; congruence).
apply Z.div_lt_upper_bound.
compute; congruence.
change (2 ^ 24 * 256)%Z with (Int.modulus).
apply Int.unsigned_range.
assert (0 < 2 ^ 24)
 by (apply Z.pow_pos_nonneg; clear; omega).
rewrite Int.unsigned_repr by (compute; split; congruence).
split.
apply Z.div_pos; auto.
apply Int.unsigned_range.
apply Z.div_le_upper_bound; auto.
apply Z.le_trans with (Int.modulus+1).
destruct (Int.unsigned_range a).
omega.
compute; congruence.
Qed.

Lemma isbyte_intlist_to_Zlist' : forall l,
   Forall isbyteZ (map Int.unsigned (map Int.repr (intlist_to_Zlist l))).
Proof.
intro.
replace (map Int.unsigned (map Int.repr (intlist_to_Zlist l))) with (intlist_to_Zlist l).
apply isbyte_intlist_to_Zlist.
induction l; simpl; auto.
repeat f_equal; auto; symmetry; apply Int.repr_unsigned.
Qed.

Lemma Forall_isbyte_repr_unsigned:
 forall l: list int, map Int.repr (map Int.unsigned l) = l.
Proof.
induction l; intros.
reflexivity.
simpl.
f_equal; auto.
apply Int.repr_unsigned.
Qed.

Lemma map_unsigned_repr_isbyte:
  forall l : list Z , Forall isbyteZ l -> map Int.unsigned (map Int.repr l) = l.
Proof. induction l; simpl; intros; auto.
  inv H. f_equal; auto. unfold isbyteZ in H2; apply Int.unsigned_repr.
 assert (Int.max_unsigned > 256)%Z by (compute; congruence).
 omega.
Qed.

Lemma int_unsigned_inj: forall a b, Int.unsigned a = Int.unsigned b -> a=b.
Proof.
intros.
rewrite <- (Int.repr_unsigned a); rewrite <- (Int.repr_unsigned b).
congruence.
Qed.

Lemma intlist_to_Zlist_inj: forall al bl, intlist_to_Zlist al = intlist_to_Zlist bl -> al=bl.
Proof.
induction al; destruct bl; intros; auto.
inv H.
inv H.
simpl in H.
injection H; intros.
f_equal; auto.
clear - H1 H2 H3 H4.
rename i into b.
apply int_unsigned_inj in H1.
apply int_unsigned_inj in H2.
apply int_unsigned_inj in H3.
apply int_unsigned_inj in H4.
unfold Shr in *.
apply Int.same_bits_eq; intros.
assert (Int.zwordsize=32)%Z by reflexivity.
change 255%Z with (Z.ones 8) in *.
destruct (zlt i 8).
transitivity (Int.testbit (Int.and a (Int.repr (Z.ones 8))) i).
autorewrite with testbit; auto.
rewrite H1. autorewrite with testbit; auto.
destruct (zlt i 16).
transitivity (Int.testbit (Int.and (Int.shru a (Int.repr 8)) (Int.repr (Z.ones 8))) (i-8)).
autorewrite with testbit.
change (Int.unsigned (Int.repr 8)) with 8%Z.
rewrite Z.sub_add; auto.
rewrite H2.
autorewrite with testbit.
rewrite Z.sub_add. auto.
destruct (zlt i 24).
transitivity (Int.testbit (Int.and (Int.shru a (Int.repr 16)) (Int.repr (Z.ones 8))) (i-16)).
autorewrite with testbit.
change (Int.unsigned (Int.repr 16)) with 16%Z.
rewrite Z.sub_add. auto.
rewrite H3.
autorewrite with testbit.
change (Int.unsigned (Int.repr 16)) with 16%Z.
rewrite Z.sub_add. auto.
transitivity (Int.testbit (Int.shru a (Int.repr 24)) (i-24)).
autorewrite with testbit.
change (Int.unsigned (Int.repr 24)) with 24%Z.
rewrite Z.sub_add. auto.
rewrite H4.
autorewrite with testbit.
change (Int.unsigned (Int.repr 24)) with 24%Z.
rewrite Z.sub_add. auto.
Qed.

Lemma Zlength_intlist_to_Zlist_app:
 forall al bl,  Zlength (intlist_to_Zlist (al++bl)) =
    (Zlength (intlist_to_Zlist al) + Zlength (intlist_to_Zlist bl))%Z.
Proof.
induction al; simpl; intros; auto.
repeat rewrite Zlength_cons.
rewrite IHal.
omega.
Qed.

Local Open Scope Z.

Lemma Forall_isbyteZ_unsigned_repr:
 forall l, Forall isbyteZ l -> Forall isbyteZ (map Int.unsigned (map Int.repr l)).
Proof. induction 1. constructor.
constructor. rewrite Int.unsigned_repr; auto.
unfold isbyteZ in H; rep_omega'.
apply IHForall.
Qed.

Lemma divide_length_app:
 forall {A} n (al bl: list A),
      (n | Zlength al) ->
      (n | Zlength bl) ->
      (n | Zlength (al++bl)).
Proof.
 intros. destruct H,H0. exists (x+x0)%Z.
 rewrite Zlength_app,H,H0;
 rewrite Z.mul_add_distr_r; omega.
Qed.

Lemma nth_list_repeat: forall A i n (x :A),
    nth i (list_repeat n x) x = x.
Proof.
 induction i; destruct n; simpl; auto.
Qed.

Lemma map_list_repeat:
  forall A B (f: A -> B) n x,
     map f (list_repeat n x) = list_repeat n (f x).
Proof. induction n; simpl; intros; f_equal; auto.
Qed.

Lemma isbyteZ_sublist data lo hi: Forall isbyteZ data -> Forall isbyteZ (sublist lo hi data).
Proof. intros. destruct (Forall_forall isbyteZ data) as [F _].
   apply Forall_forall. intros. apply (F H x). eapply sublist_In. apply H0.
Qed.

Lemma map_IntReprOfBytes_injective: forall l m, Forall isbyteZ  l ->
  Forall isbyteZ m -> map Int.repr l = map Int.repr m -> l=m.
Proof. induction l; intros.
+ destruct m; simpl in *; inv H1; trivial.
+ destruct m; simpl in *. inv H1.
  assert (Int.repr a = Int.repr z /\  map Int.repr l = map Int.repr m).
  { forget (Int.repr a) as q. forget (Int.repr z) as w. inv H1; split; trivial. }
  clear H1. destruct H2. inv H. inv H0.
  rewrite (IHl m); trivial. f_equal.
  clear IHl H2 H6 H7.
  unfold isbyteZ in *. simpl in *.
  rewrite <- (Int.unsigned_repr a), <- (Int.unsigned_repr z), H1; trivial;
  rewrite int_max_unsigned_eq; omega.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export approx_props2.
Require Export sequents_tacs.
Require Export sequents_tacs2.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export per_props_nat.
Require Export per_can.
Require Export per_props_top.
Require Export computation_arith.

Lemma computes_to_integer_member_int {o} :
   forall lib (z : Z) (t : CTerm),
   computes_to_valc lib t (mkc_integer z) -> member lib t (@mkc_int o).
Proof.
      unfold member, equality; sp.
      exists (@equality_of_int o lib);sp; [apply equality_of_int_xxx| exists z; sp; spcast; auto].
Qed.

Lemma member_int_iff {o} :
   forall lib  (t : CTerm),
   member lib t (@mkc_int o) <-> Cast {z : Z $  computes_to_valc lib t (mkc_integer z)}.
Proof. intros; split; intro.
      - unfold member in H. apply equality_in_int in H. unfold equality_of_int in H.
        exrepnd. unfold ccomputes_to_valc in H0. destruct H0; exrepnd.
        constructor. exists k; auto.
      - destruct H. exrepnd. apply computes_to_integer_member_int in X0. auto.
Qed.

Lemma  cequiv_member_int {o} :
  forall lib (z :Z) (a b : CTerm),
   cequivc lib a b ->
   computes_to_valc lib a (mkc_integer z) ->
   tequality lib (mkc_member a (@mkc_int o)) (mkc_member b (@mkc_int o)).
Proof. introv ceq compa.

  pose proof (cequivc_integer lib a b z).
  assert (computes_to_valc lib b (mkc_integer z)) as compb by auto.
  clear X.
  rw (@tequality_mkc_member o); sp.
  apply tequality_int.
  apply computes_to_integer_member_int in compa.
  apply computes_to_integer_member_int in compb.
  split; auto.
  apply equality_respects_cequivc; auto.
Qed.

Lemma tequality_member_int {o} :
  forall lib (t1 t2: CTerm),
  tequality lib (mkc_member t1 mkc_int)
                (mkc_member t2 (@mkc_int o)) ->
    member lib t1 mkc_int ->
   equality_of_int lib t1 t2.
Proof. introv teq mem. apply equality_in_int. apply tequality_mkc_member in teq.
       exrepnd. repndors; auto.
Qed.

Lemma  computes_to_value_arithop {o} :
  forall lib op (a b : (@NTerm o)) i j,
   (a =v>(lib) (mk_integer i))->
   (b =v>(lib)  (mk_integer j))->
   ((mk_arithop op a b) =v>(lib) (mk_integer (get_arith_op op i j))).
Proof. introv ai bj. allunfold @computes_to_value; exrepnd; split; eauto 3 with slow.
    apply reduces_to_arithop; auto.
Qed.

Lemma  computes_to_valc_arithop {o} :
  forall lib op (a b : (@CTerm o)) i j,
   computes_to_valc lib a (mkc_integer i)->
   computes_to_valc lib b (mkc_integer j)->
  computes_to_valc lib (mkc_arithop op a b) (mkc_integer (get_arith_op op i j)).
Proof. introv ai bj. allunfold @computes_to_valc.
       destruct a. destruct b. allsimpl.
       apply computes_to_value_arithop; auto.
Qed.

Lemma  ccomputes_to_valc_arithop {o} :
  forall lib op (a b : (@CTerm o)) i j,
   a ===>( lib)(mkc_integer i)->
   b ===>( lib)(mkc_integer j)->
  (mkc_arithop op a b) ===>( lib)(mkc_integer (get_arith_op op i j)).
Proof.
  unfold ccomputes_to_valc; introv ai bj.
  destruct ai. destruct bj. constructor.
  apply computes_to_valc_arithop; auto.
Qed.

Lemma equality_of_int_arithop {o} :
  forall lib op (a b c d: (@CTerm o)),
   equality_of_int lib a b ->
   equality_of_int lib c d ->
   equality_of_int lib (mkc_arithop op a c) (mkc_arithop op b d).
Proof.
    introv ab cd. allunfold @equality_of_int. exrepnd.
    exists (get_arith_op op k0 k); split; apply ccomputes_to_valc_arithop; auto.
Qed.

Lemma equality_of_int_mkc_integer {o} :
  forall lib  i j,
  equality_of_int lib (mkc_integer i) (@mkc_integer o j) <-> i = j.
Proof.  intros; split; introv H.
  - unfold equality_of_int in H; exrepnd; spcast.
    allunfold @computes_to_valc. allunfold @get_cterm. allunfold @mkc_integer.
    allunfold @computes_to_value. sp. allapply @integer_reduces_to; subst; auto.
  - subst. unfold equality_of_int. exists j; split; spcast; apply computes_to_valc_refl;
    apply iscvalue_mkc_integer.
Qed.
(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


Require Import Category.Lib.
Require Import Category.Theory.Category.

Generalizable All Variables.

Section Terminal.

Context {C : Category}.

Class Terminal := {
  terminal_obj : C;
  one {x} : x ~> terminal_obj;

  one_unique {x} (f g : x ~> terminal_obj) : f ≈ g
}.

End Terminal.

Notation "1" := terminal_obj : object_scope.

Corollary one_comp `{@Terminal C} {x y : C} {f : x ~> y} :
  one ∘ f ≈ one.
Proof. intros; apply one_unique. Qed.

Notation "one[ C ]" := (@one _ _ C)
  (at level 9, format "one[ C ]") : morphism_scope.

Definition const `{@Terminal C} {x y : C} {f : 1 ~> y} := f ∘ one[x].


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable tP_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defparallelogram_1 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_2 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).
Variable defparallel_3 : (forall A B C D : Universe, (exists U V Su Sv X : Universe, (par_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V))))))))))))).
Variable defparallel2_4 : (forall A B C D U V Su Sv X : Universe, ((A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V)))))))))) -> par_ A B C D)).
Variable lemma_parallelsymmetric_5 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).
Variable lemma_paralleldef2B_6 : (forall A B C D : Universe, (par_ A B C D -> tP_ A B C D)).
Variable deftarski_parallel_7 : (forall A B C D : Universe, (tP_ A B C D -> (A <> B /\ (C <> D /\ (~(meet_ A B C D) /\ oS_ C D A B))))).
Variable deftarski_parallel2_8 : (forall A B C D : Universe, ((A <> B /\ (C <> D /\ (~(meet_ A B C D) /\ oS_ C D A B))) -> tP_ A B C D)).
Variable defcollinear_9 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_10 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_11 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_12 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_13 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_14 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_15 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_16 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable defmeet_17 : (forall A B C D : Universe, (exists X : Universe, (meet_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X)))))).
Variable defmeet2_18 : (forall A B C D X : Universe, ((A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X))) -> meet_ A B C D)).
Variable lemma_extension_19 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable defoppositeside_20 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_21 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable lemma_samesidesymmetric_22 : (forall A B P Q : Universe, (oS_ P Q A B -> (oS_ Q P A B /\ (oS_ P Q B A /\ oS_ Q P B A)))).
Variable lemma_planeseparation_23 : (forall A B C D E : Universe, ((oS_ C D A B /\ tS_ D A B E) -> tS_ C A B E)).
Variable axiom_betweennesssymmetry_24 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_betweennotequal_25 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_collinear4_26 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_collinearbetween_27 : (forall A B C D E F H : Universe, ((col_ A E B /\ (col_ C F D /\ (A <> B /\ (C <> D /\ (A <> E /\ (F <> D /\ (~(meet_ A B C D) /\ (betS_ A H D /\ col_ E F H)))))))) -> betS_ E H F)).
Variable lemma_inequalitysymmetric_28 : (forall A B : Universe, (A <> B -> B <> A)).
Variable postulate_Pasch_outer_29 : (forall A B C P Q : Universe, (exists X : Universe, ((betS_ A P C /\ (betS_ B C Q /\ ~(col_ B Q A))) -> (betS_ A X Q /\ betS_ B P X)))).
Variable lemma_collinear5_30 : (forall A B C D E : Universe, ((A <> B /\ (col_ A B C /\ (col_ A B D /\ col_ A B E))) -> col_ C D E)).
Variable postulate_Pasch_inner_31 : (forall A B C P Q : Universe, (exists X : Universe, ((betS_ A P C /\ (betS_ B Q C /\ ~(col_ A C B))) -> (betS_ A X Q /\ betS_ B X P)))).
Variable lemma_3_6b_32 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ A C D) -> betS_ A B D)).

Theorem lemma_diagonalsmeet_33 : (forall A B C D : Universe, (exists X : Universe, (pG_ A B C D -> (betS_ A X C /\ betS_ B X D)))).
Proof.
  time tac.
Qed.

End FOFProblem.


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

 Terminal objects in enriched categories

 In this file, we define the notion of a terminal objects in the
 context of enriched category theory.

 The first we formulate, is the universal property of terminal
 objects. This must be done in a slightly differently compared to
 the terminal objects of ordinary categories. Usually, the
 universal property of terminal objects is expressed by saying
 that for each object the set of morphisms between them is
 equivalent to the unit set. This universal property is expressed
 in the category of sets. For enriched categories, we express it
 in the monoidal category `V` over which we enriched. More
 specifically, we say that the hom-object is a terminal object.

 One interesting aspect about limits and colimits in enriched
 category theory is that under certain conditions, we can deduce
 the existence of enriched limits from the existence of ordinary
 limits in the underlying category. A condition that allows us to
 do so, is conservativity of the functor `V(1, -)`. This
 conservativity allows us to prove that a morphism in `V` is
 isomorphic by only looking at the underlying category. Examples
 of monoidal categories that satisfy this condition include the
 category of abelian groups or the category of R-modules. The
 reason why they are conservative, is because a morphism in those
 categories is an isomorphism if and only if the underlying
 morphism between sets is an equivalence.

 We also prove that terminal objects are closed under isomorphism
 and that any two terminal objects are isomorphic.

 Contents
 1. Terminal objects in an enriched category
 2. Being terminal is a proposition
 3. Accessors for terminal objects
 4. Builders for terminal objects
 5. Being terminal is closed under iso
 6. Terminal objects are isomorphic
 7. Enriched categories with a terminal object

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.limits.terminal.

Import MonoidalNotations.
Local Open Scope cat.
Local Open Scope moncat.

Section EnrichedTerminal.
  Context {V : monoidal_cat}
          {C : category}
          (E : enrichment C V).

  (**
   1. Terminal objects in an enriched category
   *)
  Definition is_terminal_enriched
             (x : C)
    : UU
    := ∏ (y : C), isTerminal V (E ⦃ y, x ⦄).

  Definition terminal_enriched
    : UU
    := ∑ (x : C), is_terminal_enriched x.

  Coercion terminal_enriched_to_ob
           (x : terminal_enriched)
    : C
    := pr1 x.

  Coercion terminal_enriched_to_is_terminal
           (x : terminal_enriched)
    : is_terminal_enriched x
    := pr2 x.

  (**
   2. Being terminal is a proposition
   *)
  Proposition isaprop_is_terminal_enriched
              (x : C)
    : isaprop (is_terminal_enriched x).
  Proof.
    do 2 (use impred ; intro).
    apply isapropiscontr.
  Qed.

  (**
   3. Accessors for terminal objects
   *)
  Section Accessors.
    Context {x : C}
            (Hx : is_terminal_enriched x).

    Definition is_terminal_enriched_arrow
               (y : C)
      : I_{V} --> E ⦃ y , x ⦄
      := TerminalArrow (_ ,, Hx y) I_{V}.

    Definition is_terminal_enriched_eq
               {y : C}
               (f g : I_{V} --> E ⦃ y , x ⦄)
      : f = g.
    Proof.
      apply (@TerminalArrowEq _ (_ ,, Hx y) I_{V}).
    Qed.

    Definition terminal_underlying
      : Terminal C.
    Proof.
      refine (x ,, _).
      intros y.
      use iscontraprop1.
      - abstract
          (use invproofirrelevance ;
           intros f g ;
           refine (!(enriched_to_from_arr E f) @ _ @ enriched_to_from_arr E g) ;
           apply maponpaths ;
           apply is_terminal_enriched_eq).
      - exact (enriched_to_arr E (is_terminal_enriched_arrow y)).
    Defined.
  End Accessors.

  (**
   4. Builders for terminal objects
   *)
  Definition make_is_terminal_enriched
             (x : C)
             (f : ∏ (w : V) (y : C), w --> E ⦃ y , x ⦄)
             (p : ∏ (w : V) (y : C) (f g : w --> E ⦃ y , x ⦄), f = g)
    : is_terminal_enriched x.
  Proof.
    intros y w.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros φ₁ φ₂ ;
         apply p).
    - apply f.
  Defined.

  Definition make_is_terminal_enriched_from_iso
             (TV : Terminal V)
             (x : C)
             (Hx : ∏ (y : C),
                   is_z_isomorphism (TerminalArrow TV (E ⦃ y, x ⦄)))
    : is_terminal_enriched x.
  Proof.
    intros y.
    use (iso_to_Terminal TV).
    exact (z_iso_inv (TerminalArrow TV (E ⦃ y, x ⦄) ,, Hx y)).
  Defined.

  Definition terminal_enriched_from_underlying
             (TC : Terminal C)
             (TV : Terminal V)
             (HV : conservative_moncat V)
    : is_terminal_enriched TC.
  Proof.
    use (make_is_terminal_enriched_from_iso TV).
    intro y.
    use HV.
    use isweq_iso.
    - intro f.
      apply enriched_from_arr.
      apply (TerminalArrow TC).
    - abstract
        (intros f ; cbn ;
         refine (_ @ enriched_from_to_arr E f) ;
         apply maponpaths ;
         apply TerminalArrowEq).
    - abstract
        (intros f ; cbn ;
         apply TerminalArrowEq).
  Defined.

  (**
   5. Being terminal is closed under iso
   *)
  Definition terminal_enriched_from_iso
             {x y : C}
             (Hx : is_terminal_enriched x)
             (f : z_iso x y)
    : is_terminal_enriched y.
  Proof.
    intros w.
    use (iso_to_Terminal (_ ,, Hx w)) ; cbn.
    exact (postcomp_arr_z_iso E w f).
  Defined.

  (**
   6. Terminal objects are isomorphic
   *)
  Definition iso_between_terminal_enriched
             {x y : C}
             (Hx : is_terminal_enriched x)
             (Hy : is_terminal_enriched y)
    : z_iso x y.
  Proof.
    use make_z_iso.
    - exact (enriched_to_arr E (is_terminal_enriched_arrow Hy x)).
    - exact (enriched_to_arr E (is_terminal_enriched_arrow Hx y)).
    - split.
      + abstract
          (refine (enriched_to_arr_comp E _ _ @ _ @ enriched_to_arr_id E _) ;
           apply maponpaths ;
           apply (is_terminal_enriched_eq Hx)).
      + abstract
          (refine (enriched_to_arr_comp E _ _ @ _ @ enriched_to_arr_id E _) ;
           apply maponpaths ;
           apply (is_terminal_enriched_eq Hy)).
  Defined.

  Definition isaprop_terminal_enriched
             (HC : is_univalent C)
    : isaprop terminal_enriched.
  Proof.
    use invproofirrelevance.
    intros φ₁ φ₂.
    use subtypePath.
    {
      intro.
      apply isaprop_is_terminal_enriched.
    }
    use (isotoid _ HC).
    use iso_between_terminal_enriched.
    - exact (pr2 φ₁).
    - exact (pr2 φ₂).
  Defined.
End EnrichedTerminal.

(**
 7. Enriched categories with a terminal object
 *)
Definition cat_with_enrichment_terminal
           (V : monoidal_cat)
  : UU
  := ∑ (C : cat_with_enrichment V), terminal_enriched C.

Coercion cat_with_enrichment_terminal_to_cat_with_enrichment
         {V : monoidal_cat}
         (C : cat_with_enrichment_terminal V)
  : cat_with_enrichment V
  := pr1 C.

Definition terminal_of_cat_with_enrichment
           {V : monoidal_cat}
           (C : cat_with_enrichment_terminal V)
  : terminal_enriched C
  := pr2 C.