(** * The category of finite sets

Author: Langston Barrett (@siddharthist)

*)

(** ** Contents:

- The univalent category [FinSet] of finite sets/types
- (Co)limits
  - Colimits
    - Binary coproducts
  - Limits
    - Binary products

*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Combinatorics.FiniteSets.

(* Basics *)
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.

(* HSET *)
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.

(* Lemmas about forming (full) subcategories *)
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.

(* Limits *)
Require Import UniMath.CategoryTheory.Subcategory.Limits.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.

Local Open Scope cat.
Local Open Scope functions.

(** ** The univalent category [FinSet] of finite sets/types *)

(** This could be defined in three ways:
    1. as a subcategory of [type_precat],
    2. as a subcategory of [HSET] (see [isfinite_isaset]), or
    3. as a regular precategory.

    We choose the second due to the ability to inherit many structures from [HSET].
 *)
Definition finite_subtype : hsubtype (ob HSET) := isfinite ∘ pr1hSet.
Definition FinSet : univalent_category :=
  subcategory_univalent HSET_univalent_category finite_subtype.

(** ** (Co)limits *)

(** *** Colimits *)

(** **** Binary coproducts *)

(** The coproduct of finite sets is finite, so the predicate "is finite" is closed
    under the formation of coproducts. Therefore, FinSet inherits coproducts from HSET. *)
Definition BinCoproductsFinSet : BinCoproducts FinSet.
Proof.
  apply (@bin_coproducts_in_full_subcategory HSET_univalent_category
                                             finite_subtype BinCoproductsHSET).
  intros; apply isfinitecoprod; assumption.
Defined.

(** *** Limits *)

(** **** Binary products *)

(** The product of finite sets is finite, so the predicate "is finite" is closed
    under the formation of products. Therefore, FinSet inherits products from HSET. *)
Definition BinProductsFinSet : BinProducts FinSet.
Proof.
  apply (@bin_products_in_full_subcategory HSET_univalent_category
                                           finite_subtype BinProductsHSET).
  intros; apply isfinitedirprod; assumption.
Defined.


Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.

Require Import Hapsl.Ascii.Equality.

Import AsciiEqualityNotations.

(* Returns true if two strings are equivalent, otherwise returns false. *)
Fixpoint beq_string (s1 s2 : string) : bool :=
  match s1, s2 with
  | EmptyString, EmptyString => true
  | String c1 s1', String c2 s2' => andb (c1 ==_a c2) (beq_string s1' s2')
  | _, _ => false
  end.

(* Proves the reflexivity of boolean string equality. *)
Lemma beq_string_reflexive : forall (s : string),
  beq_string s s = true.
Proof.
  intros.
  induction s as [| h tail IH].
  + reflexivity.
  + unfold beq_string.
    rewrite beq_ascii_reflexive.
    auto.
Qed.

(* TODO: Symmetry of beq_string? *)

(* TODO: Transitivity of beq_string? *)

(* Equality notations module for ASCII strings. *)
Module StringEqualityNotations.

  (* String equality operator. *)
  Notation "a ==_s b" := (beq_string a b) (at level 30).

End StringEqualityNotations.


(* BEGIN FIX *)
Require Import Coq.Strings.String.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AVar (x : string)
  | APlus (a a' : aexp)
  | AMult (a a' : aexp).

Definition state : Type := string -> nat.

Fixpoint aeval (e : aexp)(s : state) : nat := match e with
  | ANum n => n
  | AVar x => s x
  | APlus a a' => aeval a s + aeval a' s
  | AMult a a' => aeval a s * aeval a' s
  end.

Inductive zart : aexp -> Prop :=
  | szam (n : nat) : zart (ANum n)
  | osszeg (a a' : aexp)(az : zart a)
           (a'z : zart a') : zart (APlus a a')
  | szorzat (a a' : aexp)(az : zart a)
            (a'z : zart a') : zart (AMult a a').

Lemma zartPlusMult (e1 e2 : aexp)(p1 : zart e1)(p2 : zart e2) :
  zart (APlus e1 (AMult e1 e2)).
Proof.
  exact (osszeg e1 (AMult e1 e2) p1 (szorzat e1 e2 p1 p2)).
Qed.
(* END FIX *)

(* BEGIN FIX *)
Theorem evalZart (a : aexp)(q : zart a)(s1 s2 : state) :
  aeval a s1 = aeval a s2.
Proof.
  induction q; trivial.
  simpl. rewrite IHq1. rewrite IHq2. trivial.
  simpl. rewrite IHq1. rewrite IHq2. trivial.
Qed.
(* END FIX *)

(* BONUS! use assert and discriminate!
Lemma lem (p : forall e1 e2, aeval e1 empty = aeval e2 empty -> e1 = e2) : False.
 *)


(* Reference: https://www.cs.umd.edu/~rrand/vqc/Complex.html *)

Require Import Psatz.
Require Import Arith.
Require Import Setoid.
Require Import Bool.
Require Import Program.
Require Export Coq.ZArith.ZArith.

(* ZSum and its properties *)
Open Scope Z_scope.

Fixpoint Zsum (f : nat -> Z) (n : nat) : Z :=
  match n with
  | O => 0
  | S n' => Zsum f n' +  f n'
  end.

Lemma Zsum_eq : forall (f g : nat -> Z) (n : nat),
  (forall x, (x < n)%nat -> f x = g x) ->
  Zsum f n = Zsum g n.
Proof.
  intros f g n H.
  induction n.
  + simpl. reflexivity.
  + simpl.
    rewrite H by lia.
    rewrite IHn by (intros; apply H; lia).
    reflexivity.
Qed.

Lemma func_shift: forall (f: nat -> Z)(n: nat),
  exists g, (forall x, (x < n)%nat -> f (x + n)%nat = g x).
Proof.
  intros.
  exists (fun x => f (x + n)%nat).
  tauto.
Qed.

Lemma Zsum_g_g': forall (n : nat) (g g' : nat -> Z),
  (forall x : nat, (x < n)%nat -> g (S x) = g' x) ->
  Zsum g (S n) = g 0%nat + Zsum g' n.
Proof.
  intros.
  induction n.
  + simpl.
    lia.
  + assert (forall x : nat, (x < n)%nat -> g (S x) = g' x). {
      intros.
      assert ((x < S n)%nat). { lia. }
      pose proof (H x H1). clear H1.
      tauto.
    }
    pose proof (IHn H0).
    replace (Zsum g (S (S n))) with (Zsum g (S n) + g (S n)) by reflexivity.
    rewrite H1.
    simpl.
    assert ((n < S n)%nat). { lia. }
    pose proof (H n H2).
    rewrite H3.
    lia.
Qed.

Lemma Zsum_f_g: forall (n : nat) (f g g' : nat -> Z),
  (forall x : nat, (x < S n)%nat -> f (x + S n)%nat = g' x) ->
  (forall x : nat, (x < n)%nat -> f (x + n)%nat = g x) ->
  Zsum g n + f (2 * n)%nat = f n + Zsum g' n.
Proof.
  intros.
  destruct n.
  + simpl.
    lia.
  + replace (Zsum g' (S n)) with (Zsum g' n + g' n) by reflexivity.
    assert ((n < S (S n))%nat). { lia. }
    pose proof (H n H1). clear H1.
    rewrite <- H2.
    assert ((2 * S n = n + S (S n))%nat). { lia. }
    rewrite <- H1.
    assert (forall x : nat, (x < n)%nat -> g (S x) = g' x). {
      intros.
      assert ((S x < S n)%nat). { lia. }
      assert ((x < S (S n))%nat). { lia. }
      specialize (H x H5).
      specialize (H0 (S x) H4).
      rewrite <- H.
      rewrite <- H0.
      assert ((S x + S n = x + S (S n))%nat). { lia. }
      rewrite H6.
      reflexivity.
    }
  pose proof (Zsum_g_g' n g g' H3).
  rewrite H4.
  assert ((0 < S n)%nat). { lia. }
  pose proof (H0 0%nat H5).
  rewrite <- H6.
  simpl.
  lia.
Qed.

Lemma Zsum_eq_seg: forall (f: nat -> Z)(n : nat),
  forall (g: nat -> Z), (forall x, (x < n)%nat -> f (x + n)%nat = g x) ->
  Zsum f (2 * n) = Zsum f n + Zsum g n.
Proof.
  intros f n.
  induction n.
  + tauto.
  + intros g' ?.
    (* Zsum f  (2n + 2) -> Zsum f (2n + 1) + f (2n + 1) *)
    (* Zsum f  (n + 1)  -> Zsum f n + f n *)
    (* Zsum g' (n + 1)  -> Zsum g' n + g' n *)
    simpl.
    pose proof func_shift f n.
    destruct H0 as [g ?].
    specialize (IHn g H0).
    assert ((n + S (n + 0))%nat = S (2 * n)). {
      simpl. lia.
    }
    rewrite H1. clear H1.

    (* Zsum f (2n + 1) -> Zsum f (2n) + f (2n) *)
    simpl.
    assert ((n + (n + 0))%nat = (2 * n)%nat). { lia. }
    rewrite H1. clear H1.

    (* use IHn: Zsum f (2n) = Zsum f n + Zsum g n *)
    rewrite IHn.
    assert ((n < S n)%nat). { lia. }
    pose proof H n H1.
    assert ((n + S n)%nat = S (2 * n)). {
      lia.
    }

    (* f (2n + 1) = g' n *)
    assert (f (S (2 * n)) = g' n). {
      rewrite <- H3.
      rewrite H2.
      reflexivity.
    }
    rewrite H4. clear H2 H3 H4.

    (* Zsum g n + f (2 * n)%nat = f n + Zsum g' n *)
    pose proof (Zsum_f_g n f g g' H H0).
    replace (Zsum f n + Zsum g n + f (2 * n)%nat + g' n) with (Zsum f n + (Zsum g n + f (2 * n)%nat) + g' n).
    2: { lia. }
    rewrite H2.
    lia.
Qed.

Lemma Zsum_plus : forall (f g : nat -> Z) (n : nat),
    Zsum (fun x => f x + g x) n = Zsum f n + Zsum g n.
Proof.
  intros f g n.
  induction n.
  - simpl. lia.
  - simpl. rewrite IHn. lia.
Qed.

Lemma Zsum_minus : forall (f g : nat -> Z) (n : nat),
    Zsum (fun x => f x - g x) n = Zsum f n - Zsum g n.
Proof.
  intros f g n.
  induction n.
  - simpl. lia.
  - simpl. rewrite IHn. lia.
Qed.

Lemma Zmult_plus_distr_l : forall c1 c2 c3:Z, c1 * (c2 + c3) = c1 * c2 + c1 * c3.
Proof. intros. lia. Qed.

Lemma Zmult_plus_distr_r : forall c1 c2 c3:Z, (c1 + c2) * c3 = c1 * c3 + c2 * c3.
Proof. intros. lia. Qed.

Lemma Zmult_minus_distr_l : forall c1 c2 c3:Z, c1 * (c2 - c3) = c1 * c2 - c1 * c3.
Proof. intros. lia. Qed.

Lemma Zmult_minus_distr_r : forall c1 c2 c3:Z, (c1 - c2) * c3 = c1 * c3 - c2 * c3.
Proof. intros. lia. Qed.

Lemma Zsum_mult_l : forall (c : Z) (f : nat -> Z) (n : nat),
    c * Zsum f n = Zsum (fun x => c * f x) n.
Proof.
  intros c f n.
  induction n.
  - simpl; lia.
  - simpl.
    rewrite Zmult_plus_distr_l.
    rewrite IHn.
    reflexivity.
Qed.

Lemma Zsum_eq_bounded : forall f g n, (forall x, (x < n)%nat -> f x = g x) -> Zsum f n = Zsum g n.
Proof.
  intros f g n H.
  induction n.
  + simpl. reflexivity.
  + simpl.
    rewrite H by lia.
    rewrite IHn by (intros; apply H; lia).
    reflexivity.
Qed.

Lemma Zmult_plus_dist_l (x y z : Z) : x * (y + z) = x * y + x * z.
Proof.
  lia.
Qed.

Lemma Zmult_plus_dist_r (x y z : Z) : (x + y) * z = x * z + y * z.
Proof.
  lia.
Qed.

Lemma Zmult_minus_dist_l (x y z : Z) : x * (y - z) = x * y - x * z.
Proof.
  lia.
Qed.

Lemma Zmult_minus_dist_r (x y z : Z) : (x - y) * z = x * z - y * z.
Proof.
  lia.
Qed.

Close Scope Z_scope.
(* End of ZSum *)

(* Haoxuan Xu, Yichen Tao *)
(* 2021-05-26 14:12 *)


Require Import HProp HFiber HSet.
Require Import PathAny.
Require Export Classes.interfaces.abstract_algebra.
Require Export Classes.theory.groups.
Require Import Pointed.Core.
Require Import WildCat.

Local Set Polymorphic Inductive Cumulativity.

Generalizable Variables G H A B C f g.

Declare Scope group_scope.

(** ** Groups *)

Local Open Scope pointed_scope.
Local Open Scope mc_mult_scope.
Local Open Scope wc_iso_scope.

(** * Definition of Group *)

(** A group consists of a type, and operation on that type, and unit and an inverse, such that they satisfy the group axioms in IsGroup. *)
Record Group := {
  group_type : Type;
  group_sgop : SgOp group_type;
  group_unit : MonUnit group_type;
  group_inverse : Negate group_type;
  group_isgroup : IsGroup group_type;
}.

Arguments group_sgop {_}.
Arguments group_unit {_}.
Arguments group_inverse {_}.
Arguments group_isgroup {_}.
(** We should never need to unfold the proof that something is a group. *)
Global Opaque group_isgroup.

(** We coerce groups back to types. *)
Coercion group_type : Group >-> Sortclass.
Global Existing Instances group_sgop group_unit group_inverse group_isgroup.

Definition issig_group : _ <~> Group
  := ltac:(issig).

(** * Proof automation *)
(** Many times in group theoretic proofs we want some form of automation for obvious identities. Here we implement such a behaviour. *)

(** We create a database of hints for the group theory library *)
Create HintDb group_db.

(** Our group laws can be proven easily with tactics such as [rapply associativity]. However this requires a typeclass search on more general algebraic structures. Therefore we explicitly list many groups laws here so that coq can use them. We also create hints for each law in our groups database. *)
Section GroupLaws.
  Context {G : Group} (x y z : G).

  Definition grp_assoc := associativity x y z.
  Definition grp_unit_l := left_identity x.
  Definition grp_unit_r := right_identity x.
  Definition grp_inv_l := left_inverse x.
  Definition grp_inv_r := right_inverse x.

End GroupLaws.

#[export] Hint Immediate grp_assoc  : group_db.
#[export] Hint Immediate grp_unit_l : group_db.
#[export] Hint Immediate grp_unit_r : group_db.
#[export] Hint Immediate grp_inv_l  : group_db.
#[export] Hint Immediate grp_inv_r  : group_db.

(** Given path types in a product we may want to decompose. *)
#[export] Hint Extern 5 (@paths (_ * _) _ _) => (apply path_prod) : group_db.
(** Given path types in a sigma type of a hprop family (i.e. a subset) we may want to decompose. *)
#[export] Hint Extern 6 (@paths (sig _) _ _) => (rapply path_sigma_hprop) : group_db.

(** We also declare a tactic (notation) for automatically solving group laws *)
(** TODO: improve this tactic so that it also rewrites and is able to solve basic group lemmas. *)
Tactic Notation "grp_auto" := hnf; intros; eauto with group_db.

(** Groups are pointed sets with point the identity. *)
Global Instance ispointed_group (G : Group)
  : IsPointed G := @mon_unit G _.

Definition ptype_group : Group -> pType
  := fun G => [G, _].
Coercion ptype_group : Group >-> pType.

(** * Some basic properties of groups *)

(** An element acting like the identity is unique. *)
Definition identity_unique {A : Type} {Aop : SgOp A}
  (x y : A) {p : LeftIdentity Aop x} {q : RightIdentity Aop y}
  : x = y := (q x)^ @ p y.

Definition identity_unique' {A : Type} {Aop : SgOp A}
  (x y : A) {p : LeftIdentity Aop x} {q : RightIdentity Aop y}
  : y = x := (identity_unique x y)^.

(** An element acting like an inverse is unique. *)
Definition inverse_unique `{IsMonoid A}
  (a x y : A) {p : x * a = mon_unit} {q : a * y = mon_unit}
  : x = y.
Proof.
  refine ((right_identity x)^ @ ap _ q^ @ _).
  refine (associativity _ _ _ @ _).
  refine (ap (fun x => x * y) p @ _).
  apply left_identity.
Defined.

(** ** Group homomorphisms *)

(* A group homomorphism consists of a map between groups and a proof that the map preserves the group operation. *)
Record GroupHomomorphism (G H : Group) := Build_GroupHomomorphism' {
  grp_homo_map : G -> H;
  grp_homo_ishomo :> IsMonoidPreserving grp_homo_map;
}.

(* We coerce a homomorphism to its underlying map. *)
Coercion grp_homo_map : GroupHomomorphism >-> Funclass.
Global Existing Instance grp_homo_ishomo.

(* Group homomorphisms are pointed maps *)
Definition pmap_GroupHomomorphism {G H : Group} (f : GroupHomomorphism G H) : G ->* H
  := Build_pMap G H f (@monmor_unitmor _ _ _ _ _ _ _ (@grp_homo_ishomo G H f)).
Coercion pmap_GroupHomomorphism : GroupHomomorphism >-> pForall.

Definition issig_GroupHomomorphism (G H : Group) : _ <~> GroupHomomorphism G H
  := ltac:(issig).

Definition equiv_path_grouphomomorphism {F : Funext} {G H : Group}
  {g h : GroupHomomorphism G H} : g == h <~> g = h.
Proof.
  refine ((equiv_ap (issig_GroupHomomorphism G H)^-1 _ _)^-1 oE _).
  refine (equiv_path_sigma_hprop _ _ oE _).
  apply equiv_path_forall.
Defined.

Global Instance ishset_grouphomomorphism {F : Funext} {G H : Group}
  : IsHSet (GroupHomomorphism G H).
Proof.
  intros f g; apply (istrunc_equiv_istrunc _ equiv_path_grouphomomorphism).
Defined.

(** * Some basic properties of group homomorphisms *)

(** Group homomorphisms preserve identities *)
Definition grp_homo_unit {G H} (f : GroupHomomorphism G H)
  : f (mon_unit) = mon_unit.
Proof.
  apply monmor_unitmor.
Defined.
#[export] Hint Immediate grp_homo_unit : group_db.

(** Group homomorphisms preserve group operations *)
Definition grp_homo_op {G H} (f : GroupHomomorphism G H)
  : forall x y : G, f (x * y) = f x * f y.
Proof.
  apply monmor_sgmor.
Defined.
#[export] Hint Immediate grp_homo_op : group_db.

(** Group homomorphisms preserve inverses *)
Definition grp_homo_inv {G H} (f : GroupHomomorphism G H)
  : forall x, f (- x) = -(f x).
Proof.
  intro x.
  apply (inverse_unique (f x)).
  + refine (_ @ grp_homo_unit f).
    refine ((grp_homo_op f (-x) x)^ @ _).
    apply ap.
    apply grp_inv_l.
  + apply grp_inv_r.
Defined.
#[export] Hint Immediate grp_homo_inv : group_db.

(** When building a group homomorphism we only need that it preserves the group operation, since we can prove that the identity is preserved. *)
Definition Build_GroupHomomorphism {G H : Group}
  (f : G -> H) {h : IsSemiGroupPreserving f}
  : GroupHomomorphism G H.
Proof.
  srapply (Build_GroupHomomorphism' _ _ f).
  split.
  1: exact h.
  unfold IsUnitPreserving.
  apply (group_cancelL (f mon_unit)).
  refine (_ @ (grp_unit_r _)^).
  refine (_ @ ap _ (monoid_left_id _ mon_unit)).
  symmetry.
  apply h.
Defined.

Definition grp_homo_id {G : Group} : GroupHomomorphism G G
  := Build_GroupHomomorphism idmap.

Definition grp_homo_compose {G H K : Group}
  : GroupHomomorphism H K -> GroupHomomorphism G H -> GroupHomomorphism G K.
Proof.
  intros f g.
  srapply (Build_GroupHomomorphism (f o g)).
Defined.

Definition grp_homo_const {G H : Group} : GroupHomomorphism G H.
Proof.
  snrapply Build_GroupHomomorphism.
  - exact (fun _ => mon_unit).
  - intros x y.
    exact (grp_unit_l mon_unit)^.
Defined.

(* An isomorphism of groups is a group homomorphism that is an equivalence. *)
Record GroupIsomorphism (G H : Group) := Build_GroupIsomorphism {
  grp_iso_homo : GroupHomomorphism G H;
  isequiv_group_iso : IsEquiv grp_iso_homo;
}.

(* We can build an isomorphism from an operation preserving equivalence. *)
Definition Build_GroupIsomorphism' {G H : Group}
  (f : G <~> H) (h : IsSemiGroupPreserving f)
  : GroupIsomorphism G H.
Proof.
  srapply Build_GroupIsomorphism.
  1: srapply Build_GroupHomomorphism.
  exact _.
Defined.

Coercion grp_iso_homo : GroupIsomorphism >-> GroupHomomorphism.
Global Existing Instance isequiv_group_iso.

Definition issig_GroupIsomorphism (G H : Group)
  : _ <~> GroupIsomorphism G H := ltac:(issig).

Definition equiv_groupisomorphism {G H : Group}
  : GroupIsomorphism G H -> G <~> H
  := fun f => Build_Equiv G H f _.

Definition pequiv_groupisomorphism {A B : Group}
  : GroupIsomorphism A B -> (A <~>* B)
  := fun f => Build_pEquiv _ _ f _.

Coercion equiv_groupisomorphism : GroupIsomorphism >-> Equiv.

Definition equiv_path_groupisomorphism `{F : Funext} {G H : Group}
  (f g : GroupIsomorphism G H)
  : f == g <~> f = g.
Proof.
  refine ((equiv_ap (issig_GroupIsomorphism G H)^-1 _ _)^-1 oE _).
  refine (equiv_path_sigma_hprop _ _ oE _).
  apply equiv_path_grouphomomorphism.
Defined.

Definition ishset_groupisomorphism `{F : Funext} {G H : Group}
  : IsHSet (GroupIsomorphism G H).
Proof.
  intros f g; apply (istrunc_equiv_istrunc _ (equiv_path_groupisomorphism _ _)).
Defined.

Definition grp_iso_id {G : Group} : GroupIsomorphism G G
  := Build_GroupIsomorphism _ _ grp_homo_id _.

Definition grp_iso_compose {G H K : Group}
  (g : GroupIsomorphism H K) (f : GroupIsomorphism G H)
  : GroupIsomorphism G K
  := Build_GroupIsomorphism _ _ (grp_homo_compose g f) _.

Definition grp_iso_inverse {G H : Group}
  : GroupIsomorphism G H -> GroupIsomorphism H G.
Proof.
  intros [f e].
  srapply Build_GroupIsomorphism.
  - srapply (Build_GroupHomomorphism f^-1).
  - exact _.
Defined.

(** Group Isomorphisms are a reflexive relation *)
Global Instance reflexive_groupisomorphism
  : Reflexive GroupIsomorphism
  := fun G => grp_iso_id.

(** Group Isomorphisms are a symmetric relation *)
Global Instance symmetric_groupisomorphism
  : Symmetric GroupIsomorphism
  := fun G H => grp_iso_inverse.

Global Instance transitive_groupisomorphism
  : Transitive GroupIsomorphism
  := fun G H K f g => grp_iso_compose g f.

(** Under univalence, equality of groups is equivalent to isomorphism of groups. *)
Definition equiv_path_group' {U : Univalence} {G H : Group}
  : GroupIsomorphism G H <~> G = H.
Proof.
  refine (equiv_compose'
    (B := sig (fun f : G <~> H => IsMonoidPreserving f)) _ _).
  { revert G H; apply (equiv_path_issig_contr issig_group).
    + intros [G [? [? [? ?]]]].
      exists 1%equiv.
      exact _.
    + intros [G [op [unit [neg ax]]]]; cbn.
      contr_sigsig G (equiv_idmap G).
      srefine (Build_Contr _ ((_;(_;(_;_)));_) _); cbn.
      1: assumption.
      1: exact _.
      intros [[op' [unit' [neg' ax']]] eq].
      apply path_sigma_hprop; cbn.
      refine (@ap _ _ (fun x : { oun :
        { oo : SgOp G & { u : MonUnit G & Negate G}}
        & @IsGroup G oun.1 oun.2.1 oun.2.2}
        => (x.1.1 ; x.1.2.1 ; x.1.2.2 ; x.2))
        ((op;unit;neg);ax) ((op';unit';neg');ax') _).
      apply path_sigma_hprop; cbn.
      srefine (path_sigma' _ _ _).
      1: funext x y; apply eq.
      rewrite transport_const.
      srefine (path_sigma' _ _ _).
      1: apply eq.
      rewrite transport_const.
      funext x.
      exact (preserves_negate (f:=idmap) _). }
  refine (_ oE (issig_GroupIsomorphism G H)^-1).
  refine (_ oE (equiv_functor_sigma' (issig_GroupHomomorphism G H)
    (fun f => 1%equiv))^-1).
  refine (equiv_functor_sigma' (issig_equiv G H) (fun f => 1%equiv) oE _).
  cbn.
  refine (
    equiv_adjointify
      (fun f => (exist (IsMonoidPreserving o pr1)
        (exist IsEquiv f.1.1 f.2) f.1.2))
      (fun f => (exist (IsEquiv o pr1)
        (exist IsMonoidPreserving f.1.1 f.2) f.1.2))
       _ _).
  all: intros [[]]; reflexivity.
Defined.

(** A version with nicer universe variables. *)
Definition equiv_path_group@{u v | u < v} {U : Univalence} {G H : Group@{u}}
  : GroupIsomorphism G H <~> (paths@{v} G H)
  := equiv_path_group'.

(** * Simple group equivalences *)

(** Left multiplication is an equivalence *)
Global Instance isequiv_group_left_op {G : Group}
  : forall (x : G), IsEquiv (x *.).
Proof.
  intro x.
  srapply isequiv_adjointify.
  1: exact (-x *.).
  all: intro y.
  all: refine (grp_assoc _ _ _ @ _ @ grp_unit_l y).
  all: refine (ap (fun x => x * y) _).
  1: apply grp_inv_r.
  apply grp_inv_l.
Defined.

(** Right multiplication is an equivalence *)
Global Instance isequiv_group_right_op (G : Group)
  : forall (x : G), IsEquiv (fun y => y * x).
Proof.
  intro x.
  srapply isequiv_adjointify.
  1: exact (fun y => y * - x).
  all: intro y.
  all: refine ((grp_assoc _ _ _)^ @ _ @ grp_unit_r y).
  all: refine (ap (y *.) _).
  1: apply grp_inv_l.
  apply grp_inv_r.
Defined.

Global Instance isequiv_group_inverse {G : Group}
  : IsEquiv ((-) : G -> G).
Proof.
  srapply isequiv_adjointify.
  1: apply (-).
  all: intro; apply negate_involutive.
Defined.

(** ** Working with equations in groups *)

Section GroupEquations.

  Context {G : Group} (x y z : G).

  (** Inverses are involutive *)
  Definition grp_inv_inv : --x = x := negate_involutive x.

  (** Inverses distribute over the group operation *)
  Definition grp_inv_op : - (x * y) = -y * -x := negate_sg_op x y.

End GroupEquations.

(** ** Cancelation *)

(** Group elements can be cancelled both on the left and the right. *)
Definition grp_cancelL {G : Group} {x y : G} z : x = y <~> z * x = z * y
  := equiv_ap (fun x => z * x) _ _.
Definition grp_cancelR {G : Group} {x y : G} z : x = y <~> x * z = y * z
  := equiv_ap (fun x => x * z) _ _.

(** ** Group movement lemmas *)

Section GroupMovement.

  (** Since left/right multiplication is an equivalence, we can use lemmas about moving equivalences around to prove group movement lemmas. *)

  Context {G : Group} {x y z : G}.

  (** *** Moving group elements *)

  Definition grp_moveL_gM : x * -z = y <~> x = y * z
    := equiv_moveL_equiv_M (f := fun t => t * z) _ _.

  Definition grp_moveL_Mg : -y * x = z <~> x = y * z
    := equiv_moveL_equiv_M (f := fun t => y * t) _ _.

  Definition grp_moveR_gM : x = z * -y <~> x * y = z
    := equiv_moveR_equiv_M (f := fun t => t * y) _ _.

  Definition grp_moveR_Mg : y = -x * z <~> x * y = z
    := equiv_moveR_equiv_M (f := fun t => x * t) _ _.

  (** *** Moving inverses.*)
  (** These are the inverses of the previous but are included here for completeness*)
  Definition grp_moveR_gV : x = y * z <~> x * -z = y
    := equiv_moveR_equiv_V (f := fun t => t * z) _ _.

  Definition grp_moveR_Vg : x = y * z <~> -y * x = z
    := equiv_moveR_equiv_V (f := fun t => y * t) _ _.

  Definition grp_moveL_gV :  x * y = z <~> x = z * -y
    := equiv_moveL_equiv_V (f := fun t => t * y) _ _.

  Definition grp_moveL_Vg :  x * y = z <~> y = -x * z
    := equiv_moveL_equiv_V (f := fun t => x * t) _ _.

(** We close the section here so the previous lemmas generalise their assumptions. *)
End GroupMovement.

Section GroupMovement.

  Context {G : Group} {x y z : G}.

  (** *** Moving elements equal to unit. *)

  Definition grp_moveL_1M : x * -y = mon_unit <~> x = y
    := equiv_concat_r (grp_unit_l _) _ oE grp_moveL_gM.

  Definition grp_moveL_M1 : -y * x = mon_unit <~> x = y
    := equiv_concat_r (grp_unit_r _) _ oE grp_moveL_Mg.

  Definition grp_moveR_1M : mon_unit = y * (-x) <~> x = y
    := (equiv_concat_l (grp_unit_l _) _)^-1%equiv oE grp_moveR_gM.

  Definition grp_moveR_M1 : mon_unit = -x * y <~> x = y
    := (equiv_concat_l (grp_unit_r _) _)^-1%equiv oE grp_moveR_Mg.

  (** *** Cancelling elements equal to unit. *)

  Definition grp_cancelL1 : x = mon_unit <~> z * x = z
    := (equiv_concat_r (grp_unit_r _) _ oE grp_cancelL z).

  Definition grp_cancelR1 : x = mon_unit <~> x * z = z
    := (equiv_concat_r (grp_unit_l _) _) oE grp_cancelR z.

End GroupMovement.

(** Power operation *)

Fixpoint grp_pow {G : Group} (g : G) (n : nat) : G :=
  match n with
  | 0%nat => mon_unit
  | m.+1%nat => g * grp_pow g m
  end.

(** Any homomorphism respects [grp_pow]. *)
Lemma grp_pow_homo {G H : Group} (f : GroupHomomorphism G H)
  (n : nat) (g : G) : f (grp_pow g n) = grp_pow (f g) n.
Proof.
  induction n.
  + cbn. apply grp_homo_unit.
  + cbn. refine ((grp_homo_op f g (grp_pow g n)) @ _).
    exact (ap (fun m => f g + m) IHn).
Defined.

(** The wild cat of Groups *)
Global Instance isgraph_group : IsGraph Group
  := Build_IsGraph Group GroupHomomorphism.

Global Instance is01cat_group : Is01Cat Group :=
  Build_Is01Cat Group _ (@grp_homo_id) (@grp_homo_compose).

Global Instance is2graph_group : Is2Graph Group
  := fun A B => isgraph_induced (@grp_homo_map A B).

Global Instance isgraph_grouphomomorphism {A B : Group} : IsGraph (A $-> B)
  := isgraph_induced (@grp_homo_map A B).

Global Instance is01cat_grouphomomorphism {A B : Group} : Is01Cat (A $-> B)
  := is01cat_induced (@grp_homo_map A B).

Global Instance is0gpd_grouphomomorphism {A B : Group}: Is0Gpd (A $-> B)
  := is0gpd_induced (@grp_homo_map A B).

Global Instance is0functor_postcomp_grouphomomorphism {A B C : Group} (h : B $-> C)
  : Is0Functor (@cat_postcomp Group _ _ A B C h).
Proof.
  apply Build_Is0Functor.
  intros [f ?] [g ?] p a ; exact (ap h (p a)).
Defined.

Global Instance is0functor_precomp_grouphomomorphism
       {A B C : Group} (h : A $-> B)
  : Is0Functor (@cat_precomp Group _ _ A B C h).
Proof.
  apply Build_Is0Functor.
  intros [f ?] [g ?] p a ; exact (p (h a)).
Defined.

(** Group forms a 1Cat *)
Global Instance is1cat_group : Is1Cat Group.
Proof.
  by rapply Build_Is1Cat.
Defined.

Global Instance hasmorext_group `{Funext} : HasMorExt Group.
Proof.
  srapply Build_HasMorExt.
  intros A B f g; cbn in *.
  snrapply @isequiv_homotopic.
  1: exact (equiv_path_grouphomomorphism^-1%equiv).
  1: exact _.
  intros []; reflexivity.
Defined.

Global Instance hasequivs_group
  : HasEquivs Group.
Proof.
  unshelve econstructor.
  + exact GroupIsomorphism.
  + exact (fun G H f => IsEquiv f).
  + intros G H f; exact f.
  + exact Build_GroupIsomorphism.
  + intros G H; exact grp_iso_inverse.
  + cbn; exact _.
  + reflexivity.
  + intros ????; apply eissect.
  + intros ????; apply eisretr.
  + intros G H f g p q.
    exact (isequiv_adjointify f g p q).
Defined.

Global Instance is1cat_strong `{Funext} : Is1Cat_Strong Group.
Proof.
  rapply Build_Is1Cat_Strong.
  all: intros; apply equiv_path_grouphomomorphism; intro; reflexivity.
Defined.

Global Instance is0functor_type_group : Is0Functor group_type.
Proof.
  apply Build_Is0Functor.
  rapply @grp_homo_map.
Defined.

Global Instance is0functor_ptype_group : Is0Functor ptype_group.
Proof.
  apply Build_Is0Functor.
  rapply @pmap_GroupHomomorphism.
Defined.

(** Given a group element [a0 : A] over [b : B], multiplication by [a] establishes an equivalence between the kernel and the fiber over [b]. *)
Lemma equiv_grp_hfiber {A B : Group} (f : GroupHomomorphism A B) (b : B)
  : forall (a0 : hfiber f b), hfiber f b <~> hfiber f mon_unit.
Proof.
  intros [a0 p].
  refine (equiv_transport (hfiber f) (right_inverse b) oE _).
  snrapply Build_Equiv.
  { srapply (functor_hfiber (h := fun t => t * -a0) (k := fun t => t * -b)).
    intro a; cbn; symmetry.
    refine (_ @ ap (fun x => f a * (- x)) p).
    exact (grp_homo_op f _ _ @ ap (fun x => f a * x) (grp_homo_inv f a0)). }
  srapply isequiv_functor_hfiber.
Defined.

(** ** The trivial group *)

Definition grp_trivial : Group.
Proof.
  refine (Build_Group Unit (fun _ _ => tt) tt (fun _ => tt) _).
  repeat split; try exact _; by intros [].
Defined.

(** Map out of trivial group *)
Definition grp_trivial_rec (G : Group) : GroupHomomorphism grp_trivial G.
Proof.
  snrapply Build_GroupHomomorphism.
  1: exact (fun _ => group_unit).
  intros ??; symmetry; apply grp_unit_l.
Defined.

(** Map into trivial group *)
Definition grp_trivial_corec (G : Group) : GroupHomomorphism G grp_trivial.
Proof.
  snrapply Build_GroupHomomorphism.
  1: exact (fun _ => tt).
  intros ??; symmetry; exact (grp_unit_l _).
Defined.

(** * Direct product of group *)

Definition grp_prod : Group -> Group -> Group.
Proof.
  intros G H.
  srapply (Build_Group (G * H)).
  (** Operation *)
  { intros [g1 h1] [g2 h2].
    exact (g1 * g2, h1 * h2). }
  (** Unit *)
  1: exact (mon_unit, mon_unit).
  (** Inverse *)
  { intros [g h].
    exact (-g, -h). }
  repeat split.
  1: exact _.
  all: grp_auto.
Defined.

Proposition grp_prod_corec {G H K : Group}
            (f : GroupHomomorphism K G)
            (g : GroupHomomorphism K H)
  : GroupHomomorphism K (grp_prod G H).
Proof.
  snrapply Build_GroupHomomorphism.
  - exact (fun x:K => (f x, g x)).
  - intros x y.
    refine (path_prod' _ _ ); try apply grp_homo_op.
Defined.

Definition grp_prod_inl {H K : Group}
  : GroupHomomorphism H (grp_prod H K)
  := grp_prod_corec grp_homo_id grp_homo_const.

Definition grp_prod_inr {H K : Group}
  : GroupHomomorphism K (grp_prod H K)
  := grp_prod_corec grp_homo_const grp_homo_id.

Definition grp_iso_prod {A B C D : Group}
  : A ≅ B -> C ≅ D -> (grp_prod A C) ≅ (grp_prod B D).
Proof.
  intros f g.
  srapply Build_GroupIsomorphism'.
  1: srapply (equiv_functor_prod (f:=f) (g:=g)).
  simpl.
  unfold functor_prod.
  intros x y.
  apply path_prod.
  1,2: apply grp_homo_op.
Defined.

Global Instance isembedding_grp_prod_inl {H K : Group}
  : IsEmbedding (@grp_prod_inl H K).
Proof.
  apply isembedding_isinj_hset.
  intros h0 h1 p; cbn in p.
  exact (fst ((equiv_path_prod _ _)^-1 p)).
Defined.

Global Instance isembedding_grp_prod_inr {H K : Group}
  : IsEmbedding (@grp_prod_inr H K).
Proof.
  apply isembedding_isinj_hset.
  intros k0 k1 q; cbn in q.
  exact (snd ((equiv_path_prod _ _)^-1 q)).
Defined.

Definition grp_prod_pr1 {G H : Group}
  : GroupHomomorphism (grp_prod G H) G.
Proof.
  snrapply Build_GroupHomomorphism.
  1: exact fst.
  intros ? ?; reflexivity.
Defined.

Definition grp_prod_pr2 {G H : Group}
  : GroupHomomorphism (grp_prod G H) H.
Proof.
  snrapply Build_GroupHomomorphism.
  1: exact snd.
  intros ? ?; reflexivity.
Defined.

Global Instance issurj_grp_prod_pr1 {G H : Group}
  : IsSurjection (@grp_prod_pr1 G H)
  := issurj_retr grp_prod_inl (fun _ => idpath).

Global Instance issurj_grp_prod_pr2 {G H : Group}
  : IsSurjection (@grp_prod_pr2 G H)
  := issurj_retr grp_prod_inr (fun _ => idpath).

(** *** Properties of maps to and from the trivial group *)

Global Instance isinitial_grp_trivial : IsInitial grp_trivial.
Proof.
  intro G.
  exists (grp_trivial_rec _).
  intros g [].
  apply (grp_homo_unit g)^.
Defined.

Global Instance contr_grp_homo_trivial_source `{Funext} G
  : Contr (GroupHomomorphism grp_trivial G).
Proof.
  snrapply Build_Contr.
  1: exact (grp_trivial_rec _).
  intros g.
  rapply equiv_path_grouphomomorphism.
  intros [].
  symmetry.
  rapply grp_homo_unit.
Defined.

Global Instance isterminal_grp_trivial : IsTerminal grp_trivial.
Proof.
  intro G.
  exists (grp_trivial_corec _).
  intros g x.
  apply path_contr.
Defined.

Global Instance contr_grp_homo_trivial_target `{Funext} G
  : Contr (GroupHomomorphism G grp_trivial).
Proof.
  snrapply Build_Contr.
  1: exact (pr1 (isterminal_grp_trivial _)).
  intros g.
  rapply equiv_path_grouphomomorphism.
  intros x.
  apply path_contr.
Defined.

Global Instance ishprop_grp_iso_trivial `{Univalence} (G : Group)
  : IsHProp (G ≅ grp_trivial).
Proof.
  apply equiv_hprop_allpath.
  intros f g.
  apply equiv_path_groupisomorphism; intro; apply path_ishprop.
Defined.

(** ** Free groups *)

Definition FactorsThroughFreeGroup (S : Type) (F_S : Group)
  (i : S -> F_S) (A : Group) (g : S -> A) : Type
  := {f : F_S $-> A & f o i == g}.

(** Universal property of a free group on a set (type). *)
Class IsFreeGroupOn (S : Type) (F_S : Group) (i : S -> F_S)
  := contr_isfreegroupon : forall (A : Group) (g : S -> A),
      Contr (FactorsThroughFreeGroup S F_S i A g).
Global Existing Instance contr_isfreegroupon.

(** A group is free if there exists a generating type on which it is a free group *)
Class IsFreeGroup (F_S : Group)
  := isfreegroup : {S : _ & {i : _ & IsFreeGroupOn S F_S i}}.

Global Instance isfreegroup_isfreegroupon (S : Type) (F_S : Group) (i : S -> F_S)
  {H : IsFreeGroupOn S F_S i}
  : IsFreeGroup F_S
  := (S; i; H).

(** Characterisation of injective group homomorphisms. *)
Lemma isembedding_grouphomomorphism {A B : Group} (f : A $-> B)
  : (forall a, f a = group_unit -> a = group_unit) <-> IsEmbedding f.
Proof.
  split.
  - intros h b.
    apply hprop_allpath.
    intros [a0 p0] [a1 p1].
    srapply path_sigma_hprop; simpl.
    apply grp_moveL_1M.
    apply h.
    rewrite grp_homo_op, grp_homo_inv.
    rewrite p0, p1.
    apply right_inverse.
  - intros E a p.
    rapply (isinj_embedding f).
    exact (p @ (grp_homo_unit f)^).
Defined.

(** Commutativity can be transferred across isomorphisms. *)
Definition commutative_iso_commutative {G H : Group}
  {C : Commutative (@group_sgop G)} (f : GroupIsomorphism G H)
  : Commutative (@group_sgop H).
Proof.
  unfold Commutative.
  rapply (equiv_ind f); intro g1.
  rapply (equiv_ind f); intro g2.
  refine ((preserves_sg_op _ _)^ @ _ @ (preserves_sg_op _ _)).
  refine (ap f _).
  apply C.
Defined.


Add LoadPath "D:\sfsol".
Require Export Hoare.

Inductive hoare_proof : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      hoare_proof P (SKIP) P
  | H_Asgn : forall Q V a,
      hoare_proof (assn_sub V a Q) (V ::= a) Q
  | H_Seq : forall P c Q d R,
      hoare_proof P c Q -> hoare_proof Q d R -> hoare_proof P (c;;d) R
  | H_If : forall P Q b c1 c2,
    hoare_proof (fun st => P st /\ bassn b st) c1 Q ->
    hoare_proof (fun st => P st /\ ~(bassn b st)) c2 Q ->
    hoare_proof P (IFB b THEN c1 ELSE c2 FI) Q
  | H_While : forall P b c,
    hoare_proof (fun st => P st /\ bassn b st) c P ->
    hoare_proof P (WHILE b DO c END) (fun st => P st /\ ~ (bassn b st))
  | H_Consequence : forall (P Q P' Q' : Assertion) c,
    hoare_proof P' c Q' ->
    (forall st, P st -> P' st) ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.

Tactic Notation "hoare_proof_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "H_Skip" | Case_aux c "H_Asgn" | Case_aux c "H_Seq"
  | Case_aux c "H_If" | Case_aux c "H_While" | Case_aux c "H_Consequence" ].

Lemma H_Consequence_pre : forall (P Q P': Assertion) c,
    hoare_proof P' c Q ->
    (forall st, P st -> P' st) ->
    hoare_proof P c Q.
Proof.
  intros.
  eapply H_Consequence.
  apply X. assumption. auto.
  Qed.

Lemma H_Consequence_post : forall (P Q Q': Assertion) c,
    hoare_proof P c Q' ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.
Proof.
  intros.
  eapply H_Consequence.
  apply X. auto. assumption.
  Qed.

Example sample_proof
             : hoare_proof
                 (assn_sub X (APlus (AId X) (ANum 1))
                   (assn_sub X (APlus (AId X) (ANum 2))
                     (fun st => st X = 3) ))
                 (X ::= APlus (AId X) (ANum 1);; (X ::= APlus (AId X) (ANum 2)))
                 (fun st => st X = 3).
Proof.
  eapply H_Seq; apply H_Asgn.
Qed.

Theorem hoare_proof_sound : forall P c Q,
  hoare_proof P c Q -> {{P}} c {{Q}}.
Proof.
  intros. induction X.
  apply hoare_skip.
  apply hoare_asgn.
  apply hoare_seq with Q; assumption.
  apply hoare_if; assumption.
  apply hoare_while; assumption.
  eapply hoare_consequence; try apply IHX; try assumption.
  Qed.

Theorem H_Post_True_deriv:
  forall c P, hoare_proof P c (fun _ => True).
Proof.
  intro c.
  com_cases (induction c) Case; intro P.
  Case "SKIP".
    eapply H_Consequence.
    apply H_Skip.
    intros. apply H.
    (* Proof of True *)
    intros. apply I.
  Case "::=".
    eapply H_Consequence_pre.
    apply H_Asgn.
    intros. apply I.
  Case ";;".
    eapply H_Consequence_pre.
    eapply H_Seq.
    apply (IHc1 (fun _ => True)).
    apply IHc2.
    intros. apply I.
  Case "IFB".
    apply H_Consequence_pre with (fun _ => True).
    apply H_If.
    apply IHc1.
    apply IHc2.
    intros. apply I.
  Case "WHILE".
    eapply H_Consequence.
    eapply H_While.
    eapply IHc.
    intros; apply I.
    intros; apply I.
Qed.

Lemma False_and_P_imp: forall P Q,
  False /\ P -> Q.
Proof.
  intros P Q [CONTRA HP].
  destruct CONTRA.
Qed.

Tactic Notation "pre_false_helper" constr(CONSTR) :=
  eapply H_Consequence_pre;
    [eapply CONSTR | intros ? CONTRA; destruct CONTRA].

Theorem H_Pre_False_deriv:
  forall c Q, hoare_proof (fun _ => False) c Q.
Proof.
  intros c.
  com_cases (induction c) Case; intro Q.
  Case "SKIP". pre_false_helper H_Skip.
  Case "::=". pre_false_helper H_Asgn.
  Case ";;". pre_false_helper H_Seq. apply IHc1. apply IHc2.
  Case "IFB".
    apply H_If; eapply H_Consequence_pre.
    apply IHc1. intro. eapply False_and_P_imp.
    apply IHc2. intro. eapply False_and_P_imp.
  Case "WHILE".
    eapply H_Consequence_post.
    eapply H_While.
    eapply H_Consequence_pre.
      apply IHc.
      intro. eapply False_and_P_imp.
    intro. simpl. eapply False_and_P_imp.
Qed.

Definition wp (c:com) (Q:Assertion) : Assertion :=
  fun s => forall s', c / s || s' -> Q s'.

Lemma wp_is_precondition: forall c Q,
  {{wp c Q}} c {{Q}}.
Proof.
  intros c Q st st' H1 H2.
  apply H2. assumption.
  Qed.

Lemma wp_is_weakest: forall c Q P',
   {{P'}} c {{Q}} -> forall st, P' st -> wp c Q st.
Proof.
  intros c Q P' H st H2. unfold wp. intros s' Hypo.
  eapply H. apply Hypo. assumption. Qed.

Lemma bassn_eval_false : forall b st, ~ bassn b st -> beval st b = false.
Proof.
  intros b st H. unfold bassn in H. destruct (beval st b).
    exfalso. apply H. reflexivity.
    reflexivity.
Qed.

Theorem hoare_proof_complete: forall P c Q,
  {{P}} c {{Q}} -> hoare_proof P c Q.
Proof.
  intros P c. generalize dependent P.
  com_cases (induction c) Case; intros P Q HT.
  Case "SKIP".
    eapply H_Consequence.
     eapply H_Skip.
      intros. eassumption.
      intro st. apply HT. apply E_Skip.
  Case "::=".
    eapply H_Consequence.
      eapply H_Asgn.
      intro st. apply HT. econstructor. reflexivity.
      intros; assumption.
  Case ";;".
    apply H_Seq with (wp c2 Q).
     eapply IHc1.
       intros st st' E1 H. unfold wp. intros st'' E2.
         eapply HT. econstructor; eassumption. assumption.
     eapply IHc2. intros st st' E1 H. apply H; assumption.
  Case "IFB".
    apply H_If. apply IHc1.
      intros st st' H [H1 H2].
      eapply HT. constructor; try apply H2; assumption. assumption.
      apply IHc2. intros st st' H [H1 H2].
      eapply HT. apply E_IfFalse; try apply bassn_eval_false; try apply H2; assumption. assumption.
  Case "WHILE".
    eapply H_Consequence with (P' := wp (WHILE b DO c END) Q).
      apply H_While.
      apply IHc. intros st st' H [H2 H3] st'' H4.
      assert((WHILE b DO c END) / st || st'').
        eapply E_WhileLoop. apply H3. apply H. apply H4.
      eapply wp_is_precondition. apply H0. assumption.
      apply wp_is_weakest. assumption.
      intros st [H1 H2]. eapply wp_is_precondition.
      assert((WHILE b DO c END) / st || st).
        apply E_WhileEnd. apply bassn_eval_false. assumption.
      apply H. assumption.
  Qed.


Require Export D.

(** Hint: You may need to first state and prove some lemma about snoc and rev. *)
Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros. induction l. reflexivity.
  Lemma rev_snoc_lemma : forall n:nat, forall l:natlist,
    rev (n :: l) = snoc (rev l) n.
  Proof. intros. reflexivity. Qed.
  rewrite -> rev_snoc_lemma. simpl.
  Lemma rev_snoc_lemma2 : forall n:nat, forall l:natlist,
    rev (snoc l n) = n :: rev l.
  Proof. intros. induction l. reflexivity.
  simpl. rewrite -> IHl. simpl. reflexivity. Qed.
  rewrite -> rev_snoc_lemma2. rewrite -> IHl. reflexivity.

Qed.


From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Inductive numeral:  nat -> Type :=
  | Z: forall n, numeral n.+1
  | U: forall n, numeral n -> numeral n.+1.

Print numeral_ind.

Definition numeral_ind2
  (P : forall n : nat, numeral n -> Prop)
  (fz : forall n : nat, P n.+1 (Z n))
  (fu : forall (n : nat) (n' : numeral n), P n n' -> P n.+1 (U n'))
  :=
    fix F (n: nat) (n': numeral n) {struct n'} : P n n' :=
      match n' as n2 in (numeral n1) return (P n1 n2) with
      | Z n1 => fz n1
      | @U n1 n2 => fu n1 n2 (F n1 n2)
      end.

Definition P: forall n, numeral n.+1 -> option (numeral n) :=
  fun n num =>
    match num with
    | Z n' => None
    | U _ n' => Some n'
    end.

Print Empty_set.
Print void.
Definition P': forall n, numeral n -> match n with
                                      | 0 => void
                                      | S n' => option (numeral n')
                                      end :=
  fun _ num =>
    match num with
    | Z n' => None
    | U _ n' => Some n'
    end.

Definition P2: forall n, numeral n.+1 -> option (numeral n) :=
  fun n num => @P' n.+1 num.

Definition P'': forall n, numeral n.+2 -> numeral n.+1 :=
  fun n num =>
    match @P' n.+2 num with
    | Some a => a
    | None => Z n
    end.

(* 21.2.1 *)
Lemma constr_disj: forall n (a: numeral n), @Z n <> @U n a.
Proof.
  by move => n a H.
Qed.
Print constr_disj.

(* 21.2.2 *)
Lemma num0: numeral 0 -> void.
Proof.
  by apply P'.
Qed.

(* 21.2.3 *)
Definition num_listing: forall (n: nat), seq (numeral n) :=
  fix F n :=
    match n with
    | 0 => [::]
    | n'.+1 => [:: Z n' & map (@U n') (F n')]
    end.

Compute num_listing 6.

(* 21.3 Inversion *)
Definition num_inv: forall {n} (a: numeral n),
  match n return numeral n -> Type with
  | 0 => fun _ => void
  | S n' => fun a => sum (a = Z n') { a' & a = U a' }
  end a.
Proof.
  move => n.
  case => [a | n' a].
  - by left.
  right.
  by exists a.
Defined.
(* ^ see chipala convoy pattern *)

Eval cbn in fun n => num_inv (Z n).
Eval cbn in fun n (a: numeral n) => num_inv (U a).

Theorem inversion: forall n (a: numeral n.+1),
  { a' & a = @U n a' } + { a = Z n }.
Proof.
  move => n a.
  case (@num_inv n.+1 a).
  - by right.
  by left.
Defined.

(* 21.3.1 *)

Lemma U_inj: forall n a b, @U n a = @U n b -> a = b.
Proof.
  move => n a b H.
  move: ((@f_equal _ _ (@P n) (@U n a) (@U n b)) H).
  rewrite /P.
  by case.
Qed.

Definition dec (X: Type) := sum X (X -> False).
Lemma numeral_decidable:
  forall n (a b: numeral n), dec (a = b).
Proof.
  move => n.
  elim => [n' b | n' b IH b'].
  - case (@inversion n' b).
      move => [a' Hb].
      right.
      by rewrite Hb.
    move => ->.
    by left.
  case (@inversion n' b').
    move => [a' ->].
    case (IH a').
      move => ->.
      by left.
    move => contra.
    right => H.
    apply contra.
    by apply (U_inj H).
  move => ->.
  by right.
Qed.

(* 21.3.2 *)
(* TODO *)

(* 21.3.3 *)
(* TODO *)

(* 21.4 Embedding numerals to numbers *)
Definition to_nat: forall n, numeral n -> nat :=
  fix F n m :=
    match m with
    | Z _ => 0
    | U n' m' => S (F n' m')
    end.

Compute (to_nat (U (U (Z 3)))).

Lemma numeral_upper: forall n (a: numeral n), to_nat a < n.
Proof.
  move => n.
  elim => [n' //| n' a' IH].
  by rewrite /to_nat -/to_nat -addn1 -[n'.+1]addn1 ltn_add2r.
Qed.

Lemma to_nat_inj: forall n,
  injective (@to_nat n).
Proof.
  move => n.
  elim => [n' b // | n' a IH b].
    move: (inversion b) => [[b' -> Contra] | -> //].
    exfalso. move: Contra.
    by rewrite /to_nat -/to_nat.
  move: (inversion b) => [[b' ->] | -> //].
  rewrite /to_nat -/to_nat.
  by move /succn_inj /IH ->.
Qed.

Fixpoint from_nat k n : numeral n.+1 :=
  match k, n with
  | 0, m => Z m
  | (S k), 0 => Z 0
  | (S k), (S m) => U (from_nat k m)
  end.

Lemma from_nat_step: forall n m,
  from_nat m.+1 n.+1 = U (from_nat m n).
Proof.
  by [].
Qed.

Lemma form_to: forall n (a: numeral n.+1), from_nat (to_nat a) n = a.
Proof.
  move => n a.
  move: (inversion a) => [[a' ->] | -> //].
  elim a' => [n'| n' a''].
    by rewrite /to_nat -/to_nat /from_nat.
  by rewrite /to_nat -/to_nat from_nat_step => ->.
Qed.

Lemma to_from: forall k n, k <= n -> @to_nat n.+1 (from_nat k n) = k.
Proof.
  elim => [n Hl // | n IH k' Hl].
  rewrite /from_nat -/from_nat.
  case E: k'.
    exfalso. move: E Hl => ->.
    by rewrite ltn0.
  move: E Hl => ->.
  rewrite ltnS => Hl.
  move: (IH _ Hl).
  by rewrite {2}/to_nat -/to_nat => ->.
Qed.

(* 21.4.1 *)
Definition lift_numeral: forall n (a: numeral n), numeral n.+1 :=
  fix F n a :=
    match a with
    | Z n' => Z n'.+1
    | @U m k => @U m.+1 (F m k)
    end.

Lemma lift_numeral_inj: forall n,
  injective (@lift_numeral n).
Proof.
  move => n.
  elim => [n' b // |n' a IH b ].
    move: (inversion b) => [[a' ->] | -> //].
    rewrite /lift_numeral -/lift_numeral.
    move => contra. exfalso.
    by [].
  move: (inversion b) => [[a' ->] | -> //].
  by rewrite /lift_numeral -/lift_numeral => /U_inj /IH ->.
Qed.

(* 21.5 Recursive numeral types *)
Fixpoint finT (n: nat): Type :=
  match n with
  | 0 => void
  | n'.+1 => option (finT n')
  end.

(* 21.5.1 *)
Definition num_fin: forall n (a: numeral n), finT n :=
  fix F n a :=
    match a with
    | Z _ => None
    | U n' a => Some (F n' a)
    end.

Fixpoint fin_num {n} (a: finT n): numeral n :=
  match n, a with
  | 0, c => match c with end
  | S n', None => Z n'
  | S n', Some a' => U (fin_num a')
  end.

(* 21.5.2 *)
Lemma finT0: finT 0 -> False.
Proof.
  by case.
Qed.

Lemma finT_inversion: forall n (a: finT n.+1),
  sum (a = None) { a' & a = Some a' }.
Proof.
  move => n.
  elim.
Admitted. (*Defined.*)

(* TODO: custom eliminator *)


From Hammer Require Import Hammer.

Require Import NZAxioms.
Require Import NZAddOrder.

Module Type NZMulOrderProp (Import NZ : NZOrdAxiomsSig').
Include NZAddOrderProp NZ.

Theorem mul_lt_pred :
forall p q n m, S p == q -> (p * n < p * m <-> q * n + m < q * m + n).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_lt_pred".
intros p q n m H. rewrite <- H. nzsimpl.
rewrite <- ! add_assoc, (add_comm n m).
now rewrite <- add_lt_mono_r.
Qed.

Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_lt_mono_pos_l".
intros p n m Hp. revert n m. apply lt_ind with (4:=Hp). solve_proper.
intros. now nzsimpl.
clear p Hp. intros p Hp IH n m. nzsimpl.
assert (LR : forall n m, n < m -> p * n + n < p * m + m)
by (intros n1 m1 H; apply add_lt_mono; trivial; now rewrite <- IH).
split; intros H.
now apply LR.
destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial.
rewrite EQ in H. order.
apply LR in GT. order.
Qed.

Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_lt_mono_pos_r".
intros p n m.
rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_pos_l.
Qed.

Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_lt_mono_neg_l".
nzord_induct p.
order.
intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order.
intros p Hp IH n m _. apply le_succ_l in Hp.
le_elim Hp.
assert (LR : forall n m, n < m -> p * m < p * n).
intros n1 m1 H. apply (le_lt_add_lt n1 m1).
now apply lt_le_incl. rewrite <- 2 mul_succ_l. now rewrite <- IH.
split; intros H.
now apply LR.
destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial.
rewrite EQ in H. order.
apply LR in GT. order.
rewrite (mul_lt_pred p (S p)), Hp; now nzsimpl.
Qed.

Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_lt_mono_neg_r".
intros p n m.
rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_neg_l.
Qed.

Theorem mul_le_mono_nonneg_l : forall n m p, 0 <= p -> n <= m -> p * n <= p * m.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_le_mono_nonneg_l".
intros n m p H1 H2. le_elim H1.
le_elim H2. apply lt_le_incl. now apply mul_lt_mono_pos_l.
apply eq_le_incl; now rewrite H2.
apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l.
Qed.

Theorem mul_le_mono_nonpos_l : forall n m p, p <= 0 -> n <= m -> p * m <= p * n.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_le_mono_nonpos_l".
intros n m p H1 H2. le_elim H1.
le_elim H2. apply lt_le_incl. now apply mul_lt_mono_neg_l.
apply eq_le_incl; now rewrite H2.
apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l.
Qed.

Theorem mul_le_mono_nonneg_r : forall n m p, 0 <= p -> n <= m -> n * p <= m * p.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_le_mono_nonneg_r".
intros n m p H1 H2;
rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonneg_l.
Qed.

Theorem mul_le_mono_nonpos_r : forall n m p, p <= 0 -> n <= m -> m * p <= n * p.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_le_mono_nonpos_r".
intros n m p H1 H2;
rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonpos_l.
Qed.

Theorem mul_cancel_l : forall n m p, p ~= 0 -> (p * n == p * m <-> n == m).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_cancel_l".
intros n m p Hp; split; intro H; [|now f_equiv].
apply lt_gt_cases in Hp; destruct Hp as [Hp|Hp];
destruct (lt_trichotomy n m) as [LT|[EQ|GT]]; trivial.
apply (mul_lt_mono_neg_l p) in LT; order.
apply (mul_lt_mono_neg_l p) in GT; order.
apply (mul_lt_mono_pos_l p) in LT; order.
apply (mul_lt_mono_pos_l p) in GT; order.
Qed.

Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_cancel_r".
intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_cancel_l.
Qed.

Theorem mul_id_l : forall n m, m ~= 0 -> (n * m == m <-> n == 1).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_id_l".
intros n m H.
stepl (n * m == 1 * m) by now rewrite mul_1_l. now apply mul_cancel_r.
Qed.

Theorem mul_id_r : forall n m, n ~= 0 -> (n * m == n <-> m == 1).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_id_r".
intros n m; rewrite mul_comm; apply mul_id_l.
Qed.

Theorem mul_le_mono_pos_l : forall n m p, 0 < p -> (n <= m <-> p * n <= p * m).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_le_mono_pos_l".
intros n m p H; do 2 rewrite lt_eq_cases.
rewrite (mul_lt_mono_pos_l p n m) by assumption.
now rewrite -> (mul_cancel_l n m p) by
(intro H1; rewrite H1 in H; false_hyp H lt_irrefl).
Qed.

Theorem mul_le_mono_pos_r : forall n m p, 0 < p -> (n <= m <-> n * p <= m * p).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_le_mono_pos_r".
intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_pos_l.
Qed.

Theorem mul_le_mono_neg_l : forall n m p, p < 0 -> (n <= m <-> p * m <= p * n).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_le_mono_neg_l".
intros n m p H; do 2 rewrite lt_eq_cases.
rewrite (mul_lt_mono_neg_l p n m); [| assumption].
rewrite -> (mul_cancel_l m n p)
by (intro H1; rewrite H1 in H; false_hyp H lt_irrefl).
now setoid_replace (n == m) with (m == n) by (split; now intro).
Qed.

Theorem mul_le_mono_neg_r : forall n m p, p < 0 -> (n <= m <-> m * p <= n * p).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_le_mono_neg_r".
intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_neg_l.
Qed.

Theorem mul_lt_mono_nonneg :
forall n m p q, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_lt_mono_nonneg".
intros n m p q H1 H2 H3 H4.
apply le_lt_trans with (m * p).
apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl].
apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n].
Qed.

Theorem mul_le_mono_nonneg :
forall n m p q, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_le_mono_nonneg".
intros n m p q H1 H2 H3 H4.
le_elim H2; le_elim H4.
apply lt_le_incl; now apply mul_lt_mono_nonneg.
rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl].
rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl].
rewrite H2; rewrite H4; now apply eq_le_incl.
Qed.

Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_pos_pos".
intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_pos_r.
Qed.

Theorem mul_neg_neg : forall n m, n < 0 -> m < 0 -> 0 < n * m.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_neg_neg".
intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r.
Qed.

Theorem mul_pos_neg : forall n m, 0 < n -> m < 0 -> n * m < 0.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_pos_neg".
intros n m H1 H2. rewrite <- (mul_0_l m). now apply mul_lt_mono_neg_r.
Qed.

Theorem mul_neg_pos : forall n m, n < 0 -> 0 < m -> n * m < 0.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_neg_pos".
intros; rewrite mul_comm; now apply mul_pos_neg.
Qed.

Theorem mul_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n*m.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_nonneg_nonneg".
intros. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order.
Qed.

Theorem mul_pos_cancel_l : forall n m, 0 < n -> (0 < n*m <-> 0 < m).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_pos_cancel_l".
intros n m Hn. rewrite <- (mul_0_r n) at 1.
symmetry. now apply mul_lt_mono_pos_l.
Qed.

Theorem mul_pos_cancel_r : forall n m, 0 < m -> (0 < n*m <-> 0 < n).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_pos_cancel_r".
intros n m Hn. rewrite <- (mul_0_l m) at 1.
symmetry. now apply mul_lt_mono_pos_r.
Qed.

Theorem mul_nonneg_cancel_l : forall n m, 0 < n -> (0 <= n*m <-> 0 <= m).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_nonneg_cancel_l".
intros n m Hn. rewrite <- (mul_0_r n) at 1.
symmetry. now apply mul_le_mono_pos_l.
Qed.

Theorem mul_nonneg_cancel_r : forall n m, 0 < m -> (0 <= n*m <-> 0 <= n).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_nonneg_cancel_r".
intros n m Hn. rewrite <- (mul_0_l m) at 1.
symmetry. now apply mul_le_mono_pos_r.
Qed.

Theorem lt_1_mul_pos : forall n m, 1 < n -> 0 < m -> 1 < n * m.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.lt_1_mul_pos".
intros n m H1 H2. apply (mul_lt_mono_pos_r m) in H1.
rewrite mul_1_l in H1. now apply lt_1_l with m.
assumption.
Qed.

Theorem eq_mul_0 : forall n m, n * m == 0 <-> n == 0 \/ m == 0.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.eq_mul_0".
intros n m; split.
intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]];
destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]];
try (now right); try (now left).
exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |].
exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |].
exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |].
exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |].
intros [H | H]. now rewrite H, mul_0_l. now rewrite H, mul_0_r.
Qed.

Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.neq_mul_0".
intros n m; split; intro H.
intro H1; apply eq_mul_0 in H1. tauto.
split; intro H1; rewrite H1 in H;
(rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H.
Qed.

Theorem eq_square_0 : forall n, n * n == 0 <-> n == 0.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.eq_square_0".
intro n; rewrite eq_mul_0; tauto.
Qed.

Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.eq_mul_0_l".
intros n m H1 H2. apply eq_mul_0 in H1. destruct H1 as [H1 | H1].
assumption. false_hyp H1 H2.
Qed.

Theorem eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.eq_mul_0_r".
intros n m H1 H2; apply eq_mul_0 in H1. destruct H1 as [H1 | H1].
false_hyp H1 H2. assumption.
Qed.

Definition mul_eq_0 := eq_mul_0.
Definition mul_eq_0_l := eq_mul_0_l.
Definition mul_eq_0_r := eq_mul_0_r.

Theorem lt_0_mul n m : 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.lt_0_mul".
split; [intro H | intros [[H1 H2] | [H1 H2]]].
destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]];
[| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |];
(destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]];
[| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]);
try (left; now split); try (right; now split).
assert (H3 : n * m < 0) by now apply mul_neg_pos.
exfalso; now apply (lt_asymm (n * m) 0).
assert (H3 : n * m < 0) by now apply mul_pos_neg.
exfalso; now apply (lt_asymm (n * m) 0).
now apply mul_pos_pos. now apply mul_neg_neg.
Qed.

Theorem square_lt_mono_nonneg : forall n m, 0 <= n -> n < m -> n * n < m * m.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.square_lt_mono_nonneg".
intros n m H1 H2. now apply mul_lt_mono_nonneg.
Qed.

Theorem square_le_mono_nonneg : forall n m, 0 <= n -> n <= m -> n * n <= m * m.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.square_le_mono_nonneg".
intros n m H1 H2. now apply mul_le_mono_nonneg.
Qed.

Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.square_lt_simpl_nonneg".
intros n m H1 H2. destruct (lt_ge_cases n 0).
now apply lt_le_trans with 0.
destruct (lt_ge_cases n m) as [LT|LE]; trivial.
apply square_le_mono_nonneg in LE; order.
Qed.

Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.square_le_simpl_nonneg".
intros n m H1 H2. destruct (lt_ge_cases n 0).
apply lt_le_incl; now apply lt_le_trans with 0.
destruct (le_gt_cases n m) as [LE|LT]; trivial.
apply square_lt_mono_nonneg in LT; order.
Qed.

Theorem mul_2_mono_l : forall n m, n < m -> 1 + 2 * n < 2 * m.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.mul_2_mono_l".
intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m two).
rewrite two_succ. nzsimpl. now rewrite le_succ_l.
order'.
Qed.

Lemma add_le_mul : forall a b, 1<a -> 1<b -> a+b <= a*b.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.add_le_mul".
assert (AUX : forall a b, 0<a -> 0<b -> (S a)+(S b) <= (S a)*(S b)).
intros a b Ha Hb.
nzsimpl. rewrite <- succ_le_mono. apply le_succ_l.
rewrite <- add_assoc, <- (add_0_l (a+b)), (add_comm b).
apply add_lt_mono_r.
now apply mul_pos_pos.
intros a b Ha Hb.
assert (Ha' := lt_succ_pred 1 a Ha).
assert (Hb' := lt_succ_pred 1 b Hb).
rewrite <- Ha', <- Hb'. apply AUX; rewrite succ_lt_mono, <- one_succ; order.
Qed.

Lemma square_nonneg : forall a, 0 <= a * a.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.square_nonneg".
intros. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0).
now apply mul_le_mono_nonpos_l.
apply mul_le_mono_nonneg_l; order.
Qed.

Lemma crossmul_le_addsquare : forall a b, 0<=a -> 0<=b -> b*a+a*b <= a*a+b*b.
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.crossmul_le_addsquare".
assert (AUX : forall a b, 0<=a<=b -> b*a+a*b <= a*a+b*b).
intros a b (Ha,H).
destruct (le_exists_sub _ _ H) as (d & EQ & Hd).
rewrite EQ.
rewrite 2 mul_add_distr_r.
rewrite !add_assoc. apply add_le_mono_r.
rewrite add_comm. apply add_le_mono_l.
apply mul_le_mono_nonneg_l; trivial. order.
intros a b Ha Hb.
destruct (le_gt_cases a b).
apply AUX; split; order.
rewrite (add_comm (b*a)), (add_comm (a*a)).
apply AUX; split; order.
Qed.

Lemma add_square_le : forall a b, 0<=a -> 0<=b ->
a*a + b*b <= (a+b)*(a+b).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.add_square_le".
intros a b Ha Hb.
rewrite mul_add_distr_r, !mul_add_distr_l.
rewrite add_assoc.
apply add_le_mono_r.
rewrite <- add_assoc.
rewrite <- (add_0_r (a*a)) at 1.
apply add_le_mono_l.
apply add_nonneg_nonneg; now apply mul_nonneg_nonneg.
Qed.

Lemma square_add_le : forall a b, 0<=a -> 0<=b ->
(a+b)*(a+b) <= 2*(a*a + b*b).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.square_add_le".
intros a b Ha Hb.
rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'.
rewrite <- !add_assoc. apply add_le_mono_l.
rewrite !add_assoc. apply add_le_mono_r.
apply crossmul_le_addsquare; order.
Qed.

Lemma quadmul_le_squareadd : forall a b, 0<=a -> 0<=b ->
2*2*a*b <= (a+b)*(a+b).
Proof. hammer_hook "NZMulOrder" "NZMulOrder.NZMulOrderProp.quadmul_le_squareadd".
intros.
nzsimpl'.
rewrite !mul_add_distr_l, !mul_add_distr_r.
rewrite (add_comm _ (b*b)), add_assoc.
apply add_le_mono_r.
rewrite (add_shuffle0 (a*a)), (mul_comm b a).
apply add_le_mono_r.
rewrite (mul_comm a b) at 1.
now apply crossmul_le_addsquare.
Qed.

End NZMulOrderProp.


Require Import Coqlibext.
Require Import Do_notation.
Require Import ClassesAndNotations.
Require Import Psatz.
Require Import Program.

Set Implicit Arguments.

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

(* Definition of what a vector is and what multiplication on vectors
   mean *)

Local Hint Unfold decidable: pb.
Local Ltac un := autounfold with pb in *.

Section WITHDIM.
Variable n: nat.
Definition vector := {l:list Z| length l = n}.
Implicit Type v: vector.
Implicit Type va: list Z.
Implicit Type x y z: Z.

Fixpoint prod_vect_aux (va1 va2:list Z) : Z :=
  match va1, va2 with
    | nil, _
    | _, nil => 0
    | x1 :: va1', x2 :: va2' =>
      (x1 * x2) + (prod_vect_aux va1' va2')
  end.

Ltac dest_vect v :=
  let av := fresh "a" v in
  let avLENGTH := fresh av "LENGTH" in
  destruct v as [av avLENGTH].

Ltac dest_vects :=
  repeat
  match goal with
    | v : vector |- _ =>
      dest_vect v
  end; simpl.

Program Definition prod_vect v1 v2 : Z :=
  prod_vect_aux v1 v2.

Notation "v1 <*> v2" := (prod_vect v1 v2) (at level 69).

Inductive cmp := EQ | GE.

Record constraint := mkConstraint
  { vect: vector;
    comp: cmp;
    val: Z}.

Definition satisfy_cmp z1 comp z2 :=
  match comp with
    | EQ => z1 = z2
    | GE => z1 >= z2
  end.

Local Hint Unfold satisfy_cmp: pb.

Lemma satisfy_cmp_dec: forall z1 comp z2, decidable (satisfy_cmp z1 comp z2).
Proof.
  intros z1 comp0 z2.
  un.
  destruct comp0. apply zeq. apply Z_ge_dec.
Qed.

Definition satisfy_constr v (constr: constraint) :=
  satisfy_cmp (constr.(vect) <*> v) constr.(comp) constr.(val).

Local Hint Unfold satisfy_constr: pb.

Lemma satisfy_constr_dec: forall v constr, decidable (satisfy_constr v constr).
Proof.
  intros v constr. un.
  apply satisfy_cmp_dec.
Qed.

Fixpoint repeat {A:Type} (m: nat) (a:A) :=
  match m with
    | O => nil
    | S m' => a :: (repeat m' a)
  end.

Lemma repeat_length: forall A m (a:A),
  length (repeat m a) = m.
Proof.
  induction m; simpl; intros; auto.
Qed.

Program Definition repeat_v z : vector:=
  repeat n z.
Next Obligation. apply repeat_length. Qed.

Definition empty_constr:= mkConstraint (repeat_v 0) GE 1.
Local Hint Unfold empty_constr: pb.
Program Lemma empty_constr_empty : forall v,
  ~satisfy_constr v empty_constr.
Proof.
  intros v.
  un. simpl.

  assert (forall m av, prod_vect_aux (repeat m 0) av = 0).
  induction m; destruct av; simpl; intros; auto.
  assert (repeat_v 0 <*> v = 0).
  dest_vect v. unfold prod_vect. simpl. auto.
  rewrite H0. auto.
Qed.

Definition polyhedron := list constraint.

Hint Unfold polyhedron: aliases.

Definition In_pol v (pol: polyhedron) :=
  list_forall (satisfy_constr v) pol.

Definition empty pol := forall v, ~In_pol v pol.

Program Definition opp_vect v : vector:= List.map Zopp v.
Next Obligation.
  dest_vect v. simpl. rewrite map_length. auto.
Qed.

Local Hint Unfold opp_vect: pb.

Notation "<~> v" := (opp_vect v) (at level 42).

Lemma opp_vect_correct1:
  forall v1 v2,  (<~> v1) <*> v2 = - (v1 <*> v2).
Proof.
  unfold opp_vect, prod_vect. intros. dest_vects. simpl.
  clear av1LENGTH av2LENGTH.
  revert av2.
  induction av1; destruct av2; simpl; intros; auto.
  rewrite IHav1. lia.
Qed.

Lemma opp_vect_correct2:
  forall v1 v2,  v1 <*> (<~> v2) = - (v1 <*> v2).
Proof.
  unfold opp_vect, prod_vect. intros. dest_vects.
  clear av1LENGTH av2LENGTH.
  revert av1.
  induction av2; destruct av1; simpl; intros; auto.
  rewrite IHav2. lia.
Qed.

(* canonize_pol removes all equalities *)
Fixpoint canonize_pol pol :=
  match pol with
    | nil => nil
    | constr :: pol' =>
      match constr.(comp) with
        | EQ =>
          (mkConstraint (<~> constr.(vect)) GE (Zopp constr.(val)))::
          (mkConstraint  constr.(vect) GE constr.(val))::
          canonize_pol pol'
        | GE => constr :: canonize_pol pol'
      end
  end.

Local Hint Unfold In_pol: pb.
Lemma canonize_pol_corr1: forall v pol, In_pol v pol ->
  In_pol v (canonize_pol pol).
Proof.
  un.
  induction pol; simpl; intro LF.
  constructor.
  inversion LF as [|? ? SATIS LF']. subst. clear LF.
  destruct a. simpl. destruct comp0; [|constructor; auto].

  unfold satisfy_constr in SATIS. simpl in *.

  unfold satisfy_constr.
  repeat (constructor; simpl); auto.
  rewrite opp_vect_correct1. lia.
  lia.
Qed.

Lemma canonize_pol_corr2: forall v pol,
  In_pol v (canonize_pol pol) -> In_pol v pol.
Proof.
  un.
  induction pol; simpl; intro LF.
  constructor.
  destruct a. simpl in *. destruct comp0; auto.
  inv LF. inv H2.
  constructor; eauto. clear H4 IHpol.
  unfold satisfy_constr in *; simpl in *.
  rewrite opp_vect_correct1 in H1. lia.
  inv LF. constructor; eauto.
Qed.

Program Definition mult_vect z v : vector:=
  map (fun z' => z * z') v.
Next Obligation.
  dest_vect v.
  simpl. rewrite map_length. auto.
Qed.

Notation "z *> v" := (mult_vect z v) (at level 42).
Local Hint Unfold mult_vect prod_vect: pb.
Lemma mult_vect_correct1: forall z v1 v2,
 (z *> v1) <*> v2 = (z * (v1 <*> v2)).
Proof.
  un.
  intros z v1 v2. dest_vects.
  clear. revert av2.
  induction av1; destruct av2; intros; simpl in *; auto; try lia.
  rewrite IHav1. lia.
Qed.

Definition mult_constraint z c :=
  mkConstraint
    ((Zabs z) *> c.(vect))
    c.(comp)
    ((Zabs z) * c.(val)).

Local Hint Unfold mult_constraint: pb.

Lemma mult_constraint_correct: forall v z c,
  satisfy_constr v c -> satisfy_constr v (mult_constraint z c).
Proof.
  unfold satisfy_constr, mult_constraint.
  intros v z c H. simpl.
  remember (Zabs z) as z'.
  assert (0 <= z'). rewrite Heqz'. apply Zabs_pos.
  destruct c.
  destruct comp0; simpl in *; auto.
  subst. rewrite mult_vect_correct1. reflexivity.
  rewrite mult_vect_correct1.

  apply Zmult_ge_compat_l; auto. lia.
Qed.

Fixpoint add_vect_aux av1 av2 :=
  match av1, av2 with
    | nil, _
    | _, nil => nil
    | z1::av1', z2::av2' =>
      (z1 + z2) :: add_vect_aux av1' av2'
  end.
Program Definition add_vect v1 v2 : vector :=
  add_vect_aux v1 v2.
Next Obligation.
  dest_vects.
  generalize dependent av2. revert av1LENGTH. revert n.
  induction av1; destruct av2; simpl; intros; auto.
  simpl in av1LENGTH. destruct n; auto.
Qed.

Notation "v1 <+> v2" := (add_vect v1 v2) (at level 42).

Lemma add_vect_correct1:
  forall v3 v1 v2,
    (v1 <+> v2) <*> v3 = (v1 <*> v3) + (v2 <*> v3).
Proof.
  intros. unfold add_vect, prod_vect. dest_vects.
  generalize dependent av2; generalize dependent av1; revert av3LENGTH; revert n.
  induction av3; intros; destruct av1; destruct av2; simpl in *;subst; auto.
  inv av1LENGTH; inv av2LENGTH.
  erewrite IHav3; eauto; try omega. lia.
Qed.

Definition add_constr c1 c2 :=
  mkConstraint (c1.(vect) <+> c2.(vect)) GE (c1.(val) + c2.(val)).

Lemma add_constr_correct : forall v c1 c2,
  satisfy_constr v c1 -> satisfy_constr v c2 -> satisfy_constr v (add_constr c1 c2).
Proof.
  unfold satisfy_constr.
  intros v c1 c2 H H0. destruct c1; destruct c2. simpl in *.
  rewrite add_vect_correct1.
  destruct comp0; destruct comp1; simpl in *; subst; lia.
Qed.

Fixpoint mult_each_constraint (wit: list Z) (pol: polyhedron) : option polyhedron :=
  match wit, pol with
    | nil, nil => Some nil
    | nil, _
    | _, nil => None
    | z :: wit', c::pol' =>
      do pol'' <- mult_each_constraint wit' pol';
      Some ((mult_constraint z c) :: pol'')
  end.

Lemma mult_each_constraint_correct: forall v wit pol pol',
  In_pol v pol -> mult_each_constraint wit pol = Some pol' ->
  In_pol v pol'.
Proof.
  induction wit; destruct pol; unfold In_pol in *; intros; simpl in *; auto.
  inv H0. constructor.

  prog_dos. inv H.
  constructor; eauto.
  apply mult_constraint_correct. auto.
Qed.

Definition colapse_constraints pol :=
  match pol with
    | nil => None
    | c1 :: pol' =>
      Some (fold_left add_constr pol' c1)
  end.

Lemma colapse_constraints_correct: forall v pol c,
  colapse_constraints pol = Some c ->
  In_pol v pol -> satisfy_constr v c.
Proof.
  intros v pol c.
  destruct pol; simpl. auto.
  unfold In_pol. intros HEQ IN. inv HEQ. inv IN.

  generalize dependent c0. generalize dependent pol.
  induction pol; intros; simpl in *; auto.
  inv H2.
  apply IHpol; auto. apply add_constr_correct; auto.
Qed.

(* in lib *)
Fixpoint list_forallb {A:Type} f (l: list A) :=
  match l with
    | nil => true
    | x :: l' =>
      (f x) && (list_forallb f l')
  end.

Lemma list_forallb_correct: forall A f (P: A -> Prop) (l: list A),
  (forall a, f a = true -> P a) ->
  list_forallb f l = true -> list_forall P l.
Proof.
  intros A f P l H H0.
  induction l; simpl in *; constructor.
  apply H. destruct (f a); auto.
  apply IHl. destruct (list_forallb f l); auto.
  destruct (f a); auto.
Qed.

Definition is_pos z :=
  match z with
    | Zpos _ => true
    | _ => false
  end.

Program Definition check_contradiction (c: constraint) :=
  (is_pos c.(val)) && (list_forallb (fun z => z == 0) c.(vect)).

Lemma check_contradiction_correct:
  forall c, check_contradiction c = true ->
    forall v, ~satisfy_constr v c.
Proof.
  unfold check_contradiction, satisfy_constr; intros c H v H'.
  destruct c. dest_vects. unfold prod_vect in *; simpl in *.
  destruct (andb_prop _ _ H). clear H.
  apply list_forallb_correct with (P := (fun z => z = 0)) in H1.

    Focus 2.
      intros. dest ==; auto.

  assert (0 >= val0).
    clear avLENGTH avect0LENGTH.
    generalize dependent av. revert H1. clear H0. revert val0.
    induction avect0; intros; destruct comp0; simpl in *; auto; try lia.
    destruct av; subst; try lia.
    inv H1. simpl. eauto.
    destruct av; subst; try lia.
    inv H1. simpl in H'. eauto.

  unfold is_pos in H0.
  destruct val0; eauto.
Qed.

Program Definition
  check_emtpy (wit: list Z) (pol: polyhedron) : {empty pol} + {True}:=
  match mult_each_constraint wit pol with
    | None => right _
    | Some pol' =>
      match colapse_constraints pol' with
        | None => right _
        | Some c =>
          match check_contradiction c with
            | true => left _
            | false => right _
          end
      end
  end.
Next Obligation.
  unfold empty. intros v IN.
  symmetry in Heq_anonymous. symmetry in Heq_anonymous0. symmetry in Heq_anonymous1.
  pose proof (mult_each_constraint_correct _ IN Heq_anonymous).
  apply (colapse_constraints_correct Heq_anonymous0) in H.
  eapply check_contradiction_correct; eauto.
Qed.

(* we now use the emptyness test to build an inclusion test *)

Definition inv_constr (c: constraint) :=
  mkConstraint (opp_vect c.(vect)) GE (1 - c.(val)).

Lemma inv_constr_correct: forall c v,
  c.(comp) = GE -> ~(satisfy_constr v (inv_constr c)) ->
  satisfy_constr v c.
Proof.
  unfold satisfy_constr. unfold inv_constr.
  intros c v H H0.
  destruct c. simpl in *. subst.
  rewrite opp_vect_correct1 in H0.
  assert (~(- (vect0 <*> v) >= (1 - val0))); auto.
  simpl. lia.
Qed.

(* is_empty is defined in Polyhedra.v *)
Variable is_empty_canonized : forall (p: polyhedron), {empty p} + {True}.

Definition included p1 p2 :=
  forall v, In_pol v p1 -> In_pol v p2.
Hint Unfold In_pol included.

Definition are_included_aux p1 p2 :=
  list_forallb (fun c => is_empty_canonized ((inv_constr c) :: p1)) (canonize_pol p2).

Lemma empty_inv: forall c p, c.(comp) = GE -> empty ((inv_constr c) :: p) ->
  forall v, (In_pol v p -> satisfy_constr v c).
Proof.
  unfold empty, In_pol.
  intros c p H H0 v H1.
  apply inv_constr_correct; auto.
  intro SATIS.
  apply (H0 v).
  constructor; auto.
Qed.

Lemma are_included_aux_correct:
  forall p1 p2, are_included_aux p1 p2 = true -> included p1 p2.
Proof.
  unfold included, In_pol, are_included_aux.
  intros p1 p2 H v H0.
  apply list_forallb_correct with (P := (fun c=> empty (inv_constr c :: p1))) in H.
  apply canonize_pol_corr2. unfold In_pol.

  induction p2 as [|c p2]; simpl; try constructor.
  destruct c; destruct comp0; simpl in *; constructor; inv H; eauto using empty_inv.
  constructor; inv H4; eauto using empty_inv.

  intros c H1. destruct (is_empty_canonized (inv_constr c :: p1)); simpl in H1; auto.
Qed.

Program Definition are_included_canonized_part p1 p2 : {included p1 p2} + {True} :=
  match are_included_aux p1 p2 with
    | true => left _
    | false => right _
  end.
Next Obligation.
  auto using are_included_aux_correct.
Qed.

Program Definition are_included_part p1 p2 : {included p1 p2} + {True} :=
  match are_included_aux (canonize_pol p1) p2 with
    | true => left _
    | false => right _
  end.
Next Obligation.
  unfold included. intros v H. apply canonize_pol_corr1 in H.
  symmetry in Heq_anonymous. apply are_included_aux_correct in Heq_anonymous.
  unfold included in Heq_anonymous. eauto.
Qed.
End WITHDIM.

Definition pseudo_vector := list Z.

Record pseudo_constraint := mkPseudoConstraint
  { pvect: pseudo_vector;
    pcomp: cmp;
    pval: Z}.

Definition pseudo_polyhedron := list pseudo_constraint.

Fixpoint is_of_length (n: nat) (pv: pseudo_vector) :=
  match n, pv with
    | O, nil => true
    | _, nil
    | O, _ => false
    | S n', _ :: pv' => is_of_length n' pv'
  end.

Program Definition make_vector n (pv: pseudo_vector) : option (vector n) :=
  match is_of_length n pv with
    | true => Some pv
    | false => None
  end.
Next Obligation.
  generalize dependent pv.
  induction n; destruct pv; simpl; intro LENGTH; auto.
Qed.

Definition make_constraint n (pc: pseudo_constraint) : option (constraint n):=
  do v <- make_vector n pc.(pvect);
  point (mkConstraint v pc.(pcomp) pc.(pval)).

Definition make_polyhedron n (ph : pseudo_polyhedron) : option (polyhedron n):=
  mmap (make_constraint n) ph.