Module AssetMapping.
Require Export Coq.Lists.ListSet.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export maps_def.
Require Export assettheory_def.
Require Export formulatheory_def.
Require Export featuremodelsemantics_def.
Require Export assettheory_int.
Require Export assettheory_inst.
Import FormulaTheory.
Import Maps.
Import AssetTheory.
Import FeatureModelSemantics.

  Definition pair : Type := AssetName * Asset.
  Definition pairs := set pair.
  (** Um AM se trata de um map_*)
  Definition AM := map_.

  (* Asset mapping refinement *)
  (** Para os mapeamentos de ativos A e A ', o último refina
     o primeiro, denotado por A ⊑ A', sempre que:
     dom (A) = dom (A ') ∧ ∀ n ∈ dom (A) · A <n> ⊑ A' < n> *)
  Definition aMR_func (am1 am2: AM) : Prop := (dom_func am1 = dom_func am2) /\
    forall (an : AssetName), set_In an (dom_func am1) ->
      exists (a1 a2: Asset), (isMappable_func am1 an a1)
        /\ (isMappable_func am2 an a2)
          /\ (assetRef_func (set_add Asset_dec a1 nil) (set_add Asset_dec a2 nil)).

  (*Axiom <Asset refinement is pre-order>*)
  Axiom assetMappingRefinement_axiom:
    forall x y z: AM, aMR_func x x /\ aMR_func x y -> aMR_func y z ->  aMR_func x z.

End AssetMapping.


(** CS6225 -- Problem Set 4b (200 points) *)

(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 2 *)

Require Import Frap.

(* Authors:
 * Ben Sherman (sherman@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

(** * Polymorphic container types *)

(* In this problem set, we'll get some practice using some of the polymorphic
 * container types, in particular, [option], [list], and [tree]. We'll then use
 * [tree] and [option] together to create binary tries (i.e., finite maps keyed
 * by lists of Booleans).
 *
 * First, we'll reproduce some definitions we need from Lecture 2,
 * [tree] and [flatten]:
 *)

Inductive tree {A} :=
| Leaf
| Node (l : tree) (d : A) (r : tree).
Arguments tree : clear implicits.

Fixpoint flatten {A} (t : tree A) : list A :=
  match t with
  | Leaf => []
  | Node l d r => flatten l ++ d :: flatten r
  end.

(* And here's one additional definition that we'll use in this problem set.
 * [either] combines two [option] values into one.
 * If either argument to [either] is a [Some], then so is
 * the result of the [either], preferring the contents of
 * the first argument if both are [Some].
 *
 * We will observe an "analogy" between the [either]
 * function on options and the [++] function on lists.
 *)
Definition either {A} (xo yo : option A) : option A :=
  match xo with
  | None => yo
  | Some x => Some x
  end.

(* A binary trie is a finite map keyed by lists of Booleans.
 * We will implement a binary trie with entries of type [A]
 * by [tree (option A)]. The value at the root of the tree
 * corresponds to the entry for the key [nil : list bool],
 * the left subtree contains entries for those keys that
 * begin with [true], and the right subtree contains entries
 * for those keys that begin with [false].
 *)

Definition binary_trie A := tree (option A).

(* Here, again, is the module type setting out exactly which theorems you need
 * to prove for full credit on this assignment. *)
Module Type S.

  (* If we [either] an [option] value with [None]
   * on the right, it leaves that value unchanged,
   * (just as if we put the [None] on the left).
   * This is analogous to how appending [nil]
   * on either side of a list leaves it unchanged.
   *)
  Axiom either_None_right : forall {A} (xo : option A),
    either xo None = xo.
  (* 10 points *)

  (* [either] is associative, just like [++].
   *)
  Axiom either_assoc : forall {A} (xo yo zo : option A),
    either (either xo yo) zo = either xo (either yo zo).
  (* 10 points *)

  (* [head] should compute the head of a list, that is,
   * it should return [Some] with the first element of
   * the list if the list is nonempty, and [None]
   * if the list is empty.
   *)
  Parameter head : forall {A}, list A -> option A.
  (* 10 points *)

  Axiom head_example : head [1; 2; 3] = Some 1.
  (* 10 points *)

  (* The following theorem makes a formal connection
   * between [either] and [++].
   *)
  Axiom either_app_head : forall {A} (xs ys : list A),
      head (xs ++ ys) = either (head xs) (head ys).
  (* 10 points *)

  (* [leftmost_Node] should compute the leftmost node of
   * a tree.
   *
   * Please implement [leftmost_Node] directly using
   * recursion (i.e., pattern matching) on the [tree] argument,
   * without using the [flatten] operation.
   *)
  Parameter leftmost_Node : forall {A}, tree A -> option A.
  (* 10 points *)

  Axiom leftmost_Node_example :
    leftmost_Node (Node (Node Leaf 2 (Node Leaf 3 Leaf)) 1 Leaf)
    = Some 2.
  (* 10 points *)

  (* Prove that the leftmost node of the tree is the same
   * as the head of the list produced by flattening the tree
   * with an in-order traversal.
   *)
  Axiom leftmost_Node_head : forall {A} (t : tree A),
      leftmost_Node t = head (flatten t).
  (* 20 points *)

  (* Now let's work with the binary tries we defined earlier!
   *
   * Define [lookup] such that [lookup k t] looks up the
   * map entry corresponding to the key [k : list bool] in the
   * binary trie [t : binary_trie A], interpreting [t] such that
   * the value at the root of [t] corresponds to the
   * entry for the key [nil], the left subtree contains entries
   * for those keys that begin with [true], and the right subtree
   * contains entries for those keys that begin with [false].
   *)
  Parameter lookup : forall {A}, list bool -> binary_trie A -> option A.
  (* 10 points *)

  Axiom lookup_example1 : lookup [] (Node Leaf (None : option nat) Leaf) = None.
  (* 10 points *)

  Axiom lookup_example2 : lookup [false; true]
    (Node (Node Leaf (Some 2) Leaf) None (Node (Node Leaf (Some 1) Leaf) (Some 3) Leaf))
                          = Some 1.
  (* 10 points *)

  (* [Leaf] represents an empty binary trie, so a lookup for
   * any key should return [None].
   *)
  Axiom lookup_empty : forall {A} (k : list bool),
      lookup k (Leaf : binary_trie A) = None.
  (* 10 points *)

  (* Define an operation to "insert" a key and optional value
   * into a binary trie. The [insert] definition should satisfy two
   * properties: one is [lookup_insert] below, which says that if we
   * look up a key [k] in a trie where [(k, v)] has just been inserted,
   * the result should be [v]. The other is that lookups on keys different
   * from the one just inserted should be the same as on the original map.
   *
   * If an entry for that key already exists, [insert] should replace
   * that entry with the new one being inserted. Note that [insert] can
   * be used to remove an entry from the trie, too, by inserting [None]
   * as the value.
   *
   * Hint: it may be helpful to define an auxiliary function that inserts
   * a key and optional value into the empty trie.
   *)
  Parameter insert : forall {A}, list bool -> option A -> binary_trie A -> binary_trie A.
  (* 20 points *)

  Axiom insert_example1 : lookup [] (insert [] None (Node Leaf (Some 0) Leaf)) = None.
  Axiom insert_example2 : lookup [] (insert [true] (Some 2) (Node Leaf (Some 0) Leaf)) = Some 0.
  (* 10 points *)

  Axiom lookup_insert : forall {A} (k : list bool) (v : option A) (t : binary_trie A),
      lookup k (insert k v t) = v.
  (* 40 points *)
End S.

(* The template file Pset4b.v also suggests an additional challenge problem,
 * which won't be graded, but which provides extra practice with container data
 * structures.  The key operation is *left-biased merge for trees*. *)


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

This file contains various useful tactics

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

Require Import UniMath.Foundations.All.

(** A version of "easy" specialized for the needs of UniMath.
This tactic is supposed to be simple and predictable. The goal
is to use it to finish "trivial" goals *)
Ltac easy :=
  trivial; intros; solve
   [ repeat (solve [trivial | apply pathsinv0; trivial] || split)
   | match goal with | H : ∅ |- _ => induction H end
   | match goal with | H : ¬ _ |- _ => induction H; trivial end
   | match goal with | H : _ → ∅ |- _ => induction H; trivial end
   | match goal with | H : _ → _ → ∅ |- _ => induction H; trivial end ].

(** Override the Coq now tactic so that it uses unimath_easy instead *)
Tactic Notation "now" tactic(t) := t; easy.

(* hSet_induction in Foundations is wrong, so redefine it here: *)
Ltac hSet_induction f e := generalize f; apply hSet_rect; intro e; clear f.

(* When the goal is displayed as x=y and the types of x and y are hard to discern,
   use this tactic -- it will add the type to the context in simplified form. *)
Ltac show_id_type := match goal with |- @paths ?ID _ _ => set (TYPE := ID); simpl in TYPE end.

Require Import UniMath.Foundations.Sets UniMath.Foundations.UnivalenceAxiom.

Definition post_cat {X} {x y z:X} {p:y = z} : x = y -> x = z.
Proof. intros q. exact (pathscomp0 q p). Defined.

Definition pre_cat {X} {x y z:X} {p:x = y} : y = z -> x = z.
Proof. intros q. exact (pathscomp0 p q). Defined.

Ltac maponpaths_pre_post_cat :=
  repeat rewrite path_assoc; repeat apply (maponpaths post_cat); repeat rewrite <- path_assoc;
  repeat apply (maponpaths pre_cat); repeat rewrite path_assoc; repeat rewrite maponpathsinv0;
  try reflexivity.

Ltac prop_logic :=
  abstract (intros; simpl;
            repeat (try (apply isapropdirprod);try (apply isapropishinh);apply impred ;intro);
            try (apply isapropiscontr); try assumption) using _L_.

Lemma iscontrweqb' {X Y} (is:iscontr Y) (w:X ≃ Y) : iscontr X.
Proof. intros. apply (iscontrweqb (Y:=Y)). assumption. assumption. Defined.

Ltac intermediate_iscontr  Y' := apply (iscontrweqb (Y := Y')).
Ltac intermediate_iscontr' Y' := apply (iscontrweqb' (Y := Y')).

Ltac isaprop_goal x :=
  let G := match goal with |- ?G => constr:(G) end in
  assert (x : isaprop(G)).

(* less fancy than [isaprop_goal ig.] is [apply isaprop_goal; intro ig.] *)
Definition isaprop_goal X (ig:isaprop X) (f:isaprop X -> X) : X.
Proof. intros. exact (f ig). Defined.

Ltac isaset_goal x :=
  let G := match goal with |- ?G => constr:(G) end in
  assert (x : isaset(G)).

Ltac split3 := split; [| split].
Ltac split4 := split; [| split3].
Ltac split5 := split; [| split4].
Ltac split6 := split; [| split5].
Ltac split7 := split; [| split6].
Ltac split8 := split; [| split7].
Ltac split9 := split; [| split8].
Ltac split10 := split; [| split9].
Ltac split11 := split; [| split10].
Ltac split12 := split; [| split11].
Ltac split13 := split; [| split12].
Ltac split14 := split; [| split13].
Ltac split15 := split; [| split14].
Ltac split16 := split; [| split15].
Ltac split17 := split; [| split16].
Ltac split18 := split; [| split17].
Ltac split19 := split; [| split18].
Ltac split20 := split; [| split19].
Ltac split21 := split; [| split20].
(** this allows to decompose a goal for [prebicat_laws] *)


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

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Group_kernel.
(** Title "Factorisation of a group homomorphism: G -> G/Kerf -> coKerf -> G'." *)
Section Def.
Variable G G' : GROUP.
Variable f : Hom G G'.

Definition surj_group_quo_ker :
  Hom G (group_quo G (Ker f) (kernel_normal (G:=G) (G':=G') (f:=f))) :=
  group_quo_surj (kernel_normal (f:=f)).

Lemma surj_group_quo_ker_surjective : surjective surj_group_quo_ker.
red in |- *.
simpl in |- *.
unfold group_quo_eq, subtype_image_equal in |- *.
intros y; exists y; try assumption.
simpl in |- *.
apply Trans with (Ap (sgroup_map (monoid_sgroup_hom f)) (monoid_unit G));
 auto with algebra.
Qed.

Definition inj_coKer_group : Hom (coKer f:GROUP) G'.
apply (BUILD_HOM_GROUP (G:=coKer f) (G':=G') (ff:=inj_part (coKer f))).
simpl in |- *.
auto with algebra.
simpl in |- *.
auto with algebra.
simpl in |- *.
auto with algebra.
Defined.

Lemma inj_coKer_group_injective : injective inj_coKer_group.
exact (inj_part_injective (E:=G') (A:=coKer f)).
Qed.

Definition bij_group_quo_ker_coKer :
  Hom (group_quo G (Ker f) (kernel_normal (G:=G) (G':=G') (f:=f)):GROUP)
    (coKer f).
apply
 (BUILD_HOM_GROUP
    (G:=group_quo G (Ker f) (kernel_normal (G:=G) (G':=G') (f:=f)))
    (G':=coKer f)
    (ff:=fun x : G =>
         Build_subtype (P:=image (sgroup_map (monoid_sgroup_hom f)) (full G))
           (subtype_elt:=f x) (coKer_prop f x))).
simpl in |- *.
unfold group_quo_eq, subtype_image_equal in |- *.
simpl in |- *.
intros x y H'; try assumption.
apply
 GROUP_reg_right
  with (group_inverse _ (Ap (sgroup_map (monoid_sgroup_hom f)) y));
 auto with algebra.
apply
 Trans
  with
    (sgroup_law G' (Ap (sgroup_map (monoid_sgroup_hom f)) x)
       (Ap (sgroup_map (monoid_sgroup_hom f)) (group_inverse G y)));
 auto with algebra.
apply
 Trans
  with
    (Ap (sgroup_map (monoid_sgroup_hom f))
       (sgroup_law G x (group_inverse G y))); auto with algebra.
apply Trans with (monoid_unit G'); auto with algebra.
simpl in |- *.
unfold group_quo_eq, subtype_image_equal in |- *.
simpl in |- *.
intros x y; try assumption.
exact (SGROUP_hom_prop f x y).
simpl in |- *.
unfold group_quo_eq, subtype_image_equal in |- *.
simpl in |- *.
auto with algebra.
Defined.

Lemma bij_group_quo_ker_coKer_bijective : bijective bij_group_quo_ker_coKer.
red in |- *.
split; [ try assumption | idtac ].
red in |- *.
simpl in |- *.
unfold group_quo_eq, subtype_image_equal in |- *.
simpl in |- *.
intros x y H'; try assumption.
apply
 Trans
  with
    (sgroup_law G' (Ap (sgroup_map (monoid_sgroup_hom f)) x)
       (Ap (sgroup_map (monoid_sgroup_hom f)) (group_inverse G y)));
 auto with algebra.
apply
 Trans
  with
    (sgroup_law G' (Ap (sgroup_map (monoid_sgroup_hom f)) x)
       (group_inverse _ (Ap (sgroup_map (monoid_sgroup_hom f)) y)));
 auto with algebra.
apply
 Trans
  with
    (sgroup_law G' (Ap (sgroup_map (monoid_sgroup_hom f)) x)
       (group_inverse _ (Ap (sgroup_map (monoid_sgroup_hom f)) x)));
 auto with algebra.
red in |- *.
intros y; try assumption.
elim y.
intros y' subtype_prf; try assumption.
elim subtype_prf.
intros x H'; try assumption.
elim H'; intros H'0 H'1; try exact H'0; clear H'.
exists x; try assumption.
Qed.

Theorem factor_group_hom :
 Equal f
   (comp_hom inj_coKer_group
      (comp_hom bij_group_quo_ker_coKer surj_group_quo_ker)).
simpl in |- *.
unfold Map_eq in |- *.
simpl in |- *.
auto with algebra.
Qed.
End Def.
Hint Resolve factor_group_hom bij_group_quo_ker_coKer_bijective
  inj_coKer_group_injective surj_group_quo_ker_surjective: algebra.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

  DdlCoq 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.

  DdlCoq 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 DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export symbol_lemmas.
Require Export tactics_util.

(** definition of state *)
Definition state := KAssignable -> R.

(** Dummy state *)
Definition DumState : state := fun v => DumR.

(** some properties about states *)

(** change KAssignable (variable or differential of variable)  a with r in state s *)
Definition upd_state (s : state) (a : KAssignable) (r : R) : state :=
  fun x =>
    if KAssignable_dec x a
    then r
    else s x.

(** after variable a in state s is update with value r, it's value in state s is r *)
Lemma upd_state_same :
  forall s a r, upd_state s a r a = r.
Proof.
  intros s a r.
  unfold upd_state.
  destruct (KAssignable_dec a a) as [n|n]; auto.
  destruct n; auto.
Qed.
Hint Rewrite upd_state_same.

(** special case of upd_state is defined for variables *)
Definition upd_state_var S v r :=
  upd_state S (KAssignVar v) r.

(** special case of upd_state_same is defined for variables *)
Lemma upd_state_var_same :
  forall s v r, upd_state_var s v r (KAssignVar v) = r.
Proof.
  intros s v r.
  unfold upd_state_var; autorewrite with core; auto.
Qed.
Hint Rewrite upd_state_var_same.

(** if we consider two different KAssignables a and b in one state,
and we update value of a, then value of b remains the same as before update *)
Lemma upd_state_diff :
  forall s a r b, a <> b -> upd_state s a r b = s b.
Proof.
  intros s a r b d.
  unfold upd_state.
  destruct (KAssignable_dec b a) as [n|n]; subst; auto.
  destruct d; auto.
Qed.

(** special case of upd_state_diff is defined for variables *)
Lemma upd_state_var_diff :
  forall s v r a, KAssignVar v <> a -> upd_state_var s v r a = s a.
Proof.
  intros s v r ac d.
  apply upd_state_diff; auto.
Qed.

Definition var_sub := list (KVariable * R).

(** update list of variables sub in state s *)
Fixpoint upd_list_state (s : state) (sub : var_sub) : state :=
  match sub with
  | [] => s
  | (v,r) :: sub => upd_state (upd_list_state s sub) (KAssignVar v) r
  end.

(** builds a var_sub from a state [s] w.r.t. a support [l] *)
Fixpoint state2var_sub (s : state) (l : list KVariable) : var_sub :=
  match l with
  | [] => []
  | v :: vs => (v, s (KAssignVar v)) :: state2var_sub s vs
  end.

(** updates [s1] with the values of [s2] at [l] *)
Definition upd_state_st (s1 : state) (s2 : state) (l : list KVariable) : state :=
  upd_list_state s1 (state2var_sub s2 l).

Lemma upd_state_st_nil :
  forall s1 s2, upd_state_st s1 s2 [] = s1.
Proof.
  tcsp.
Qed.
Hint Rewrite upd_state_st_nil : core.

(** states s1 and s2 are equal except that for variable x, s2 maps to r *)
Definition differ_state_except (s1 s2 : state) x (r : R) : Prop :=
  (forall y, x <> y -> s1 y = s2 y)
  /\
  s2 x = r.

Lemma differ_state_except_prop1 :
  forall v w x r y,
    differ_state_except v w x r
    -> y <> x
    -> v y = w y.
Proof.
  introv d1 d2.
  destruct d1 as [h1 h2].
  apply h1; auto.
Qed.

Lemma differ_state_except_prop2 :
  forall v w x r,
    differ_state_except v w x r
    -> w x = r.
Proof.
  introv d.
  destruct d as [h1 h2]; auto.
Qed.

(* this definition is used in definition of dynamic semantics of programs *)
(** states s1 and s2 are equal except for variables in vars *)
Definition equal_states_except (s1 s2 : state) (vs : list KAssignable) : Prop :=
  forall x,
    not (List.In x vs)
    -> s1 x = s2 x.

Lemma differ_state_except_implies_equal_states_except :
  forall v w x r,
    differ_state_except v w x r
    -> equal_states_except v w [x].
Proof.
  introv h i; simpl in *.
  destruct h as [h1 h2].
  apply h1; tcsp.
Qed.


(* -*- coding: utf-8 *)

(** * Group actions *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.Propositions.
Require Import UniMath.MoreFoundations.Notations.
Require Import UniMath.MoreFoundations.Univalence.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Combinatorics.OrderedSets.

Import UniMath.MoreFoundations.PartA.

(** ** Definitions *)

Definition action_op G (X:hSet) : Type := ∏ (g:G) (x:X), X.

Section A.
  Context (G:gr) (X:hSet).
  Definition ActionStructure : Type :=
    ∑ (act_mult  :    action_op G X)
      (act_unit  :    ∏ x, act_mult (unel G) x = x),
   (*  act_assoc : *) ∏ g h x, act_mult (op g h) x = act_mult g (act_mult h x).
  Definition make act_mult act_unit act_assoc : ActionStructure := act_mult,, act_unit,, act_assoc.
  Definition act_mult (x:ActionStructure) := pr1 x.
  Definition act_unit (x:ActionStructure) := pr12 x.
  Definition act_assoc (x:ActionStructure) := pr22 x.
End A.
Arguments act_mult {_ _} _ _ _.

Lemma isaset_ActionStructure (G:gr) (X:hSet) : isaset (ActionStructure G X).
Proof.
  intros.
  apply isaset_total2.
  { apply (impred 2); intro g. apply impred; intro x. apply setproperty. }
  intro op.
  apply isaset_total2.
  { apply (impred 2); intro x. apply hlevelntosn. apply setproperty. }
  intro un. apply (impred 2); intro g. apply (impred 2); intro h. apply (impred 2); intro x.
  apply hlevelntosn. apply setproperty.
Qed.

Definition Action (G:gr) := total2 (ActionStructure G).
Definition makeAction {G:gr} (X:hSet) (ac:ActionStructure G X) :=
  X,,ac : Action G.

Definition ac_set {G:gr} (X:Action G) := pr1 X.
Coercion ac_set : Action >-> hSet.
Definition ac_type {G:gr} (X:Action G) := pr1hSet (ac_set X).
Definition ac_str {G:gr} (X:Action G) := pr2 X : ActionStructure G (ac_set X).
Definition ac_mult {G:gr} (X:Action G) := act_mult (pr2 X).
Declare Scope action_scope.
Delimit Scope action_scope with action.
Local Notation "g * x" := (ac_mult _ g x) : action_scope.
Local Open Scope action_scope.
Definition ac_assoc {G:gr} (X:Action G) := act_assoc _ _ (pr2 X) : ∏ g h x, (op g h)*x = g*(h*x).

Definition right_mult {G:gr} {X:Action G} (x:X) := λ g, g*x.
Definition left_mult {G:gr} {X:Action G} (g:G) := λ x:X, g*x.

Definition is_equivariant {G:gr} {X Y:Action G} (f:X->Y) : hProp :=
  (∀ g x, f (g*x) = g*(f x))%logic.

Definition is_equivariant_isaprop {G:gr} {X Y:Action G} (f:X->Y) :
  isaprop (is_equivariant f).
Proof.
  apply propproperty.
Qed.

(** The following fact is fundamental: it shows that our definition of
    [is_equivariant] captures all of the structure.  The proof reduces to
    showing that if G acts on a set X in two ways, and the identity function is
    equivariant, then the two actions are equal.  A similar fact will hold in
    other cases: groups, rings, monoids, etc.  Refer to section 9.8 of the HoTT
    book, on the "structure identity principle", a term coined by Peter Aczel. *)
Local Open Scope transport.

Definition is_equivariant_identity {G:gr} {X Y:Action G}
           (p:ac_set X = ac_set Y) :
  p # ac_str X = ac_str Y ≃ is_equivariant (cast (maponpaths pr1hSet p)).
Proof.
  revert X Y p; intros [X [Xm [Xu Xa]]] [Y [Ym [Yu Ya]]] ? .
  (* should just apply hPropUnivalence at this point, as in Poset_univalence_prelim! *)
  simpl in p. destruct p; simpl. unfold transportf; simpl.
  simple refine (make_weq _ _).
  { intros p g x. simpl in x. simpl.
    exact (eqtohomot (eqtohomot (maponpaths act_mult p) g) x). }
  use isweq_iso.
  { unfold cast; simpl.
    intro i.
    assert (p:Xm=Ym).
    { apply funextsec; intro g. apply funextsec; intro x; simpl in x.
      exact (i g x). }
    destruct p. clear i. assert (p:Xu=Yu).
    { apply funextsec; intro x; simpl in x. apply setproperty. }
    destruct p. assert (p:Xa=Ya).
    { apply funextsec; intro g. apply funextsec; intro h.
      apply funextsec; intro x. apply setproperty. }
    destruct p. apply idpath. }
  { intro p. apply isaset_ActionStructure. }
  { intro is. apply proofirrelevance.
    apply impred; intros g.
    apply impred; intros x.
    apply setproperty. }
Defined.

Definition is_equivariant_comp {G:gr} {X Y Z:Action G}
           (p:X->Y) (i:is_equivariant p)
           (q:Y->Z) (j:is_equivariant q) : is_equivariant (funcomp p q).
Proof.
  intros. intros g x. exact (maponpaths q (i g x) @ j g (p x)).
Defined.

Definition ActionMap {G:gr} (X Y:Action G) := total2 (@is_equivariant _ X Y).

Definition underlyingFunction {G:gr} {X Y:Action G} (f:ActionMap X Y) := pr1 f.

Coercion underlyingFunction : ActionMap >-> Funclass.

Definition equivariance {G:gr} {X Y:Action G} (f:ActionMap X Y) : is_equivariant f
  := pr2 f.

Definition composeActionMap {G:gr} (X Y Z:Action G)
           (p:ActionMap X Y) (q:ActionMap Y Z) : ActionMap X Z.
Proof.
  revert p q; intros [p i] [q j]. exists (funcomp p q).
  apply is_equivariant_comp. assumption. assumption.
Defined.

Definition ActionIso {G:gr} (X Y:Action G) : Type.
Proof.
  exact  (∑ f:(ac_set X) ≃ (ac_set Y), is_equivariant f).
Defined.

Lemma ActionIso_isaset {G:gr} (X Y:Action G) : isaset (ActionIso X Y).
Proof.
  apply (isofhlevelsninclb _ pr1).
  { apply isinclpr1; intro f. apply propproperty. }
  apply isofhlevelsnweqtohlevelsn.
  apply setproperty.
Defined.

Coercion underlyingIso {G:gr} {X Y:Action G} (e:ActionIso X Y) : X ≃ Y := pr1 e.

Lemma underlyingIso_incl {G:gr} {X Y:Action G} :
  isincl (underlyingIso : ActionIso X Y -> X ≃ Y).
Proof.
  intros. apply isinclpr1; intro f. apply propproperty.
Defined.

Local Goal ∏ G (X Y:Action G) (i : ActionIso X Y) (x:X), Y.
  intros.
  exact (i x).
Qed.

Lemma underlyingIso_injectivity {G:gr} {X Y:Action G}
      (e f:ActionIso X Y) :
  (e = f) ≃ (underlyingIso e = underlyingIso f).
Proof.
  intros. apply weqonpathsincl. apply underlyingIso_incl.
Defined.

Definition underlyingActionMap {G:gr} {X Y:Action G} (e:ActionIso X Y) : ActionMap X Y :=
  pr1weq (pr1 e),, pr2 e.

Definition idActionIso {G:gr} (X:Action G) : ActionIso X X.
Proof.
  intros. exists (idweq _). intros g x. reflexivity.
Defined.

Definition composeActionIso {G:gr} {X Y Z:Action G}
           (e:ActionIso X Y) (f:ActionIso Y Z) : ActionIso X Z.
Proof.
  revert e f; intros [e i] [f j]. exists (weqcomp e f).
  destruct e as [e e'], f as [f f']; simpl.
  apply is_equivariant_comp. exact i. exact j.
Defined.

Lemma composeActionIsoId {G:gr} {X Y:Action G} (f : ActionIso X Y) : composeActionIso (idActionIso X) f = f.
Proof.
  apply subtypePath.
  { intros g. apply propproperty. }
  apply subtypePath.
  { intros g. apply isapropisweq. }
  reflexivity.
Defined.

Lemma composeActionIsoId' {G:gr} {X Y:Action G} (f : ActionIso X Y) : composeActionIso f (idActionIso Y) = f.
Proof.
  apply subtypePath.
  { intros g. apply propproperty. }
  apply subtypePath.
  { intros g. apply isapropisweq. }
  reflexivity.
Defined.

Definition path_to_ActionIso {G:gr} {X Y:Action G} (e:X = Y) : ActionIso X Y.
Proof.
  intros. destruct e. exact (idActionIso X).
Defined.

Definition castAction {G:gr} {X Y:Action G} (e:X = Y) : X -> Y.
Proof.
  intros x. exact (path_to_ActionIso e x).
Defined.

(** ** Applications of univalence *)

Definition Action_univalence_prelim {G:gr} {X Y:Action G} :
  (X = Y) ≃ (ActionIso X Y).
Proof.
  intros.
  simple refine (weqcomp (total2_paths_equiv (ActionStructure G) X Y) _).
  simple refine (weqbandf _ _ _ _).
  { apply hSet_univalence. }
  simpl. intro p. simple refine (weqcomp (is_equivariant_identity p) _).
  exact (eqweqmap (maponpaths (λ f, hProptoType (is_equivariant f)) (pr1_eqweqmap (maponpaths pr1hSet p)))).
Defined.

Definition Action_univalence_prelim_comp {G:gr} {X Y:Action G} (p:X = Y) :
   Action_univalence_prelim p = path_to_ActionIso p.
Proof.
  intros. destruct p. apply (maponpaths (tpair _ _)). apply funextsec; intro g.
  apply funextsec; intro x. apply setproperty.
Defined.

Lemma path_to_ActionIsweq_iso {G:gr} {X Y:Action G}  :
   isweq (@path_to_ActionIso G X Y).
Proof.
  intros. exact (isweqhomot Action_univalence_prelim
                            path_to_ActionIso
                            Action_univalence_prelim_comp
                            (pr2 Action_univalence_prelim)).
Qed.

Definition Action_univalence {G:gr} {X Y:Action G} :
  (X = Y) ≃ (ActionIso X Y).
Proof.
  intros. exists path_to_ActionIso. apply path_to_ActionIsweq_iso.
Defined.

Definition Action_univalence_comp {G:gr} {X Y:Action G} (p:X = Y) :
   Action_univalence p = path_to_ActionIso p.
Proof.
  reflexivity.
Defined.

Definition Action_univalence_inv {G:gr} {X Y:Action G}
  : (ActionIso X Y) ≃ (X=Y) := invweq Action_univalence.

Definition Action_univalence_inv_comp {G:gr} {X Y:Action G} (f:ActionIso X Y) :
  path_to_ActionIso (Action_univalence_inv f) = f.
Proof.
  intros.
  unfold Action_univalence_inv, Action_univalence.
  apply (homotweqinvweq Action_univalence f).
Defined.

Definition Action_univalence_inv_comp_eval {G:gr} {X Y:Action G} (f:ActionIso X Y) (x:X) :
  castAction (Action_univalence_inv f) x = f x.
Proof.
  intros. exact (eqtohomot
                   (maponpaths pr1weq
                               (maponpaths underlyingIso
                                           (Action_univalence_inv_comp f)))
                   x).
Defined.

(** ** Torsors *)

Definition is_torsor {G:gr} (X:Action G) :=
  nonempty X × ∏ x:X, isweq (right_mult x).

Lemma is_torsor_isaprop {G:gr} (X:Action G) : isaprop (is_torsor X).
Proof.
  intros. apply isapropdirprod.
  { apply propproperty. }
  { apply impred; intro x. apply isapropisweq. }
Qed.

Definition Torsor (G:gr) := total2 (@is_torsor G).

Coercion underlyingAction {G} (X:Torsor G) := pr1 X : Action G.

Definition is_torsor_prop {G} (X:Torsor G) := pr2 X.

Definition torsor_nonempty {G} (X:Torsor G) := pr1 (is_torsor_prop X).

Definition torsor_splitting {G} (X:Torsor G) := pr2 (is_torsor_prop X).

Definition torsor_mult_weq {G} (X:Torsor G) (x:X) :=
  make_weq (right_mult x) (torsor_splitting X x) : G ≃ X.

Definition torsor_mult_weq' {G} (X:Torsor G) (g:G) : X ≃ X.
Proof.
  exists (left_mult g).
  use isweq_iso.
    - exact (left_mult (grinv G g)).
    - intros x. unfold left_mult.
      intermediate_path ((grinv G g * g)%multmonoid * x).
      + apply pathsinv0,act_assoc.
      + intermediate_path (unel G * x).
        * apply (maponpaths (right_mult x)). apply grlinvax.
        * apply act_unit.
    - intros x. unfold left_mult.
      intermediate_path ((g * grinv G g)%multmonoid * x).
      + apply pathsinv0,act_assoc.
      + intermediate_path (unel G * x).
        * apply (maponpaths (right_mult x)). apply grrinvax.
        * apply act_unit.
Defined.

Definition left_mult_Iso {G:abgr} (X:Torsor G) (g:G) : ActionIso X X.
Proof.
  exists (torsor_mult_weq' X g). intros h x.
  change (g * (h * x) = h * (g * x)).
  refine (! ac_assoc X g h x @ _ @ ac_assoc X h g x).
  exact (maponpaths (right_mult x) (commax G g h)).
Defined.

Definition torsor_update_nonempty {G} (X:Torsor G) (x:nonempty X) : Torsor G.
Proof.
  exact (underlyingAction X,,(x,,pr2(is_torsor_prop X))).
Defined.

Definition castTorsor {G} {T T':Torsor G} (q:T = T') : T -> T'.
Proof.
  exact (castAction (maponpaths underlyingAction q)).
Defined.

Lemma castTorsor_transportf {G} {T T':Torsor G} (q:T = T') (t:T) :
  transportf (λ S, underlyingAction S) q t = castTorsor q t.
Proof.
  now induction q.
Defined.

Lemma underlyingAction_incl {G:gr} :
  isincl (underlyingAction : Torsor G -> Action G).
Proof.
  intros. refine (isinclpr1 _ _); intro X. apply is_torsor_isaprop.
Defined.

Lemma underlyingAction_injectivity {G:gr} {X Y:Torsor G} :
      (X = Y) ≃ (underlyingAction X = underlyingAction Y).
Proof.
  intros. apply weqonpathsincl. apply underlyingAction_incl.
Defined.

Definition underlyingAction_injectivity_comp {G:gr} {X Y:Torsor G} (p:X = Y) :
  underlyingAction_injectivity p = maponpaths underlyingAction p.
Proof.
  reflexivity.
Defined.

Definition underlyingAction_injectivity_comp' {G:gr} {X Y:Torsor G} :
     pr1weq (@underlyingAction_injectivity G X Y)
  = @maponpaths (Torsor G) (Action G) (@underlyingAction G) X Y.
Proof.
  reflexivity.
Defined.

Definition underlyingAction_injectivity_inv_comp {G:gr} {X Y:Torsor G}
           (f:underlyingAction X = underlyingAction Y) :
  maponpaths underlyingAction (invmap underlyingAction_injectivity f) = f.
Proof.
  intros. apply (homotweqinvweq underlyingAction_injectivity f).
Defined.

Definition PointedTorsor (G:gr) := ∑ X:Torsor G, X.
Definition underlyingTorsor {G} (X:PointedTorsor G) := pr1 X : Torsor G.
Coercion underlyingTorsor : PointedTorsor >-> Torsor.
Definition underlyingPoint {G} (X:PointedTorsor G) := pr2 X : X.

Lemma is_quotient {G} (X:Torsor G) (y x:X) : ∃! g, g*x = y.
Proof.
  intros. exact (pr2 (is_torsor_prop X) x y).
Defined.

Definition quotient {G} (X:Torsor G) (y x:X) := pr1 (iscontrpr1 (is_quotient X y x)) : G.
Local Notation "y / x" := (quotient _ y x) : action_scope.

Lemma quotient_times {G} {X:Torsor G} (y x:X) : (y/x)*x = y.
Proof.
  intros. exact (pr2 (iscontrpr1 (is_quotient _ y x))).
Defined.

Lemma quotient_uniqueness {G} {X:Torsor G} (y x:X) (g:G) : g*x = y -> g = y/x.
Proof.
  intros e.
  exact (maponpaths pr1 (uniqueness (is_quotient _ y x) (g,,e))).
Defined.

Lemma quotient_mult {G} (X:Torsor G) (g:G) (x:X) : (g*x)/x = g.
Proof.
  intros. apply pathsinv0. apply quotient_uniqueness. reflexivity.
Defined.

Lemma quotient_1 {G} (X:Torsor G) (x:X) : x/x = 1%multmonoid.
Proof.
  intros. apply pathsinv0. apply quotient_uniqueness. apply act_unit.
Defined.

Lemma quotient_product {G} (X:Torsor G) (z y x:X) : op (z/y) (y/x) = z/x.
Proof.
  intros. apply quotient_uniqueness.
  exact (ac_assoc _ _ _ _
                  @ maponpaths (left_mult (z/y)) (quotient_times y x)
                  @ quotient_times z y).
Defined.

Lemma quotient_map {G} {X Y:Torsor G} (f : ActionMap X Y) (x x':X) : f x' / f x = x' / x.
Proof.
  refine (! (quotient_uniqueness (f x') (f x) (x' / x) _)).
  assert (p := equivariance f (x'/x) x).
  refine (!p @ _); clear p.
  apply maponpaths.
  apply quotient_times.
Qed.

Lemma torsorMapIsIso {G} {X Y : Torsor G} (f : ActionMap X Y) : isweq f.
Proof.
  apply (squash_to_prop (torsor_nonempty X)).
  - apply isapropisweq.
  - intros x.
    set (y := f x).
    set (f' := λ y', y' / y * x).
    apply (isweq_iso f f').
    + intros x'.
      unfold f', y.
      assert (p := quotient_times x' x).
      refine (_ @ p); clear p.
      apply (maponpaths (λ g, g * x)).
      apply quotient_map.
    + intros y'.
      unfold f'.
      assert (p := equivariance f (y'/y) x).
      refine (p @ _); clear p.
      fold y.
      apply quotient_times.
Defined.

Definition torsorMap_to_torsorIso {G} {X Y : Torsor G} (f : ActionMap X Y) : ActionIso X Y.
Proof.
  use tpair.
  - exists f. apply torsorMapIsIso.
  - simpl. apply equivariance.
Defined.

Definition trivialTorsor (G:gr) : Torsor G.
Proof.
  intros. exists (makeAction G (make G G op (lunax G) (assocax G))).
  exact (hinhpr (unel G),,
         λ x, isweq_iso
           (λ g, op g x)
           (λ g, op g (grinv _ x))
           (λ g, assocax _ g x (grinv _ x) @ maponpaths (op g) (grrinvax G x) @ runax _ g)
           (λ g, assocax _ g (grinv _ x) x @ maponpaths (op g) (grlinvax G x) @ runax _ g)).
Defined.

Definition toTrivialTorsor {G:gr} (g:G) : trivialTorsor G.
Proof.
  exact g.
Defined.

Definition pointedTrivialTorsor (G:gr) : PointedTorsor G.
Proof.
  intros. exists (trivialTorsor G). exact (unel G).
Defined.

Definition univ_function {G:gr} (X:Torsor G) (x:X) : trivialTorsor G -> X.
Proof.
  apply right_mult. assumption.
Defined.

Definition univ_function_pointed {G:gr} (X:Torsor G) (x:X) :
  univ_function X x (unel _) = x.
Proof.
  intros. apply act_unit.
Defined.

Definition univ_function_is_equivariant {G:gr} (X:Torsor G) (x:X) :
  is_equivariant (univ_function X x).
Proof.
  intros. intros g h. apply act_assoc.
Defined.

Definition triviality_isomorphism {G:gr} (X:Torsor G) (x:X) :
  ActionIso (trivialTorsor G) X.
Proof.
  intros.
  exact (torsor_mult_weq X x,, univ_function_is_equivariant X x).
Defined.

Lemma triviality_isomorphism_compute (G:gr) :
  triviality_isomorphism (trivialTorsor G) (unel G) = idActionIso (trivialTorsor G).
Proof.
  apply subtypePath_prop.
  apply subtypePath.
  { intros X. apply isapropisweq. }
  apply funextsec; intros g.
  change (op g (unel _) = g).
  apply runax.
Defined.

Definition trivialTorsor_weq (G:gr) (g:G) : (trivialTorsor G) ≃ (trivialTorsor G).
Proof.
  intros. exists (λ h, op h g). apply (isweq_iso _ (λ h, op h (grinv G g))).
  { exact (λ h, assocax _ _ _ _ @ maponpaths (op _) (grrinvax _ _) @ runax _ _). }
  { exact (λ h, assocax _ _ _ _ @ maponpaths (op _) (grlinvax _ _) @ runax _ _). }
Defined.

Definition trivialTorsorAuto (G:gr) (g:G) :
  ActionIso (trivialTorsor G) (trivialTorsor G).
Proof.
  intros. exists (trivialTorsor_weq G g).
  intros h x. simpl.  exact (assocax _ h x g).
Defined.

Lemma pr1weq_injectivity {X Y} (f g:X ≃ Y) : (f = g) ≃ (pr1weq f = pr1weq g).
Proof.
  intros. apply weqonpathsincl. apply isinclpr1weq.
Defined.

Definition trivialTorsorRightMultiplication (G:gr) : G ≃ ActionIso (trivialTorsor G) (trivialTorsor G).
Proof.
  exists (trivialTorsorAuto G). simple refine (isweq_iso _ _ _ _).
  { intro f. exact (f (unel G)). }
  { intro g; simpl. exact (lunax _ g). }
  { intro f; simpl. apply (invweq (underlyingIso_injectivity _ _)); simpl.
    apply (invweq (pr1weq_injectivity _ _)). apply funextsec; intro g.
    simpl. exact ((! (pr2 f) g (unel G)) @ (maponpaths (pr1 f) (runax G g))). }
Defined.

Definition autos_comp (G:gr) (g:G) :
  underlyingIso (trivialTorsorRightMultiplication G g) = trivialTorsor_weq G g.
Proof.
  reflexivity.             (* don't change the proof *)
Defined.

Definition autos_comp_apply (G:gr) (g h:G) :
  (trivialTorsorRightMultiplication _ g) h = (h * g)%multmonoid.
Proof.
  reflexivity.             (* don't change the proof *)
Defined.

Lemma trivialTorsorAuto_unit (G:gr) :
  trivialTorsorAuto G (unel _) = idActionIso _.
Proof.
  intros. simple refine (subtypePath _ _).
  { intro k. apply is_equivariant_isaprop. }
  { simple refine (subtypePath _ _).
    { intro; apply isapropisweq. }
    { apply funextsec; intro x; simpl. exact (runax G x). } }
Defined.

Lemma trivialTorsorAuto_mult (G:gr) (g h:G) :
  composeActionIso (trivialTorsorAuto G g) (trivialTorsorAuto G h)
  = (trivialTorsorAuto G (op g h)).
Proof.
  intros. simple refine (subtypePath _ _).
  { intro; apply is_equivariant_isaprop. }
  { simple refine (subtypePath _ _).
    { intro; apply isapropisweq. }
    { apply funextsec; intro x; simpl. exact (assocax _ x g h). } }
Defined.

(** ** Applications of univalence *)

Definition torsor_univalence {G:gr} {X Y:Torsor G} : (X = Y) ≃ (ActionIso X Y).
Proof.
  intros. simple refine (weqcomp underlyingAction_injectivity _).
  apply Action_univalence.
Defined.

Definition torsor_univalence_transport {G:gr} {X Y:Torsor G} (p:X=Y) (x:X) :
  torsor_univalence p x = transportf (λ X:Torsor G, X:Type) p x.
(* compare with castTorsor_transportf above *)
Proof.
  now induction p.
Defined.

Corollary torsor_hlevel {G:gr} : isofhlevel 3 (Torsor G).
Proof.
  intros X Y.
  apply (isofhlevelweqb 2 torsor_univalence).
  apply ActionIso_isaset.
Defined.

Definition torsor_univalence_comp {G:gr} {X Y:Torsor G} (p:X = Y) :
   torsor_univalence p = path_to_ActionIso (maponpaths underlyingAction p).
Proof.
  reflexivity.
Defined.

Definition torsor_univalence_inv_comp_eval {G:gr} {X Y:Torsor G}
           (f:ActionIso X Y) (x:X) :
  castTorsor (invmap torsor_univalence f) x = f x.
Proof.
  intros. unfold torsor_univalence.
  unfold castTorsor. rewrite invmapweqcomp. (* too slow *)
  unfold weqcomp; simpl.
  rewrite underlyingAction_injectivity_inv_comp.
  apply Action_univalence_inv_comp_eval.
Defined.

Definition torsor_eqweq_to_path {G:gr} {X Y:Torsor G} : ActionIso X Y -> X = Y.
Proof.
  intros f. exact (invweq torsor_univalence f).
Defined.

Definition torsorMap_to_path {G:gr} {X Y:Torsor G} : ActionMap X Y -> X = Y.
Proof.
  intros f.
  apply (invweq torsor_univalence).
  apply torsorMap_to_torsorIso.
  exact f.
Defined.

Theorem TorsorIso_rect {G:gr} {X Y : Torsor G} (P : ActionIso X Y -> UU) :
  (∏ e : X = Y, P (torsor_univalence e)) -> ∏ f, P f.
Proof.
  intros ih ?.
  set (p := ih (invmap torsor_univalence f)).
  set (h := homotweqinvweq torsor_univalence f).
  exact (transportf P h p).
Defined.

Ltac torsor_induction f e :=
  generalize f; apply TorsorIso_rect; intro e; clear f.

Theorem TorsorIso_rect' {G:gr} {X : Torsor G} (P : ∏ Y : Torsor G, ActionIso X Y -> Type) :
  P X (idActionIso X) -> ∏ (Y : Torsor G) (f:ActionIso X Y), P Y f.
Proof.
  intros p ? ?. torsor_induction f q. induction q. exact p.
Defined.

Ltac torsor_induction' f X :=
  generalize f; generalize X; apply TorsorIso_rect'; clear f X.

Lemma torsor_univalence_id {G:gr} (X:Torsor G) : invmap torsor_univalence (idActionIso X) = idpath X.
(* upstream *)
Proof.
  change (idActionIso X) with (torsor_univalence (idpath X)).
  apply homotinvweqweq.
Defined.

Definition invUnivalenceCompose {G:gr} {X Y Z : Torsor G} (f : ActionIso X Y) (g : ActionIso Y Z) :
  invmap torsor_univalence f @ invmap torsor_univalence g = invmap torsor_univalence (composeActionIso f g).
Proof.
  torsor_induction' g Z. rewrite composeActionIsoId'. rewrite torsor_univalence_id. apply pathscomp0rid.
Defined.

Definition PointedActionIso {G:gr} (X Y:PointedTorsor G)
    := ∑ f:ActionIso X Y, f (underlyingPoint X) = underlyingPoint Y.

Definition pointed_triviality_isomorphism {G:gr} (X:PointedTorsor G) :
  PointedActionIso (pointedTrivialTorsor G) X.
Proof.
  revert X; intros [X x]. exists (triviality_isomorphism X x).
  simpl. apply univ_function_pointed.
Defined.

Definition Pointedtorsor_univalence {G:gr} {X Y:PointedTorsor G} :
  (X = Y) ≃ (PointedActionIso X Y).
Proof.
  intros.
  simple refine (weqcomp (total2_paths_equiv _ X Y) _).
  simple refine (weqbandf _ _ _ _).
  { intros.
    exact (weqcomp (weqonpathsincl underlyingAction underlyingAction_incl X Y)
                   Action_univalence). }
  destruct X as [X x], Y as [Y y]; simpl. intro p. destruct p; simpl.
  exact (idweq _).
Defined.

Definition ClassifyingSpace G := pointedType (Torsor G) (trivialTorsor G).
Definition E := PointedTorsor.
Definition B := ClassifyingSpace.
Definition π {G:gr} := underlyingTorsor : E G -> B G.

Lemma isBaseConnected_BG (G:gr) : isBaseConnected (B G).
Proof.
  intros X. use (hinhfun _ (torsor_nonempty X)); intros x.
  exact (torsor_eqweq_to_path (triviality_isomorphism X x)).
Defined.

Goal ∏ (G:gr), triviality_isomorphism (trivialTorsor G) (unel G) = idActionIso (trivialTorsor G).
  Fail reflexivity.
Abort.

Goal ∏ (G:gr), isBaseConnected_BG G (trivialTorsor G) = hinhpr (idpath (trivialTorsor G)).
  intros.
  unfold isBaseConnected_BG, pr2.
  change (pr1 (trivialTorsor G) : Type) with (G : Type).
  change (torsor_nonempty (trivialTorsor G)) with (hinhpr (unel G)).
  change (hinhpr (torsor_eqweq_to_path (triviality_isomorphism (trivialTorsor G) (unel G)))
          = hinhpr (idpath (trivialTorsor G))).
  apply maponpaths.
  Fail reflexivity.
Abort.

Lemma isConnected_BG (G:gr) : isConnected (B G).
Proof.
  apply baseConnectedness. apply isBaseConnected_BG.
Defined.

Lemma iscontr_EG (G:gr) : iscontr (E G).
Proof.
  intros. exists (pointedTrivialTorsor G). intros [X x].
  apply pathsinv0. apply (invweq Pointedtorsor_univalence).
  apply pointed_triviality_isomorphism.
Defined.

Theorem loopsBG (G:gr) : G ≃ Ω (B G).
Proof.
  intros.
  simple refine (weqcomp _ (invweq torsor_univalence)).
  apply trivialTorsorRightMultiplication.
Defined.

Definition loopsBG_comp (G:gr) (g:G) :
  loopsBG G g = invmap torsor_univalence (trivialTorsorAuto G g).
Proof.
  reflexivity.
Defined.

Definition loopsBG_comp' {G:gr} (p : Ω (B G)) :
  invmap (loopsBG G) p = path_to_ActionIso (maponpaths underlyingAction p) (unel G).
Proof.
  reflexivity.
Defined.

Definition loopsBG_comp_2 (G:gr) (g h:G)
  : castTorsor (loopsBG G g) h = (h*g)%multmonoid.
Proof.
  exact (torsor_univalence_inv_comp_eval (trivialTorsorAuto G g) h).
Defined.

(** Theorem [loopsBG] also follows from the Rezk Completion theorem of the CategoryTheory
    package.  To see that, regard G as a category with one object.  Consider a
    merely representable functor F : G^op -> Set.  Let X be F of the object *.
    Apply F to the arrows to get an action of G on X.  Try to prove that X is a
    torsor.  Since being a torsor is a mere property, we may assume F is
    actually representable.  There is only one object *, so F is isomorphic to
    h_*.  Apply h_* to * and we get Hom(*,*), which is G, regarded as a G-set.
    That's a torsor.  So the Rezk completion RCG is equivalent to BG, the type
    of G-torsors.  Now the theorem also says there is an equivalence G -> RCG.
    So RCG is connected and its loop space is G.

    A formalization of that argument should be added eventually. *)

(*
Local Variables:
compile-command: "make -C ../.. UniMath/CategoryTheory/RepresentableFunctors/GroupAction.vo"
End:
*)


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import Basics.Overture Basics.Tactics.
Require Import WildCat.Core.
Require Import WildCat.Equiv.
Require Import WildCat.NatTrans.
Require Import WildCat.FunctorCat.

(** ** Opposite categories *)

Definition op (A : Type) := A.
Notation "A ^op" := (op A).

(** This stops typeclass search from trying to unfold op. *)
#[global] Typeclasses Opaque op.

Global Instance isgraph_op {A : Type} `{IsGraph A}
  : IsGraph A^op.
Proof.
  apply Build_IsGraph.
  unfold op; exact (fun a b => b $-> a).
Defined.

Global Instance is01cat_op {A : Type} `{Is01Cat A} : Is01Cat A^op.
Proof.
  apply Build_Is01Cat.
  + cbv; exact Id.
  + cbv; exact (fun a b c g f => f $o g).
Defined.

(** We don't invert 2-cells as this is op on the first level. *)
Global Instance is2graph_op {A : Type} `{Is2Graph A} : Is2Graph A^op.
Proof.
  intros a b; unfold op in *; cbn; exact _.
Defined.

Global Instance is1cat_op {A : Type} `{Is1Cat A} : Is1Cat A^op.
Proof.
  srapply Build_Is1Cat; unfold op in *; cbv in *.
  - intros a b.
    apply is01cat_hom.
  - intros a b.
    apply is0gpd_hom.
  - intros a b c h.
    srapply Build_Is0Functor.
    intros f g p.
    cbn in *.
    exact (p $@R h).
  - intros a b c h.
    srapply Build_Is0Functor.
    intros f g p.
    cbn in *.
    exact (h $@L p).
  - intros a b c d f g h; exact (cat_assoc_opp h g f).
  - intros a b f; exact (cat_idr f).
  - intros a b f; exact (cat_idl f).
Defined.

Global Instance is1cat_strong_op A `{Is1Cat_Strong A}
  : Is1Cat_Strong (A ^op).
Proof.
  srapply Build_Is1Cat_Strong; unfold op in *; cbn in *.
  - intros a b c d f g h; exact (cat_assoc_opp_strong h g f).
  - intros a b f.
    apply cat_idr_strong.
  - intros a b f.
    apply cat_idl_strong.
Defined.

(* Opposites are (almost) definitionally involutive. You can test this by uncommenting the stuff below. *)

(*
Definition test1 A `{Is01Cat A} : A = (A^op)^op := 1.
Definition test2 A `{x : Is01Cat A} : x = is01cat_op (A^op) := 1.
Definition test3 A `{x : Is2Graph A} : x = is2graph_op (A^op) := 1.
(** Doesn't work *)
Definition test4 A `{x : Is1Cat A} : x = is1cat_op (A^op) := 1.
*)

(** Opposite groupoids *)

Global Instance is0gpd_op A `{Is0Gpd A} : Is0Gpd (A^op).
Proof.
  srapply Build_Is0Gpd; unfold op in *; cbn in *.
  intros a b.
  apply gpd_rev.
Defined.

Global Instance op0gpd_fun A `{Is0Gpd A} :
  Is0Functor( (fun x => x) : A^op -> A).
Proof.
  srapply Build_Is0Functor; unfold op in *; cbn.
  intros a b.
  exact (fun f => f^$).
Defined.

(** ** Opposite functors *)

Global Instance is0functor_op A B (F : A -> B)
  `{IsGraph A, IsGraph B, x : !Is0Functor F}
  : Is0Functor (F : A^op -> B^op).
Proof.
  apply Build_Is0Functor.
  intros a b.
  cbn; apply fmap.
  assumption.
Defined.

Global Instance is1functor_op A B (F : A -> B)
  `{Is1Cat A, Is1Cat B, !Is0Functor F, !Is1Functor F}
  : Is1Functor (F : A^op -> B^op).
Proof.
  apply Build_Is1Functor; unfold op in *; cbn in *.
  - intros a b; rapply fmap2; assumption.
  - intros a; exact (fmap_id F a).
  - intros a b c f g; exact (fmap_comp F g f).
Defined.

(** Bundled opposite functors *)
Definition fun01_op (A B : Type) `{IsGraph A} `{IsGraph B}
  : Fun01 A B -> Fun01 A^op B^op.
Proof.
  intros F.
  rapply (Build_Fun01 A^op B^op F).
Defined.

(** Opposite natural transformations *)

Definition transformation_op {A} {B} `{Is01Cat B}
           (F : A -> B) (G : A -> B) (alpha : F $=> G)
  : @Transformation A^op (fun _ => B^op) _
                     (G : A^op -> B^op) (F : A^op -> B^op).
Proof.
  unfold op in *.
  cbn in *.
  intro a.
  apply (alpha a).
Defined.

Global Instance is1nat_op A B `{Is01Cat A} `{Is1Cat B}
       (F : A -> B) `{!Is0Functor F}
       (G : A -> B) `{!Is0Functor G}
       (alpha : F $=> G) `{!Is1Natural F G alpha}
  : Is1Natural (G : A^op -> B^op) (F : A^op -> B^op) (transformation_op F G alpha).
Proof.
  unfold op in *.
  unfold transformation_op.
  cbn.
  intros a b f.
  srapply isnat_tr.
Defined.

(** Opposite categories preserve having equivalences. *)
Global Instance hasequivs_op {A} `{HasEquivs A} : HasEquivs A^op.
Proof.
  srapply Build_HasEquivs; intros a b; unfold op in *; cbn.
  - exact (b $<~> a).
  - apply CatIsEquiv.
  - apply cate_fun'.
  - apply cate_isequiv'.
  - apply cate_buildequiv'.
  - rapply cate_buildequiv_fun'.
  - apply cate_inv'.
  - rapply cate_isretr'.
  - rapply cate_issect'.
  - intros f g s t.
    exact (catie_adjointify f g t s).
Defined.

Global Instance isequivs_op {A : Type} `{HasEquivs A}
       {a b : A} (f : a $-> b) {ief : CatIsEquiv f}
  : @CatIsEquiv A^op _ _ _ _ _ b a f.
Proof.
  assumption.
Defined.

Global Instance hasmorext_op {A : Type} `{H0 : HasMorExt A}
  : HasMorExt A^op.
Proof.
  snrapply Build_HasMorExt.
  intros a b f g.
  refine (@isequiv_Htpy_path _ _ _ _ _ H0 b a f g).
Defined.

Lemma natequiv_op {A B : Type} `{Is01Cat A} `{HasEquivs B}
  (F G : A -> B) `{!Is0Functor F, !Is0Functor G}
  : NatEquiv F G -> NatEquiv (G : A^op -> B^op) F.
Proof.
  intros [a n].
  snrapply Build_NatEquiv.
  { intro x.
    exact (a x). }
  rapply is1nat_op.
Defined.


From CoqAlgs Require Import Base.

Module Type StackSpec.

Parameter Stack : Type -> Type.

(** Basic stack-building operations. *)

Parameter empty :
  forall {A : Type}, Stack A.

Parameter push :
  forall {A : Type}, A -> Stack A -> Stack A.

Parameter top :
  forall {A : Type}, Stack A -> option A.

Parameter pop :
  forall {A : Type}, Stack A -> option (Stack A).

Definition unpush {A : Type} (s : Stack A) : option (A * Stack A) :=
match top s, pop s with
    | None, _ => None
    | _, None => None
    | Some x, Some s' => Some (x, s')
end.

(** Secondary operations. *)
Parameter isEmpty :
  forall {A : Type}, Stack A -> bool.

Parameter size :
  forall {A : Type}, Stack A -> nat.

Parameter fmap :
  forall {A B : Type}, (A -> B) -> Stack A -> Stack B.

(** Properties of the basic operations. *)

Parameter top_empty :
  forall {A : Type}, top (@empty A) = None.

Parameter top_push :
  forall {A : Type} (x : A) (s : Stack A),
    top (push x s) = Some x.

Parameter pop_empty :
  forall {A : Type}, pop (@empty A) = None.

Parameter pop_push :
  forall {A : Type} (x : A) (s : Stack A),
    pop (push x s) = Some s.

(** Properties of [isEmpty]. *)

Parameter isEmpty_empty :
  forall {A : Type}, isEmpty (@empty A) = true.

Parameter isEmpty_push :
  forall {A : Type} (x : A) (s : Stack A),
    isEmpty (push x s) = false.

Parameter isEmpty_top :
  forall {A : Type} (s : Stack A),
    isEmpty s = true -> top s = None.

Parameter isEmpty_pop :
  forall {A : Type} (s : Stack A),
    isEmpty s = true -> pop s = None.

(** Properties of [size]. *)

Parameter size_empty :
  forall {A : Type}, size (@empty A) = 0.

Parameter size_push :
  forall {A : Type} (x : A) (s : Stack A),
    size (push x s) = 1 + size s.

End StackSpec.


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

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) languages square, prime and anbncn are not context-free;
   (ii) context-free languages are not closed under intersection.

   More information can be found in the paper "Some Applications of the
   Formalization of the Pumping Lemma for Context-Free Languages",
   submitted to LSFA 2018 by Marcus Vinícius Midena Ramos, Ruy J. G. B.
   de Queiroz, Nelma Moreira and José Carlos Bacelar Almeida.
   Also, in the thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md describes the contents of each file and
   provides instructions on how to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* CONTEXT FREE LANGUAGES                                                *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import emptyrules.

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

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* CONTEXT-FREE LANGUAGES - DEFINITIONS                                  *)
(* --------------------------------------------------------------------- *)

Section ContextFreeLanguages_Definitions.

Variables non_terminal terminal: Type.

Notation sentence:= (list terminal).

Definition lang := sentence -> Prop.

Definition lang_of_g (g: cfg non_terminal terminal): lang :=
fun w: sentence => produces g w.

Definition lang_eq (l k: lang) :=
forall w, l w <-> k w.

Definition empty_lang (l: lang): Prop:=
~ exists w: sentence,
l w.

Definition non_empty_lang (l: lang): Prop:=
exists w: sentence,
l w.

Definition contains_empty (l: lang): Prop:=
l [].

Definition contains_non_empty (l: lang): Prop:=
exists w: sentence,
l w /\ w <> [].

End ContextFreeLanguages_Definitions.

Infix "==" := lang_eq (at level 80).

Definition cfl (terminal: Type) (l: lang terminal): Prop:=
exists non_terminal: Type,
exists g: cfg non_terminal terminal,
l == lang_of_g g.

(* --------------------------------------------------------------------- *)
(* CONTEXT-FREE LANGUAGES - LEMMAS                                       *)
(* --------------------------------------------------------------------- *)

Section ContextFreeLanguages_Lemma.

Variables non_terminal non_terminal' terminal: Type.

Lemma produces_empty_equiv_contains_empty:
forall g: cfg non_terminal terminal,
produces_empty g <-> contains_empty (lang_of_g g).
Proof.
intros g.
unfold produces_empty.
unfold contains_empty.
unfold lang_of_g.
split; auto.
Qed.

Lemma produces_non_empty_equiv_contains_non_empty:
forall g: cfg non_terminal terminal,
produces_non_empty g <-> contains_non_empty (lang_of_g g).
Proof.
intros g.
unfold produces_non_empty.
unfold contains_non_empty.
unfold lang_of_g.
split; auto.
Qed.

Lemma g_equiv_lang_eq:
forall g: cfg non_terminal terminal,
forall g': cfg non_terminal' terminal,
g_equiv g' g -> lang_of_g g' == lang_of_g g.
Proof.
unfold g_equiv.
unfold lang_of_g.
unfold lang_eq.
intros g g' H1.
split.
- intros H2.
  apply H1.
  exact H2.
- intros H2.
  apply H1.
  exact H2.
Qed.

Lemma lang_eq_sym:
forall l1 l2: lang terminal,
l1 == l2 ->
l2 == l1.
Proof.
unfold lang_eq.
intros l1 l2 H1 w.
split.
- intros H2.
  apply H1.
  exact H2.
- intros H2.
  apply H1.
  exact H2.
Qed.

Lemma lang_eq_trans:
forall l1 l2 l3: lang terminal,
l1 == l2 ->
l2 == l3 ->
l1 == l3.
Proof.
unfold lang_eq.
intros l1 l2 l3 H1 H3 w.
split.
- intros H4.
  apply H3.
  apply H1.
  exact H4.
- intros H4.
  apply H1.
  apply H3.
  exact H4.
Qed.

Lemma lang_eq_change_g:
forall l: lang terminal,
forall g: cfg non_terminal terminal,
forall g': cfg non_terminal' terminal,
l == lang_of_g g ->
g_equiv g' g ->
l == lang_of_g g'.
Proof.
intros l g g' H1 H2.
apply g_equiv_lang_eq in H2.
apply lang_eq_trans with (l2 := lang_of_g g).
- exact H1.
- apply lang_eq_sym.
  exact H2.
Qed.

Lemma cfl_lang_eq:
forall (l1 l2: lang terminal),
cfl l1 -> l1==l2 -> cfl l2.
Proof.
intros l1 l2 H1 H2.
unfold cfl in H1.
destruct H1 as [nt1 [g1 H1]].
exists nt1, g1.
apply lang_eq_trans with (l2:=l1).
- apply lang_eq_sym.
  exact H2.
- exact H1.
Qed.

End ContextFreeLanguages_Lemma.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import Logic. Import Decidable.
Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Key_Properties.

Require Import Coq.Strings.String.

Lemma TypedReduce_unique: forall (v v1 v2 : exp) (A: typ),
    value v -> (exists B, Etyping nil v B) -> TypedReduce v A v1 -> TypedReduce v A v2 -> v1 = v2.
Proof.
  intros v v1 v2 A Val H R1 R2.
  gen v2.
  lets R1': R1.
  induction R1; introv R2;
    try solve [inverts* R2];
    try solve [forwards*: TypedReduce_toplike R1' R2].
  - (* mergel *)
    lets [B H']: H.
    lets R2': R2.
    inverts Val.
    inverts* R2;
      try solve [forwards*: TypedReduce_toplike R1 R2'];
      try solve [inverts* H'].
    +
      inverts* H'.
      forwards* Con: disjoint_val_consistent H13 H8 H11.
    +
      inverts* H1.
  - (* merger *)
    lets [B H']: H.
    lets R2': R2.
    inverts Val.
    inverts* R2;
      try solve [forwards*: TypedReduce_toplike R1 R2'];
      try solve [inverts* H'].
    +
      inverts* H'.
      forwards* Con: disjoint_val_consistent H13 H8 H11.
      forwards*: Con H7 R1.
      forwards*: H15 H7 R1.
    +
      inverts* H1.
  - (* and *)
    inverts* R2;
      try solve [inversion H2]. (* inversion ord (t_and _ _) *)
    forwards*: IHR1_1.
    forwards*: IHR1_2.
    congruence.
Qed.

Theorem step_unique: forall A (e e1 e2 : exp),
    Etyping nil e A -> step e e1 -> step e e2 -> e1 = e2.
Proof.
  introv Typ Red1.
  gen A e2.
  lets Red1' : Red1.
  induction Red1;
    introv Typ Red2.
  - Case "beta3".
    inverts* Red2.
    + SCase "beta3".
      inverts* Typ.
      inverts* H10. (* Typing condition for the following assert *)
      assert (v' = v'0) by forwards*: TypedReduce_unique H1 H9.
      congruence.
    + SCase "app1".
      inverts* H6.
    + SCase "app2".
      forwards*: step_not_value H6.
  - Case "annov".
    inverts* Red2.
    + SCase "annov".
      forwards*: TypedReduce_unique H0 H5.
      inverts* Typ.
    + SCase "anno".
      forwards*: step_not_value H4.
  - Case "appl".
    inverts* Red2.
    + SCase "absv".
      forwards*: step_not_value Red1.
    + SCase "appl".
      inverts* Typ.
      forwards*: IHRed1.
      congruence.
    + SCase "appr".
      forwards*: step_not_value Red1.
  - Case "appr".
    inverts* Red2;
      try solve [forwards*: step_not_value Red1].
    + SCase "appl".
      forwards*: step_not_value H4.
    + SCase "appr".
      inverts* Typ.
      forwards*: IHRed1.
      congruence.
  - Case "mergel".
    inverts* Red2;
      try solve [forwards*: step_not_value Red1].
    + SCase "mergel".
      inverts* Typ;
        forwards*: IHRed1;
        congruence.
  - Case "merger".
    inverts* Red2;
      try solve [forwards*: step_not_value Red1].
    + SCase "mergel".
      forwards*: step_not_value H4.
    + SCase "merger".
      inverts* Typ;
        forwards*: IHRed1;
        congruence.
  - Case "anno".
    inverts* Red2;
      inverts* Typ;
      try solve [inverts* Red1];
      try solve [lets*: step_not_value Red1].
    forwards*: IHRed1.
    congruence.
  - Case "fix".
    inverts* Red2.
Qed.


Require Import Recdef Bool.

Require Import List.
Import ListNotations.

Inductive Even : nat -> Prop :=
| Even0 : Even 0
| EvenSS : forall n : nat, Even n -> Even (S (S n)).

Function isEven (n : nat) : bool :=
match n with
| 0 => true
| 1 => false
| S (S n') => isEven n'
end.

Lemma isEven_spec :
  forall n : nat, reflect (Even n) (isEven n).
Proof.
  intro.
  functional induction (isEven n); try constructor.
    constructor.
    inversion 1.
    destruct IHb; constructor.
      constructor. assumption.
      inversion 1; subst. contradiction.
Qed.

Module Unbundled.

Class Dec (P : Prop) : Type :=
{
  b : bool;
  spec : reflect P b;
}.

Coercion cast (P : Prop) {d : Dec P} : bool := b.

Print Graph.

#[refine]
#[export]
Instance Dec_Even (n : nat) : Dec (Even n) :=
{
  b := isEven n
}.
Proof.
  apply isEven_spec.
Defined.

(* Doesn't work. *)
Fail Definition silly (n : nat) : bool :=
  if Even n then true else false.

End Unbundled.

Module Bundled.

Class Dec : Type :=
{
  P : Prop;
  b : bool;
  spec : reflect P b;
}.

Coercion cast (d : Dec) : bool := b.

#[refine]
#[export]
Instance Dec_Even (n : nat) : Dec :=
{
  P := Even n;
  b := isEven n;
}.
Proof.
  apply isEven_spec.
Defined.

(* Still no luck. *)
Fail Definition silly (n : nat) : bool :=
  if Even n then true else false.

End Bundled.

Module Canonical.

Module Dec.

Record class (P : Prop) := Class
{
  b :> bool;
  spec : reflect P b;
}.

Structure type := Pack
{
  P : Prop;
  class_of :> class P;
}.

Definition dec (t : type) : bool :=
  let 'Pack _ (Class _ b _) := t in b.

Arguments dec {t} : simpl never.
Arguments Class {P} _.

Module theory.
(* Notation "x == y" := (42) (at level 70). *)
End theory.

End Dec.

Import Dec.theory.

Definition Even_class (n : nat) : Dec.class (Even n).
Proof.
  split with (isEven n).
  apply isEven_spec.
Defined.

Canonical Structure Dec_Even (n : nat) : Dec.type :=
  Dec.Pack (Even n) (Even_class n).

(* Still no success. *)
Fail Definition silly (n : nat) : bool :=
  if Even n then true else false.

End Canonical.

From Typonomikon Require Import M.

Module ThisMustWork.

Class Dec (P : Prop) : Type :=
{
  dec : bool;
  dec_spec : reflect P dec;
}.

Arguments dec      _ {Dec}.
Arguments dec_spec _ {Dec}.

#[refine]
#[export]
Instance Dec_isEven (n : nat) : Dec (Even n) :=
{
  dec := isEven n;
}.
Proof.
  apply isEven_spec.
Defined.

Definition not_so_silly (n : nat) : bool :=
  if dec (Even n) then true else false.

Compute not_so_silly 6.

#[refine]
#[export]
Instance Dec_False : Dec False :=
{
  dec := false
}.
Proof.
  constructor.
  destruct 1.
Defined.

#[refine]
#[export]
Instance Dec_True : Dec True :=
{
  dec := true
}.
Proof.
  constructor.
  trivial.
Defined.

#[refine]
#[export]
Instance Dec_or {P Q : Prop} (DP : Dec P) (DQ : Dec Q) : Dec (P \/ Q) :=
{
  dec := dec P || dec Q
}.
Proof.
  destruct (dec_spec P), (dec_spec Q); cbn; constructor.
    1-3: auto.
    intros [p | q]; contradiction.
Defined.

#[refine]
#[export]
Instance Dec_and {P Q : Prop} (DP : Dec P) (DQ : Dec Q) : Dec (P /\ Q) :=
{
  dec := dec P && dec Q
}.
Proof.
  destruct (dec_spec P), (dec_spec Q); cbn; constructor.
    split; assumption.
    all: intros [p' q']; contradiction.
Defined.

#[refine]
#[export]
Instance Dec_impl {P Q : Prop} (DP : Dec P) (DQ : Dec Q) : Dec (P -> Q) :=
{
  dec := negb (dec P) || dec Q
}.
Proof.
  destruct (dec_spec P), (dec_spec Q);
  cbn; constructor; intros.
    assumption.
    intro. apply n, H. assumption.
    assumption.
    contradiction.
Defined.

#[refine]
#[export]
Instance Dec_not
  {P : Prop} (DP : Dec P) : Dec (~ P) :=
{
  dec := negb (dec P)
}.
Proof.
  destruct (dec_spec P); constructor.
    intro. contradiction.
    assumption.
Defined.

#[refine]
#[export]
Instance Dec_exists
  {A : Type} {P : A -> Prop}
  (SA : Searchable A) (DP : forall x : A, Dec (P x))
  : Dec (exists x : A, P x) :=
{
  dec := dec (P (search (fun x : A => dec (P x))))
}.
Proof.
  destruct (@dec_spec _ (DP (search (fun x : A => dec (P x)))));
  constructor.
    exists (search (fun x : A => dec (P x))). assumption.
    intros [x p]. destruct (dec (P (search (fun x : A => dec (P x))))) eqn: Heq.
      destruct (@dec_spec _ (DP (search (fun x : A => dec (P x))))).
        contradiction.
        congruence.
      pose (search_spec (fun x : A => dec (P x)) Heq x). clearbody e. cbn in e.
        destruct (dec_spec (P x)).
          congruence.
          contradiction.
Defined.

#[refine]
#[export]
Instance Dec_forall
  {A : Type} {P : A -> Prop}
  (SA : Searchable A) (DP : forall x : A, Dec (P x))
  : Dec (forall x : A, P x) :=
{
  dec := negb (dec (~ P (search (fun x : A => dec (~ P x)))))
}.
Proof.
  destruct (dec_spec (~ P (search (fun x : A => dec (~ P x)))));
  constructor.
    intro. apply n, H.
    cut (forall x : A, dec (~ P x) = false).
      intros. cbn in H. specialize (H x). destruct (dec_spec (P x)).
        assumption.
        cbn in H. congruence.
      apply (search_spec (fun x : A => dec (~ P x))).
        destruct (dec_spec (~ P (search (fun x : A => dec (~ P x))))).
          contradiction.
          reflexivity.
Defined.

End ThisMustWork.

Module WeakEquality.

Class WeakEquality (A : Type) : Type :=
{
  weq : A -> A -> Prop;
  weq_spec :
    forall x y : A, x = y -> weq x y;
}.

Notation "x ~=~ y" := (weq x y) (at level 50).

#[refine]
#[export]
Instance WeakEquality_Unit : WeakEquality unit :=
{
  weq := fun _ _ => True;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance WeakEquality_Empty : WeakEquality False :=
{
  weq := fun _ _ => True;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance WeakEquality_Fun
  {A B : Type} : WeakEquality (A -> B) :=
{
  weq := fun f g => forall x : A, f x = g x;
}.
Proof.
  intros f g [] x. reflexivity.
Defined.

#[refine]
#[export]
Instance WeakEquality_Fun'
  {A B : Type} (WEB : WeakEquality B): WeakEquality (A -> B) :=
{
  weq := fun f g => forall x : A, weq (f x) (g x);
}.
Proof.
  intros f g [] x. apply weq_spec. reflexivity.
Defined.

#[refine]
#[export]
Instance WeakEquality_Sum
  {A B : Type} (WEA : WeakEquality A) (WEB : WeakEquality B) : WeakEquality (A + B) :=
{
  weq := fun x y =>
    match x, y with
    | inl a1, inl a2 => weq a1 a2
    | inr b1, inr b2 => weq b1 b2
    | _     , _      => False
    end
}.
Proof.
  destruct x, y; intro H; inversion H; subst; clear H.
    apply weq_spec. reflexivity.
    apply weq_spec. reflexivity.
Defined.

#[refine]
#[export]
Instance WeakEquality_Prod
  {A B : Type} (WEA : WeakEquality A) (WEB : WeakEquality B) : WeakEquality (A * B) :=
{
  weq := fun x y =>
    match x, y with
    | (a1, b1), (a2, b2) => weq a1 a2 /\ weq b1 b2
    end
}.
Proof.
  destruct x, y.
  intro H.
  inversion H; subst; clear H.
  split.
    apply weq_spec. reflexivity.
    apply weq_spec. reflexivity.
Defined.

#[refine]
#[export]
Instance WeakEquality_List
  {A B : Type} (WEA : WeakEquality A) : WeakEquality (list A) :=
{
  weq := fix f (x y : list A) : Prop :=
    match x, y with
    | [], [] => True
    | h1 :: t1, h2 :: t2 => weq h1 h2 /\ f t1 t2
    | _, _ => False
    end
}.
Proof.
  induction x as [| h1 t1]; destruct y as [| h2 t2]; cbn; intro H.
    trivial.
    1-2: inversion H.
    inversion H; subst. split.
      apply weq_spec. reflexivity.
      apply IHt1. reflexivity.
Defined.

Set Warnings "-require-in-module".
From Typonomikon Require Import F2.
Set Warnings "require-in-module".

#[refine]
#[export]
Instance WeakEquality_Stream
  {A B : Type} (WEA : WeakEquality A) : WeakEquality (Stream A) :=
{
  weq := sim;
}.
Proof.
  destruct 1. apply sim_refl.
Defined.

End WeakEquality.

Module StrongInequality.

Class StrongDisequality (A : Type) : Type :=
{
  sdeq : A -> A -> Prop;
  sdeq_spec :
    forall x y : A, sdeq x y -> x <> y;
}.

Notation "x =/= y" := (sdeq x y) (at level 50).

#[refine]
#[export]
Instance StrongDisequality_Unit : StrongDisequality unit :=
{
  sdeq := fun _ _ => False;
}.
Proof.
  destruct 1.
Defined.

#[refine]
#[export]
Instance StrongDisequality_Empty : StrongDisequality False :=
{
  sdeq := fun _ _ => True;
}.
Proof.
  destruct x.
Defined.

#[refine]
#[export]
Instance StrongDisequality_Sum
  {A B : Type} (SDA : StrongDisequality A) (SDB : StrongDisequality B) : StrongDisequality (A + B) :=
{
  sdeq := fun x y =>
    match x, y with
    | inl a1, inl a2 => sdeq a1 a2
    | inr b1, inr b2 => sdeq b1 b2
    | inl _ , inr _  => True
    | inr _ , inl _  => True
    end
}.
Proof.
  destruct x, y; intros H1 H2;
  inversion H2; subst.
    apply sdeq_spec in H1. contradiction.
    apply sdeq_spec in H1. contradiction.
Defined.

#[refine]
#[export]
Instance StrongDisequality_Prod
  {A B : Type} (SDA : StrongDisequality A) (SDB : StrongDisequality B) : StrongDisequality (A * B) :=
{
  sdeq := fun x y =>
    match x, y with
    | (a1, b1), (a2, b2) => sdeq a1 a2 \/ sdeq b1 b2
    end
}.
Proof.
  destruct x, y; intros H1 H2;
  inversion H2; subst.
  destruct H1.
    apply sdeq_spec in H. contradiction.
    apply sdeq_spec in H. contradiction.
Defined.

#[refine]
#[export]
Instance StrongDisequality_Fun
  {A B : Type} : StrongDisequality (A -> B) :=
{
  sdeq := fun f g => exists x : A, f x <> g x;
}.
Proof.
  intros f g [x H] p. subst. contradiction.
Defined.

#[refine]
#[export]
Instance StrongDisequality_Fun'
  {A B : Type} (SDB : StrongDisequality B) : StrongDisequality (A -> B) :=
{
  sdeq := fun f g => exists x : A, sdeq (f x) (g x);
}.
Proof.
  intros f g [x H] p. subst. apply sdeq_spec in H. contradiction.
Defined.

#[refine]
#[export]
Instance StrongDisequality_List
  {A B : Type} (SDA : StrongDisequality A) : StrongDisequality (list A) :=
{
  sdeq := fix f (x y : list A) : Prop :=
    match x, y with
    | [], [] => False
    | h1 :: t1, h2 :: t2 => sdeq h1 h2 \/ f t1 t2
    | _, _ => True
    end
}.
Proof.
  induction x as [| h1 t1];
  destruct y as [| h2 t2];
  cbn; intro H;
  inversion 1; subst.
    contradiction.
    destruct H.
      apply sdeq_spec in H. contradiction.
      apply (IHt1 t2). apply H. reflexivity.
Defined.

Set Warnings "-require-in-module".
From Typonomikon Require Import F2.
Set Warnings "require-in-module".

Inductive Ex {A : Type} (R : A -> A -> Prop) : Stream A -> Stream A -> Prop :=
| Ex_hd :
    forall s1 s2 : Stream A, R (hd s1) (hd s2) -> Ex R s1 s2
| Ex_tl :
    forall s1 s2 : Stream A, Ex R (tl s1) (tl s2) -> Ex R s1 s2.

#[refine]
#[export]
Instance StrongDisequality_Stream
  {A B : Type} (SDA : StrongDisequality A) : StrongDisequality (Stream A) :=
{
  sdeq := Ex sdeq;
}.
Proof.
  induction 1; inversion 1; subst.
    apply sdeq_spec in H. contradiction.
    contradiction.
Defined.

End StrongInequality.

Class Pointed (A : Type) : Type :=
{
  point : A;
}.

Set Warnings "-cannot-define-projection".

Class Inhabited (A : Type) : Prop :=
{
  inhabitant : A;
}.

#[export]
Instance Inhabited_Pointed
  (A : Type) (inst : Pointed A)
  : Inhabited A :=
{
  inhabitant := point;
}.

#[export]
Instance Pointed_nat : Pointed nat :=
{
  point := 0
}.

Module StrongNegation.

Class StrongNegation (A : Type) : Type :=
{
  NOT : Type;
  NOT_spec : NOT -> A -> False;
}.

Arguments NOT A {StrongNegation}.

#[refine]
#[export]
Instance StrongNegation_Default
  (A : Type) : StrongNegation A | 999 :=
{
  NOT := A -> False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Pointed
  (A : Type) (inst : Pointed A)
  : StrongNegation A :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Inhabited
  (A : Type) (inst : Inhabited A)
  : StrongNegation A :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_True :
  StrongNegation True :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_False :
  StrongNegation False :=
{
  NOT := True;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_or
  (P Q : Prop) (PSN : StrongNegation P) (QSN : StrongNegation Q)
  : StrongNegation (P \/ Q) :=
{
  NOT := NOT P * NOT Q;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_and
  (P Q : Prop) (PSN : StrongNegation P) (QSN : StrongNegation Q)
  : StrongNegation (P /\ Q) :=
{
  NOT := NOT P + NOT Q;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_impl
  (P Q : Prop) (QSN : StrongNegation Q)
  : StrongNegation (P -> Q) :=
{
  NOT := P * NOT Q;
}.
Proof.
  destruct 1. intro pq. apply QSN.
    assumption.
    apply pq. assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_forall
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation (forall x : A, P x) :=
{
  NOT := {x : A & NOT (P x)};
}.
Proof.
  intros [x np] H.
  apply (PSN x).
    assumption.
    apply H.
Defined.

#[refine]
#[export]
Instance StrongNegation_exists
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation (exists x : A, P x) :=
{
  NOT := forall x : A, NOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_subset
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation {x : A | P x} :=
{
  NOT := forall x : A, NOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_sigma
  (A : Type) (P : A -> Type)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation {x : A & P x} :=
{
  NOT := forall x : A, NOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

Compute NOT (forall n : nat, True).
Compute NOT (NOT (forall n : nat, True)).
Compute NOT nat.

End StrongNegation.

Module StrongNegation_Prop.

Class StrongNegation (A : Prop) : Type :=
{
  NOT : Prop;
  NOT_spec : NOT -> A -> False;
}.

Arguments NOT A {StrongNegation}.

#[refine]
#[export]
Instance StrongNegation_Default
  (A : Prop) : StrongNegation A | 999 :=
{
  NOT := A -> False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Pointed
  (A : Prop) (inst : Pointed A)
  : StrongNegation A :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Inhabited
  (A : Prop) (inst : Inhabited A)
  : StrongNegation A :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_True :
  StrongNegation True :=
{
  NOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_False :
  StrongNegation False :=
{
  NOT := True;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_or
  (P Q : Prop) (PSN : StrongNegation P) (QSN : StrongNegation Q)
  : StrongNegation (P \/ Q) :=
{
  NOT := NOT P /\ NOT Q;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_and
  (P Q : Prop) (PSN : StrongNegation P) (QSN : StrongNegation Q)
  : StrongNegation (P /\ Q) :=
{
  NOT := NOT P \/ NOT Q;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_impl
  (P Q : Prop) (QSN : StrongNegation Q)
  : StrongNegation (P -> Q) :=
{
  NOT := P /\ NOT Q;
}.
Proof.
  destruct 1. intro pq. apply QSN.
    assumption.
    apply pq. assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_forall
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation (forall x : A, P x) :=
{
  NOT := exists x : A, NOT (P x);
}.
Proof.
  intros [x np] H.
  apply (PSN x).
    assumption.
    apply H.
Defined.

#[refine]
#[export]
Instance StrongNegation_exists
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation (exists x : A, P x) :=
{
  NOT := forall x : A, NOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

Compute NOT (forall n : nat, True).
Compute NOT (NOT (forall n : nat, True)).

End StrongNegation_Prop.

Module StrongNegation_Type.

Class StrongNegation (A : Type) : Type :=
{
  TNOT : Type;
  TNOT_spec : TNOT -> A -> False;
}.

Arguments TNOT A {StrongNegation}.

#[refine]
#[export]
Instance StrongNegation_Default
  (A : Type) : StrongNegation A | 999 :=
{
  TNOT := A -> False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Pointed
  (A : Type) (inst : Pointed A)
  : StrongNegation A :=
{
  TNOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_Inhabited
  (A : Type) (inst : Inhabited A)
  : StrongNegation A :=
{
  TNOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_True :
  StrongNegation unit :=
{
  TNOT := False;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_False :
  StrongNegation False :=
{
  TNOT := True;
}.
Proof.
  trivial.
Defined.

#[refine]
#[export]
Instance StrongNegation_or
  (A B : Type) (PSN : StrongNegation A) (QSN : StrongNegation B)
  : StrongNegation (A + B) :=
{
  TNOT := TNOT A * TNOT B;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_and
  (A B : Type) (PSN : StrongNegation A) (QSN : StrongNegation B)
  : StrongNegation (A * B) :=
{
  TNOT := TNOT A + TNOT B;
}.
Proof.
  destruct 1, 1.
    apply PSN; assumption.
    apply QSN; assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_fun
  (A B : Type) (QSN : StrongNegation B)
  : StrongNegation (A -> B) :=
{
  TNOT := A * TNOT B;
}.
Proof.
  destruct 1. intro pq. apply QSN.
    assumption.
    apply pq. assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_pi
  (A : Type) (P : A -> Type)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation (forall x : A, P x) :=
{
  TNOT := {x : A & TNOT (P x)};
}.
Proof.
  intros [x np] H.
  apply (PSN x).
    assumption.
    apply H.
Defined.

#[refine]
#[export]
Instance StrongNegation_subset
  (A : Type) (P : A -> Prop)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation {x : A | P x} :=
{
  TNOT := forall x : A, TNOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

#[refine]
#[export]
Instance StrongNegation_sigma
  (A : Type) (P : A -> Type)
  (PSN : forall x : A, StrongNegation (P x))
  : StrongNegation {x : A & P x} :=
{
  TNOT := forall x : A, TNOT (P x);
}.
Proof.
  intros H [x np]. apply (PSN x).
    apply H.
    assumption.
Defined.

Compute TNOT (forall n : nat, True).
Compute TNOT (TNOT (forall n : nat, True)).
Compute TNOT nat.

End StrongNegation_Type.

(** Klasy zbierające poszczególne implementacje izomorficznych typów są
    w ogólności potrzebne nawet jeżeli mamy homotopiczną teorię typów,
    bo przecież używanie izomorfizmów zrobionych ze ścieżek kosztuje. *)

Module Natural.

Class Natural (A : Type) : Type :=
{
  zero : A;
  succ : A -> A;
  rect :
    forall P : A -> Type,
      P zero -> (forall n : A, P n -> P (succ n)) ->
        forall n : A, P n;

  add : A -> A -> A;
  sub : A -> A -> A;

  mul : A -> A -> A;

  pred : A -> option A;
}.

#[export]
Instance Natural_nat : Natural nat :=
{
  zero := 0;
  succ := S;
  rect := nat_rect;

  add := plus;
  sub := minus;

  mul := mult;

  pred n := match n with | 0 => None | S n' => Some n' end
}.

End Natural.

Require Import ZArith.

Module Integral.

Class Integral (A : Type) : Type :=
{
  zero : A;
  succ : A -> A;
  pred : A -> A;

  add : A -> A -> A;
  sub : A -> A -> A;

  mul : A -> A -> A;
}.

#[export]
Instance Integral_Z : Integral Z :=
{
  zero := 0;
  succ := Z.succ;
  pred := Z.pred;

  add := Z.add;
  sub := Z.sub;

  mul := Z.mul;
}.

End Integral.

Require Import QArith.

Module Rational.

Class Rational (A : Type) : Type :=
{
  zero : A;

  add : A -> A -> A;
  sub : A -> A -> A;

  mul : A -> A -> A;
  div : A -> A -> option A;
}.

#[export]
Instance Rational_Q : Rational Q :=
{
  zero := 0;
  add := Qplus;
  sub := Qminus;

  mul := Qmult;
  div p q := if Qeq_bool q 0 then None else Some (Qdiv p q);
}.

End Rational.

Module Sequence.

Class Sequence (A L : Type) : Type :=
{
  nil : L;
  cons : A -> L -> L;

  rect :
    forall P : L -> Type,
      P nil -> (forall (h : A) (t : L), P t -> P (cons h t)) ->
        forall l : L, P l;

  snoc : L -> A -> L;

  app : L -> L -> L;
  rev : L -> L -> L;

  (* no map with this definition *)
}.

End Sequence.

(** TODO:
    - HoTTowa baza
    - hierarchia algebraiczna
    - typy skończone
*)

(** Trzeba mieć pod ręką zarówno trójstronne porównania, jak i te klasyczne (mniejszy lub równy).
    Dzięki eleganckiej koercji można tych bardziej ogólnych, czyli trójstronnych, używać też tam
    gdzie potrzeba nam [bool]a. Koercja w drugą stronę jest upierdliwsza, a raczej brak jej wcale. *)

Inductive Cmp : Type := Lt | Eq | Gt.

Definition Cmp2bool (c : Cmp) : bool :=
match c with
| Lt => true
| Eq => true
| Gt => false
end.

Coercion Cmp2bool : Cmp >-> bool.

(** Uwaga: daje nam to też koercję [(A -> A -> comparison) >-> (A -> A -> bool)], czyli elegancko. *)

(** Uwaga2: [Cmp] jest już w bibliotece standardowej i nazywa się [comparison]. *)

(** Inna fajna rzecz: generyczne Exists/Forall, w tym generyczne w sensie ilości argumentów (vararg). *)


Require Import List.
Import ListNotations.
Require Import PeanoNat.
Require Import Coq.omega.Omega.
Require Import Coq.Numbers.NatInt.NZOrder.

From VLG Require Import matcher.
From VLG Require Import ltac.

Definition Sigma := matcher.Sigma.
Definition Sigma_dec := matcher.Sigma_dec.
Definition String := matcher.String.

Lemma String_dec : forall s s' : String, {s = s'} + {s <> s'}.
Proof. decide equality. apply Sigma_dec. Qed.

Definition State : Type := regex.
Definition transition : Sigma -> State -> State := derivative.
Definition accepts : String -> State -> bool := exp_matchb.
Definition accepting : State -> bool:= nullable.

Lemma accepts_nil: forall(fsm : State),
    accepting fsm = accepts [] fsm.
Proof.
  intros fsm. reflexivity.
Qed.

Lemma accepts_transition : forall cand a fsm,
    accepts cand (transition a fsm)
    = accepts (a :: cand) fsm.
Proof.
  auto.
Qed.

Inductive eq_models : State -> regex -> Prop :=
| SReq (fsm : State) (r : regex)
       (H1 : forall(s : String), true = accepts s fsm <-> exp_match s r) :
    eq_models fsm r.

Definition init_state (r : regex) : State := r.
Definition init_state_inv (fsm : State) : regex := fsm.
(** Facts about inverting init_state **)
Lemma invert_init_correct' : forall(r : regex) (s : String),
    exp_match s (init_state_inv (init_state r)) <-> exp_match s r.
Proof.
  intros. split; auto.
Qed.

Definition Label : Type := String.
Definition Prefix : Type := String.
Definition Suffix : Type := String.
Definition Token : Type := Label * Prefix.
Definition Rule : Type := Label * regex.

Lemma ru_dec : forall (ru1 ru2 : Rule), {ru1 = ru2} + {ru1 <> ru2}.
Proof.
  intros. destruct ru1. destruct ru2.
  destruct (String_dec l l0); destruct (regex_dec r r0); subst; auto;
    right; intros C; destruct n; inv C; auto.
Qed.

Definition sRule : Type := Label * State.

(** Facts about accepts/accepting **)
Lemma accepts_matches : forall(s : String) (fsm : State),
    true = accepts s fsm <-> exp_match s (init_state_inv fsm).
Proof.
  intros. split; intros; apply match_iff_matchb; auto.
Qed.

(* no external depends after this *)
Lemma accepting_nilmatch : forall fsm,
    true = accepting fsm
    <-> exp_match [] (init_state_inv fsm).
Proof.
  intros. split; intros.
  - apply accepts_matches. rewrite <- accepts_nil. auto.
  - apply accepts_matches in H. rewrite accepts_nil. auto.
Qed.

Lemma inv_eq_model : forall(fsm : State),
    eq_models fsm (init_state_inv fsm).
Proof.
  intros fsm. apply SReq. intros s. rewrite accepts_matches. split; auto.
Qed.

Lemma inv_transition : forall cand a fsm,
    exp_match cand (init_state_inv (transition a fsm))
    <-> exp_match (a :: cand) (init_state_inv fsm).
Proof.
  intros. repeat rewrite <- accepts_matches. rewrite accepts_transition.
  split; auto.
Qed.


Require Export prosa.analysis.facts.behavior.completion.

(** * Deadlines *)

(** In this file, we observe basic properties of the behavioral job
    model w.r.t. deadlines. *)
Section DeadlineFacts.

  (** Consider any given type of jobs with costs and deadlines... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job}.

  (** ... any given type of processor states. *)
  Context {PState: eqType}.
  Context `{ProcessorState Job PState}.

  (** We begin with schedules / processor models in which scheduled jobs
    always receive service. *)
  Section IdealProgressSchedules.

    (** Consider a given reference schedule... *)
    Variable sched: schedule PState.

    (** ...in which complete jobs don't execute... *)
    Hypothesis H_completed_jobs: completed_jobs_dont_execute sched.

    (** ...and scheduled jobs always receive service. *)
    Hypothesis H_scheduled_implies_serviced: ideal_progress_proc_model PState.

    (** We observe that, if a job is known to meet its deadline, then
       its deadline must be later than any point at which it is
       scheduled. That is, if a job that meets its deadline is
       scheduled at time t, we may conclude that its deadline is at a
       time later than t. *)
    Lemma scheduled_at_implies_later_deadline:
      forall j t,
        job_meets_deadline sched j ->
        scheduled_at sched j t ->
        t < job_deadline j.
    Proof.
      move=> j t.
      rewrite /job_meets_deadline => COMP SCHED.
      case: (boolP (t < job_deadline j)) => //.
      rewrite -leqNgt => AFTER_DL.
      apply completion_monotonic with (t' := t) in COMP => //.
      apply scheduled_implies_not_completed in SCHED => //.
      move/negP in SCHED. contradiction.
    Qed.

  End IdealProgressSchedules.

  (** In the following section, we observe that it is sufficient to
      establish that service is invariant across two schedules at a
      job's deadline to establish that it either meets its deadline in
      both schedules or none. *)
  Section EqualProgress.

    (** Consider any two schedules [sched] and [sched']. *)
    Variable sched sched': schedule PState.

    (** We observe that, if the service is invariant at the time of a
       job's absolute deadline, and if the job meets its deadline in one of the schedules,
       then it meets its deadline also in the other schedule. *)
    Lemma service_invariant_implies_deadline_met:
      forall j,
        service sched j (job_deadline j) = service sched' j (job_deadline j) ->
        (job_meets_deadline sched j <-> job_meets_deadline sched' j).
    Proof.
      move=> j SERVICE.
      split;
        by rewrite /job_meets_deadline /completed_by -SERVICE.
    Qed.

  End EqualProgress.

End DeadlineFacts.


From Coq Require Import OrderedType.
From mathcomp Require Import ssreflect ssrbool eqtype.
From ssrlib Require Import Types.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Coq OrderedType with Boolean equality. *)

Module Type SsrOrderMinimal.
  Parameter t : eqType.
  Definition eqn : t -> t -> bool := fun x y => x == y.
  Parameter ltn : t -> t -> bool.
  Axiom ltn_trans : forall x y z : t, ltn x y -> ltn y z -> ltn x z.
  Axiom ltn_not_eqn : forall x y : t, ltn x y -> x != y.
  Parameter compare : forall x y : t, Compare ltn eqn x y.
End SsrOrderMinimal.

Module Type SsrOrder <: OrderedType.
  Parameter T : eqType.
  Definition t : Type := T.
  Definition eq : t -> t -> Prop := fun x y => x == y.
  Parameter ltn : t -> t -> bool.
  Definition lt : t -> t -> Prop := fun x y => ltn x y.
  Axiom eq_refl : forall x : t, eq x x.
  Axiom eq_sym : forall x y : t, eq x y -> eq y x.
  Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Parameter compare : forall x y : t, Compare lt eq x y.
  Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.

  (* Derived facts *)
  Axiom ltn_trans : forall x y z : t, ltn x y -> ltn y z -> ltn x z.
  Axiom ltn_eqF : forall (x y : t), ltn x y -> (x == y) = false.
  Axiom ltnn : forall (x : t), ltn x x = false.
  Axiom nltn_eqVlt : forall (x y : t), (~~ ltn x y) = ((x == y) || ltn y x).
  Axiom ltn_neqAlt : forall (x y : t), ltn x y = (x != y) && ~~ (ltn y x).
  Axiom neq_ltn : forall (x y : t), (x != y) = (ltn x y) || (ltn y x).
End SsrOrder.

Module MakeSsrOrder (M : SsrOrderMinimal) <: SsrOrder.

  Definition T : eqType := M.t.

  Definition t : Type := T.

  Definition eq : t -> t -> Prop := fun x y => x == y.

  Definition ltn : t -> t -> bool := M.ltn.

  Definition lt : t -> t -> Prop := fun x y => ltn x y.

  Lemma eq_refl (x : t) : eq x x.
  Proof. exact: eqxx. Qed.

  Lemma eq_sym (x y : t) : eq x y -> eq y x.
  Proof. by rewrite /eq eq_sym. Qed.

  Lemma eq_trans (x y z : t) : eq x y -> eq y z -> eq x z.
  Proof. move=> Hxy Hyz. rewrite (eqP Hxy). exact: Hyz. Qed.

  Definition lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z :=
    M.ltn_trans.

  Lemma lt_not_eq (x y : t) : lt x y -> ~ eq x y.
  Proof. move=> Hlt Heq. by move/negP: (M.ltn_not_eqn Hlt). Qed.

  Definition compare : forall x y : t, Compare lt eq x y := M.compare.
  Lemma eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
  Proof.
    move=> x y.
    case Hxy: (x == y).
    - left; exact: Hxy.
    - right; move=> Heq.
      apply/negPf: Hxy.
      exact: Heq.
  Qed.

  Lemma ltn_trans (x y z : t) : ltn x y -> ltn y z -> ltn x z.
  Proof. exact: lt_trans. Qed.

  Lemma ltn_eqF (x y : t) : ltn x y -> (x == y) = false.
  Proof. move=> H. apply/negP. exact: lt_not_eq. Qed.

  Lemma ltnn (x : t) : ltn x x = false.
  Proof. case H: (ltn x x) => //=. move: (ltn_eqF H). by rewrite eqxx. Qed.

  Lemma nltn_eqVlt (x y : t) : (~~ ltn x y) = ((x == y) || ltn y x).
  Proof.
    case Heq: (x == y) => /=.
    - by rewrite (eqP Heq) ltnn.
    - case Hlt: (ltn x y) => /=; symmetry.
      + apply/negP => Hyx. move: (ltn_trans Hlt Hyx). by rewrite ltnn.
      + move: Heq Hlt. case: (compare x y); by move=> ->.
  Qed.

  Lemma ltn_neqAlt (x y : t) : ltn x y = (x != y) && ~~ (ltn y x).
  Proof.
    rewrite nltn_eqVlt. case H: ((x != y) && ((y == x) || ltn x y)).
    - move/andP: H=> [H1 H2]. case/orP: H2 => H2.
      + by rewrite (eqP H2) eqxx in H1.
      + assumption.
    - apply/negP=> H2. move/negP: H; apply. rewrite (ltn_eqF H2) H2.
      by rewrite orbT.
  Qed.

  Lemma neq_ltn (x y : t) : (x != y) = (ltn x y) || (ltn y x).
  Proof.
    case: (compare x y) => H.
    - by rewrite (ltn_eqF H) H.
    - by rewrite H (eqP H) !ltnn.
    - by rewrite H eqtype.eq_sym (ltn_eqF H) orbT.
  Qed.

End MakeSsrOrder.

(* OrderedType with a default value and a successor function,
   useful for generating new values *)

Module Type HasSucc (Import T : SsrOrder).
  Parameter succ : t -> t.
End HasSucc.

Module Type HasLtn (Import T : SsrOrder).
  Parameter ltn : t -> t -> bool.
End HasLtn.

Module Type HasLtnSucc (Import T : SsrOrder) (Import L : HasLtn T) (Import S : HasSucc T).
  Parameter ltn_succ : forall (x : t), ltn x (succ x).
End HasLtnSucc.

Module Type SsrOrderWithDefaultSucc <: SsrOrder :=
  SsrOrder <+ HasDefault <+ HasSucc <+ HasLtnSucc.

(** Product of ordered types. *)

Module MakeProdOrderMinimal (O1 O2 : SsrOrder) <: SsrOrderMinimal with Definition t := prod_eqType O1.T O2.T.

  Definition t : eqType := prod_eqType O1.T O2.T.

  Definition eqn (x y : t) : bool := x == y.

  Definition ltn (x y : t) : bool :=
    O1.ltn (fst x) (fst y) || (fst x == fst y) && O2.ltn (snd x) (snd y).

  Lemma ltn_trans (x y z : t) : ltn x y -> ltn y z -> ltn x z.
  Proof.
    case: x => x1 x2; case: y => y1 y2; case: z => z1 z2. rewrite /ltn /=.
    case/orP=> [Hxy1 | /andP [Hxy1 Hxy2]]; (case/orP=> [Hyz1 | /andP [Hyz1 Hyz2]]).
    - by rewrite (O1.lt_trans Hxy1 Hyz1).
    - by rewrite -(eqP Hyz1) Hxy1.
    - by rewrite (eqP Hxy1) Hyz1.
    - by rewrite (eqP Hxy1) (eqP Hyz1) eqxx (O2.lt_trans Hxy2 Hyz2) orbT.
  Qed.

  Lemma ltn_not_eqn (x y : t) : ltn x y -> x != y.
  Proof.
    case: x => x1 x2; case: y => y1 y2. rewrite /ltn /=.
    case/orP=> [Hxy1 | /andP [Hxy1 Hxy2]].
    - apply/eqP=> H. case: H => H1 H2. apply: (O1.lt_not_eq Hxy1). by apply/eqP.
    - apply/eqP=> H. case: H => H1 H2. apply: (O2.lt_not_eq Hxy2). by apply/eqP.
  Qed.

  Definition compare (x y : t) : Compare ltn eqn x y.
  Proof.
    case: x => x1 x2; case: y => y1 y2. rewrite /ltn /eqn.
    case: (O1.compare x1 y1) => H1.
    - apply: LT => /=. by rewrite H1.
    - case: (O2.compare x2 y2) => H2.
      + apply: LT => /=. by rewrite H1 H2 orbT.
      + apply: EQ => /=. by rewrite (eqP H1) (eqP H2).
      + apply: GT => /=. by rewrite (eqP H1) eqxx H2 orbT.
    - apply: GT => /=. by rewrite H1.
  Defined.

End MakeProdOrderMinimal.

Module MakeProdOrder (O1 O2 : SsrOrder) <: SsrOrder
    with Definition T := prod_eqType O1.T O2.T.
  Module M := MakeProdOrderMinimal O1 O2.
  Module P := MakeSsrOrder M.
  Include P.
End MakeProdOrder.

Module MakeProdOrderWithDefaultSucc (O1 O2 : SsrOrderWithDefaultSucc) <: SsrOrderWithDefaultSucc
    with Definition T := prod_eqType O1.T O2.T.
  Module M := MakeProdOrderMinimal O1 O2.
  Module P := MakeSsrOrder M.
  Include P.
  Definition default : t := (O1.default, O2.default).
  Definition succ (x : t) : t := (O1.succ (fst x), O2.default).
  Lemma ltn_succ (x : t) : ltn x (succ x).
  Proof.
    case: x => x y. rewrite /ltn /succ /=. rewrite /M.ltn /=.
    by rewrite O1.ltn_succ /=.
  Qed.
End MakeProdOrderWithDefaultSucc.

(** Union of ordered types. *)

Module MakeUnionOrderMinimal
       (V1 : SsrOrder) (V2 : SsrOrder) <: SsrOrderMinimal.

  Inductive ut : Type :=
  | C1 : V1.t -> ut
  | C2 : V2.t -> ut.

  Definition uo_eqb (x y : ut) : bool :=
    match x, y with
    | C1 x, C1 y => x == y
    | C2 x, C2 y => x == y
    | _, _ => false
    end.

  Lemma uo_eqP : Equality.axiom uo_eqb.
  Proof.
    move=> x y.
    case H: (uo_eqb x y).
    - apply: ReflectT.
      move: H; case: y; case: x => //=.
      + move=> x y H.
        rewrite (eqP H).
        reflexivity.
      + move=> x y H.
        rewrite (eqP H).
        reflexivity.
    - apply: ReflectF.
      move: H; case: y; case: x => //=.
      + move=> x y H1 [] H2.
        apply/negPf: H1.
        rewrite H2; exact: eqxx.
      + move=> x y H1 [] H2.
        apply/negPf: H1.
        rewrite H2; exact: eqxx.
  Qed.

  Canonical uo_eqMixin := EqMixin uo_eqP.
  Canonical uo_eqType := Eval hnf in EqType ut uo_eqMixin.

  Definition t : eqType := uo_eqType.

  Definition eqn : t -> t -> bool := uo_eqb.

  Definition ltn (x y : t) : bool :=
    match x, y with
    | C1 x, C1 y => V1.ltn x y
    | C1 _, C2 _ => true
    | C2 _, C1 _ => false
    | C2 x, C2 y => V2.ltn x y
    end.

  Lemma ltn_trans (x y z : t) : ltn x y -> ltn y z -> ltn x z.
  Proof.
    case: z; case: y; case: x => //=.
    - exact: V1.lt_trans.
    - exact: V2.lt_trans.
  Qed.

  Lemma ltn_not_eqn (x y : t) : ltn x y -> x != y.
  Proof.
    case: y; case: x => //=.
    - move=> x y H. apply/negP. exact: V1.lt_not_eq.
    - move=> x y H. apply/negP. exact: V2.lt_not_eq.
  Qed.

  Definition compare (x y : t) : Compare ltn eqn x y.
  Proof.
    case: y; case: x.
    - move=> x y.
      case H: (V1.compare x y).
      + apply: LT; assumption.
      + apply: EQ; assumption.
      + apply: GT; assumption.
    - move=> x y.
      by apply: GT.
    - move=> x y.
      by apply: LT.
    - move=> x y.
      case H: (V2.compare x y).
      + apply: LT; assumption.
      + apply: EQ; assumption.
      + apply: GT; assumption.
  Defined.

End MakeUnionOrderMinimal.

Module MakeUnionOrder
       (V1 : SsrOrder) (V2 : SsrOrder) <: SsrOrder.
  Module M := MakeUnionOrderMinimal V1 V2.
  Module O := MakeSsrOrder M.
  Include O.
  Definition c1 (x : V1.t) : t := M.C1 x.
  Definition c2 (x : V2.t) : t := M.C2 x.
End MakeUnionOrder.

(** A singleton ordered type. *)

Module UnitOrderMinimal <: SsrOrderMinimal.

  Definition t : eqType := unit_eqType.

  Definition eqn (x y : t) : bool := x == y.

  Definition ltn (x y : t) : bool := false.

  Lemma ltn_trans (x y z : t) : ltn x y -> ltn y z -> ltn x z.
  Proof. done. Qed.

  Lemma ltn_not_eqn (x y : t) : ltn x y -> x != y.
  Proof. done. Qed.

  Definition compare (x y : t) : Compare ltn eqn x y.
  Proof. by apply: EQ. Defined.

End UnitOrderMinimal.

Module UnitOrder <: SsrOrder.
  Module O := MakeSsrOrder UnitOrderMinimal.
  Include O.
End UnitOrder.

(** Convert orderType to SsrOrder. *)

From mathcomp Require Import order.
Import Order.Theory.

Module Type OrderType.
  Parameter d : unit.
  Parameter t : orderType d.
End OrderType.

Module SsrOrderMinimalOfOrderType (O : OrderType) <: SsrOrderMinimal.
  Local Open Scope order_scope.
  Definition t := Order.Total.eqType O.t.
  Definition eqn (x y : t) : bool := x == y.
  Definition ltn (x y : t) : bool := x < y.
  Lemma ltn_trans : forall x y z : t, ltn x y -> ltn y z -> ltn x z.
  Proof.
    move=> x y z. rewrite /ltn => Hxy Hyz. exact: (lt_trans Hxy Hyz).
  Qed.
  Lemma ltn_not_eqn : forall x y : t, ltn x y -> x != y.
  Proof.
    move=> x y. rewrite /ltn lt_def. rewrite eq_sym. move/andP=> [-> _]. reflexivity.
  Qed.
  Definition compare : forall x y : t, Compare ltn eqn x y.
  Proof.
    move=> x y. case Heq: (x == y).
    - exact: (EQ Heq).
    - case Hlt: (x < y).
      + exact: (LT Hlt).
      + apply: GT. rewrite /ltn lt_def. rewrite Heq /=. rewrite leNgt Hlt. reflexivity.
  Defined.
End SsrOrderMinimalOfOrderType.

Module SsrOrderOfOrderType (O : OrderType) <: SsrOrder.
  Module M := SsrOrderMinimalOfOrderType O.
  Module P := MakeSsrOrder M.
  Include P.
End SsrOrderOfOrderType.