Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Init.Nat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
Import ListNotations.

From PLF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import Types.
From PLF Require Import Imp.

Hint Constructors multi.

Module S.

Import Smallstep.

Definition stack := list nat.
Definition prog  := list sinstr.

Inductive stack_step : state -> prog * stack -> prog * stack -> Prop :=
  | SS_Push : forall st stk n p',
    stack_step st (SPush n :: p', stk)      (p', n :: stk)
  | SS_Load : forall st stk i p',
    stack_step st (SLoad i :: p', stk)      (p', st i :: stk)
  | SS_Plus : forall st stk n m p',
    stack_step st (SPlus :: p', n::m::stk)  (p', (m+n)::stk)
  | SS_Minus : forall st stk n m p',
    stack_step st (SMinus :: p', n::m::stk) (p', (m-n)::stk)
  | SS_Mult : forall st stk n m p',
    stack_step st (SMult :: p', n::m::stk)  (p', (m*n)::stk).

Fixpoint s_compile (e : aexp) : list sinstr :=
match e with
		| ANum v => [SPush v]
		| AId i => [SLoad i]
		| APlus a1 a2 => (s_compile a1) ++ (s_compile a2) ++ [SPlus]
		| AMinus a1 a2 => (s_compile a1) ++ (s_compile a2) ++ [SMinus]
		| AMult a1 a2 => (s_compile a1) ++ (s_compile a2) ++ [SMult]
end.

Theorem stack_step_deterministic : forall st,
  deterministic (stack_step st).
Proof.
  unfold deterministic.
  intros st x y1 y2 H1 H2.
  induction H1; inversion H2; reflexivity.
Qed.

Definition stack_multistep st := multi (stack_step st).

Definition compiler_is_correct_statement : Prop :=
  forall (st : state) (e : aexp),
    stack_multistep st (s_compile e, []) ([], [ aeval st e ]).

Theorem s_compile_aux : forall (e : aexp) (t: prog) (st : state) (stk1 : stack),
  stack_multistep st (s_compile e ++ t, stk1) (t, aeval st e :: stk1).
Proof.

induction e.
  - intros t st stk1. simpl. unfold stack_multistep. apply multi_R. constructor.
  - intros t st stk1. simpl. unfold stack_multistep. apply multi_R. constructor.
  - intros t st stk1. simpl. unfold stack_multistep.
    unfold stack_multistep in IHe1. unfold stack_multistep in IHe2.
    eapply multi_trans.
    + rewrite <- app_assoc. rewrite <- app_assoc. eapply IHe1.
    + eapply multi_trans.
      * eapply IHe2.
      * apply multi_R. constructor.
  - (* same as previous case *)
    intros t st stk1. simpl. unfold stack_multistep.
    unfold stack_multistep in IHe1. unfold stack_multistep in IHe2.
    eapply multi_trans.
    + rewrite <- app_assoc. rewrite <- app_assoc. eapply IHe1.
    + eapply multi_trans.
      * eapply IHe2.
      * apply multi_R. constructor.
  - (* same as previous case *)
    intros t st stk1. simpl. unfold stack_multistep.
    unfold stack_multistep in IHe1. unfold stack_multistep in IHe2.
    eapply multi_trans.
    + rewrite <- app_assoc. rewrite <- app_assoc. eapply IHe1.
    + eapply multi_trans.
      * eapply IHe2.
      * apply multi_R. constructor.
Qed.

Theorem compiler_is_correct : compiler_is_correct_statement.
Proof.
  unfold compiler_is_correct_statement.
  intros st e.
  rewrite <- (app_nil_r (s_compile e)).
  apply s_compile_aux.
Qed.

End S.

Module T.

Import Types.

Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t --> t'.

Proof with auto.
  intros t T HT.
  induction HT...
  (* The cases that were obviously values, like T_Tru and
     T_Fls, were eliminated immediately by auto *)
  - (* T_Test *)
    right. inversion IHHT1; clear IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    inversion H; subst; clear H.
      exists t2...
      exists t3...
    + (* t1 can take a step *)
      inversion H as [t1' H1].
      exists (test t1' t2 t3)...

  - (* T_Succ *)
    inversion IHHT.
    + left. apply (nat_canonical t1 HT) in H.
      apply nv_scc in H. unfold value. right. assumption.
    + right. inversion H as [t1' H1]. exists (scc t1')...
  - (* T_Prd *)
    right. inversion IHHT; clear IHHT.
    + apply (nat_canonical t1 HT) in H.
      inversion H; subst; clear H.
      * exists zro...
      * exists t...
    + inversion H. exists (prd x). apply ST_Prd. assumption.
  - (* T_Iszro *)
    right. inversion IHHT; clear IHHT.
    + apply (nat_canonical t1 HT) in H.
      inversion H; subst; clear H.
      * exists tru. apply ST_IszroZro.
      * exists fls. apply ST_IszroScc.  assumption.
    + inversion H. exists (iszro x). apply ST_Iszro. assumption.
Qed.

Theorem preservation : forall t t' T,
  |- t \in T ->
  t --> t' ->
  |- t' \in T.

Proof with auto.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try solve_by_invert.
    - (* T_Test *) inversion HE; subst; clear HE.
      + (* ST_TESTTru *) assumption.
      + (* ST_TestFls *) assumption.
      + (* ST_Test *) apply T_Test; try assumption.
        apply IHHT1; assumption.
    - (* T_Scc *) inversion HE; subst; clear HE.
      apply T_Scc. apply IHHT. assumption.
    - (* T_Prd *) inversion HE; subst; clear HE.
      + apply HT.
      + inversion HT. assumption.
      + apply T_Prd. apply IHHT. assumption.
    - (* T_Iszro *) inversion HE; subst; clear HE.
      + apply T_Tru.
      + apply T_Fls.
      + apply T_Iszro. apply IHHT. assumption.
Qed.

End T.


Require Import StructTact.StructTactics.
Require Import oeuf.StuartTact.

Section steplib.

Variable state : Type.
Variable sstep : state -> state -> Prop.

Inductive sstar : state -> state -> Prop :=
| SStarNil : forall e, sstar e e
| SStarCons : forall e e' e'',
        sstep e e' ->
        sstar e' e'' ->
        sstar e e''.

Inductive splus  : state -> state -> Prop :=
| SPlusOne : forall s s',
        sstep s s' ->
        splus s s'
| SPlusCons : forall s s' s'',
        sstep s s' ->
        splus s' s'' ->
        splus s s''.

Lemma sstar_snoc : forall s s' s'',
    sstar s s' ->
    sstep s' s'' ->
    sstar s s''.
induction 1; intros.
- econstructor; try eassumption. econstructor.
- econstructor; eauto.
Qed.

Lemma splus_snoc : forall s s' s'',
    splus s s' ->
    sstep s' s'' ->
    splus s s''.
induction 1; intros.
- econstructor 2; try eassumption.
  econstructor 1; eassumption.
- econstructor; solve [eauto].
Qed.

Lemma splus_sstar : forall s s',
    splus s s' ->
    sstar s s'.
induction 1; intros.
- econstructor; try eassumption. constructor.
- econstructor; eauto.
Qed.

Lemma sstep_sstar : forall s s',
    sstep s s' ->
    sstar s s'.
intros. eapply splus_sstar. eapply SPlusOne. auto.
Qed.

Lemma sstar_then_sstar : forall s s' s'',
    sstar s s' ->
    sstar s' s'' ->
    sstar s s''.
induction 1; intros.
- assumption.
- econstructor; solve [eauto].
Qed.

Lemma sstar_then_splus : forall s s' s'',
    sstar s s' ->
    splus s' s'' ->
    splus s s''.
induction 1; intros.
- assumption.
- econstructor; solve [eauto].
Qed.

Lemma splus_then_sstar' : forall s s' s'',
    sstar s' s'' ->
    splus s s' ->
    splus s s''.
induction 1; intros.
- assumption.
- eapply IHsstar. eapply splus_snoc; eauto.
Qed.

Lemma splus_then_sstar : forall s s' s'',
    splus s s' ->
    sstar s' s'' ->
    splus s s''.
intros. eauto using splus_then_sstar'.
Qed.

Lemma splus_then_splus : forall s s' s'',
    splus s s' ->
    splus s' s'' ->
    splus s s''.
induction 1; intros; eauto using SPlusCons.
Qed.

End steplib.

Implicit Arguments sstar [state].
Implicit Arguments splus [state].

Require oeuf.Semantics.

Lemma sstar_semantics : forall genv state step ge s s',
    sstar (step ge) s s' ->
    @Semantics.star genv state step ge s s'.
induction 1.
- constructor.
- econstructor; eauto.
Qed.

Lemma splus_semantics : forall genv state step ge s s',
    splus (step ge) s s' ->
    @Semantics.plus genv state step ge s s'.
destruct 1.
- econstructor; eauto. constructor.
- econstructor; eauto using splus_sstar, sstar_semantics.
Qed.

Lemma splus_semantics_sim : forall genv state_a state_b step
        ge (a' : state_a) (b : state_b) match_states,
    (exists b' : state_b,
        splus (step ge) b b' /\ match_states a' b') ->
    (exists b' : state_b,
        @Semantics.plus genv state_b step ge b b' /\ match_states a' b').
firstorder eauto using splus_semantics.
Qed.

Lemma sstar_01_semantics_sim : forall genv state_a state_b step measure
        ge (a a' : state_a) (b : state_b) match_states,
    (exists b' : state_b,
        (step ge b b' \/ (b' = b /\ measure a' < measure a)) /\
        match_states a' b') ->
    ((exists b' : state_b,
            @Semantics.plus genv state_b step ge b b' /\ match_states a' b') \/
        (measure a' < measure a /\ match_states a' b)).
intros. break_exists. break_and. on (_ \/ _), invc.
- left. eapply splus_semantics_sim. firstorder eauto using SPlusOne.
- right. firstorder congruence.
Qed.

Lemma sstar_semantics_sim : forall genv state_a state_b step measure
        ge (a a' : state_a) (b : state_b) match_states,
    (exists b' : state_b,
        (splus (step ge) b b' \/ (b' = b /\ measure a' < measure a)) /\
        match_states a' b') ->
    ((exists b' : state_b,
            @Semantics.plus genv state_b step ge b b' /\ match_states a' b') \/
        (measure a' < measure a /\ match_states a' b)).
intros. break_exists. break_and. on (_ \/ _), invc.
- left. eapply splus_semantics_sim. firstorder.
- right. firstorder congruence.
Qed.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** This file provides classical logic and indefinite description under
    the form of Hilbert's epsilon operator *)

(** Hilbert's epsilon operator and classical logic implies
    excluded-middle in [Set] and leads to a classical world populated
    with non computable functions. It conflicts with the
    impredicativity of [Set] *)

Require Export Classical.
Require Import ChoiceFacts.

Set Implicit Arguments.

Axiom constructive_indefinite_description :
  forall (A : Type) (P : A->Prop),
    (exists x, P x) -> { x : A | P x }.

Lemma constructive_definite_description :
  forall (A : Type) (P : A->Prop),
    (exists! x, P x) -> { x : A | P x }.
Proof.
  intros; apply constructive_indefinite_description; firstorder.
Qed.

Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
Proof.
  apply
    (constructive_definite_descr_excluded_middle
      constructive_definite_description classic).
Qed.

Theorem classical_indefinite_description :
  forall (A : Type) (P : A->Prop), inhabited A ->
    { x : A | (exists x, P x) -> P x }.
Proof.
  intros A P i.
  destruct (excluded_middle_informative (exists x, P x)) as [Hex|HnonP].
  apply constructive_indefinite_description
    with (P:= fun x => (exists x, P x) -> P x).
  destruct Hex as (x,Hx).
    exists x; intros _; exact Hx.
  assert {x : A | True} as (a,_).
    apply constructive_indefinite_description with (P := fun _ : A => True).
    destruct i as (a); firstorder.
  firstorder.
Defined.

(** Hilbert's epsilon operator *)

Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A
  := proj1_sig (classical_indefinite_description P i).

Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) :
  (exists x, P x) -> P (epsilon i P)
  := proj2_sig (classical_indefinite_description P i).

(** Open question: is classical_indefinite_description constructively
    provable from [relational_choice] and
    [constructive_definite_description] (at least, using the fact that
    [functional_choice] is provable from [relational_choice] and
    [unique_choice], we know that the double negation of
    [classical_indefinite_description] is provable (see
    [relative_non_contradiction_of_indefinite_desc]). *)

(** A proof that if [P] is inhabited, [epsilon a P] does not depend on
    the actual proof that the domain of [P] is inhabited
    (proof idea kindly provided by Pierre Castéran) *)

Lemma epsilon_inh_irrelevance :
   forall (A:Type) (i j : inhabited A) (P:A->Prop),
   (exists x, P x) -> epsilon i P = epsilon j P.
Proof.
 intros.
 unfold epsilon, classical_indefinite_description.
 destruct (excluded_middle_informative (exists x : A, P x)) as [|[]]; trivial.
Qed.

Opaque epsilon.

(** *** Weaker lemmas (compatibility lemmas) *)

Theorem choice :
  forall (A B : Type) (R : A->B->Prop),
    (forall x : A, exists y : B, R x y) ->
    (exists f : A->B, forall x : A, R x (f x)).
Proof.
  intros A B R H.
  exists (fun x => proj1_sig (constructive_indefinite_description _ (H x))).
  intro x.
  apply (proj2_sig (constructive_indefinite_description _ (H x))).
Qed.


From Hammer Require Import Hammer.

Require Import List Decidable.
Set Implicit Arguments.

Definition decidable_eq A := forall x y:A, decidable (x=y).

Section Dec_in_Prop.
Variables (A:Type)(dec:decidable_eq A).

Lemma In_decidable x (l:list A) : decidable (In x l).
Proof using A dec. hammer_hook "ListDec" "ListDec.In_decidable".
induction l as [|a l IH].
- now right.
- destruct (dec a x).
+ left. now left.
+ destruct IH; simpl; [left|right]; tauto.
Qed.

Lemma incl_decidable (l l':list A) : decidable (incl l l').
Proof using A dec. hammer_hook "ListDec" "ListDec.incl_decidable".
induction l as [|a l IH].
- left. inversion 1.
- destruct (In_decidable a l') as [IN|IN].
+ destruct IH as [IC|IC].
* left. destruct 1; subst; auto.
* right. contradict IC. intros x H. apply IC; now right.
+ right. contradict IN. apply IN; now left.
Qed.

Lemma NoDup_decidable (l:list A) : decidable (NoDup l).
Proof using A dec. hammer_hook "ListDec" "ListDec.NoDup_decidable".
induction l as [|a l IH].
- left; now constructor.
- destruct (In_decidable a l).
+ right. inversion_clear 1. tauto.
+ destruct IH.
* left. now constructor.
* right. inversion_clear 1. tauto.
Qed.

End Dec_in_Prop.

Section Dec_in_Type.
Variables (A:Type)(dec : forall x y:A, {x=y}+{x<>y}).

Definition In_dec := List.In_dec dec.

Lemma incl_dec (l l':list A) : {incl l l'}+{~incl l l'}.
Proof using A dec. hammer_hook "ListDec" "ListDec.incl_dec".
induction l as [|a l IH].
- left. inversion 1.
- destruct (In_dec a l') as [IN|IN].
+ destruct IH as [IC|IC].
* left. destruct 1; subst; auto.
* right. contradict IC. intros x H. apply IC; now right.
+ right. contradict IN. apply IN; now left.
Qed.

Lemma NoDup_dec (l:list A) : {NoDup l}+{~NoDup l}.
Proof using A dec. hammer_hook "ListDec" "ListDec.NoDup_dec".
induction l as [|a l IH].
- left; now constructor.
- destruct (In_dec a l).
+ right. inversion_clear 1. tauto.
+ destruct IH.
* left. now constructor.
* right. inversion_clear 1. tauto.
Qed.

End Dec_in_Type.

Lemma uniquify_map A B (d:decidable_eq B)(f:A->B)(l:list A) :
exists l', NoDup (map f l') /\ incl (map f l) (map f l').
Proof. hammer_hook "ListDec" "ListDec.uniquify_map".
induction l.
- exists nil. simpl. split; [now constructor | red; trivial].
- destruct IHl as (l' & N & I).
destruct (In_decidable d (f a) (map f l')).
+ exists l'; simpl; split; trivial.
intros x [Hx|Hx]. now subst. now apply I.
+ exists (a::l'); simpl; split.
* now constructor.
* intros x [Hx|Hx]. subst; now left. right; now apply I.
Qed.

Lemma uniquify A (d:decidable_eq A)(l:list A) :
exists l', NoDup l' /\ incl l l'.
Proof. hammer_hook "ListDec" "ListDec.uniquify".
destruct (uniquify_map d id l) as (l',H).
exists l'. now rewrite !map_id in H.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Relations.Relations.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Eqdep_dec.
Require Import ExtLib.Data.Eq.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Data.Member.
Require Import ExtLib.Data.HList.

Set Implicit Arguments.
Set Strict Implict.

Inductive typ : Type := Nat | Arr (dom codom : typ).

Fixpoint typD (t : typ) : Type :=
  match t with
  | Nat => nat
  | Arr a b => typD a -> typD b
  end.

Inductive wt_expr (vs : list typ) : typ -> Type :=
| wtApp : forall t1 t2, wt_expr vs (Arr t1 t2) -> wt_expr vs t1 -> wt_expr vs t2
| wtAbs : forall t1 t2, wt_expr (t1 :: vs) t2 -> wt_expr vs (Arr t1 t2)
| wtVar : forall t, member t vs -> wt_expr vs t
| wtConst : forall t, typD t -> wt_expr vs t.

Inductive expr : Type :=
| App (f x : expr)
| Abs : typ -> expr -> expr
| Var : nat -> expr
| Const : forall t, typD t -> expr.

Fixpoint erase vs t (e : wt_expr vs t) : expr :=
  match e with
  | wtApp a b => App (erase a) (erase b)
  | @wtAbs _ t _ a => Abs t (erase a)
  | @wtVar _ _ m => Var (to_nat m)
  | @wtConst _ t x => @Const t x
  end.

Definition wt_expr_expr' vs t (wt : wt_expr vs t) (e : expr) : Prop :=
  erase wt = e.

Inductive wt_expr_expr vs : forall t, wt_expr vs t -> expr -> Prop :=
| rApp : forall t1 t2 e1 e1' e2 e2',
    @wt_expr_expr vs (Arr t1 t2) e1 e1' ->
    @wt_expr_expr vs t1 e2 e2' ->
    @wt_expr_expr vs t2 (wtApp e1 e2) (App e1' e2')
| rAbs : forall t1 t2 e1 e1',
    @wt_expr_expr (t1 :: vs) t2 e1 e1' ->
    @wt_expr_expr vs (Arr t1 t2) (wtAbs e1) (Abs t1 e1')
| rVar : forall t (m : member t vs),
    @wt_expr_expr vs t (wtVar m) (Var (to_nat m))
| rConst : forall t v,
    @wt_expr_expr vs t (wtConst vs t v) (Const t v).

Fixpoint wt_exprD vs t (e : wt_expr vs t) : hlist typD vs -> typD t :=
  match e in wt_expr _ t return hlist typD vs -> typD t with
  | wtApp a b =>
    let aD := @wt_exprD _ _ a in
    let bD := @wt_exprD _ _ b in
    fun x => (aD x) (bD x)
  | @wtAbs _ _ t e =>
    let eD := @wt_exprD _ _ e in
    fun x => fun y => eD (Hcons y x)
  | wtVar m => fun x => hlist_get m x
  | wtConst _ _ x => fun _ => x
  end.

Definition type_eq (a b : typ) : {a = b} + {a <> b}.
decide equality.
Defined.

Fixpoint type_of_expr (vs : list typ) (e : expr) : option typ :=
  match e with
  | App a b =>
    match type_of_expr vs a , type_of_expr vs b with
    | Some (Arr ta tb) , Some ta' =>
      if type_eq ta ta' then Some tb else None
    | _ , _ => None
    end
  | Abs t e =>
    match type_of_expr (t :: vs) e with
    | Some t' => Some (Arr t t')
    | _ => None
    end
  | Var v => nth_error vs v
  | Const t _ => Some t
  end.

Fixpoint exprD vs t (e : expr) : option (hlist typD vs -> typD t) :=
  match e with
  | Abs _ e =>
    match t as t return option (hlist typD vs -> typD t) with
    | Arr t' r =>
      match exprD (t' :: vs) r e with
      | None => None
      | Some eD => Some (fun x y => eD (Hcons y x))
      end
    | _ => None
    end
  | App a b =>
    match type_of_expr vs b with
    | Some ta =>
      match exprD vs (Arr ta t) a , exprD vs ta b with
      | Some f , Some x => Some (fun vs => (f vs) (x vs))
      | _ , _ => None
      end
    | _ => None
    end
  | Var n =>
    match nth_error_get_hlist_nth typD vs n with
    | Some (existT _ t' get) =>
      match type_eq t' t with
      | left pf =>
        match pf in _ = X return option (hlist typD vs -> typD X) with
        | eq_refl => Some get
        end
      | right _ => None
      end
    | None => None
    end
  | Const t' val =>
    match type_eq t' t with
    | left pf =>
      match pf in _ = X return option (hlist typD vs -> typD X) with
      | eq_refl => Some (fun _ => val)
      end
    | _ => None
    end
  end.

Inductive Succeeds {T U : Type} (rT : T -> U -> Prop) : T -> option U -> Prop :=
| Success : forall x y, rT x y -> Succeeds rT x (Some y).

Lemma something : forall vs t (wte : wt_expr vs t) e,
    wt_expr_expr wte e ->
    type_of_expr vs e = Some t.
Proof.
  induction 1; simpl; auto.
  { rewrite IHwt_expr_expr1. rewrite IHwt_expr_expr2.
    destruct (type_eq t1 t1); auto. congruence. }
  { rewrite IHwt_expr_expr. reflexivity. }
  { induction m; simpl; try eauto. }
Qed.

Lemma K_eq_typ : forall (a b : typ) (pf1 pf2 : a = b), pf1 = pf2.
Proof.
  eapply UIP_dec.
  eapply type_eq.
Qed.

Goal forall vs t wte e,
    @wt_expr_expr vs t wte e ->
    Succeeds (eq ==> eq)%signature (@wt_exprD vs t wte) (@exprD vs t e).
Proof.
  induction 1; simpl; intros.
  { erewrite something by eauto.
    destruct IHwt_expr_expr1.
    destruct IHwt_expr_expr2.
    constructor. red. intros; subst.
    erewrite H2 by eauto.
    erewrite H1 by eauto.
    reflexivity. }
  { destruct IHwt_expr_expr.
    constructor. red. intros; subst.
    eapply FunctionalExtensionality.functional_extensionality.
    intros. eapply H0. reflexivity. }
  { induction m.
    { simpl.
      destruct (type_eq t t); try congruence.
      rewrite (eq_option_eq e (fun X => (hlist typD (t :: ls) -> typD X))).
      constructor.
      red. intros. subst.
      rewrite (eq_Arr_eq e).
      rewrite eq_Const_eq.
      generalize (hlist_hd y). clear.
      rewrite (K_eq_typ e eq_refl). reflexivity. }
    { simpl.
      destruct (nth_error_get_hlist_nth typD ls (to_nat m));
        try solve [ inversion IHm ].
      destruct s.
      destruct (type_eq x t); try solve [ inversion IHm ].
      subst. inversion IHm; clear IHm; subst.
      constructor. red. intros; subst.
      erewrite <- H1; reflexivity. } }
  { destruct (type_eq t t); try congruence.
    rewrite (K_eq_typ e eq_refl). constructor.
    reflexivity. }
Qed.


Require Import
  HoTT.Basics
  HoTT.Types
  HoTT.UnivalenceImpliesFunext
  HoTT.Categories.Category.Core
  HoTT.Categories.Category.Univalent
  HoTT.Algebra.UniversalAlgebra.Infinitary.ua_isomorphic.

Require HoTT.Categories.Category.Morphisms.

Import Morphisms.CategoryMorphismsNotations isomorphic_notations.

Local Open Scope category.

(** Given any signature [σ], there is a precategory of set algebras
    and homomorphisms for that signature. *)

Lemma precategory_algebra `{Funext} (σ : Signature) : PreCategory.
Proof.
  apply (@Build_PreCategory
           (Algebra σ) Homomorphism hom_id (@hom_compose σ));
    [intros; by apply path_homomorphism .. | exact _].
Defined.

(** Category isomorphic implies algebra isomorphic. *)

Lemma catiso_to_uaiso `{Funext} {σ} {A B : object (precategory_algebra σ)}
  : A <~=~> B → A ≅ B.
Proof.
  intros [f [a b c]].
  unshelve eapply (@Build_Isomorphic _ _ _ f).
  intros s.
  refine (isequiv_adjointify (f s) (a s) _ _).
  - exact (apD10_homomorphism c s).
  - exact (apD10_homomorphism b s).
Defined.

(** Algebra isomorphic implies category isomorphic. *)

Lemma uaiso_to_catiso `{Funext} {σ} {A B : object (precategory_algebra σ)}
  : A ≅ B → A <~=~> B.
Proof.
  intros [f F G]. set (h := Build_Homomorphism f).
  apply (@Morphisms.Build_Isomorphic _ A B h).
  apply (@Morphisms.Build_IsIsomorphism _ A B h (hom_inv h)).
  - apply path_homomorphism. funext s x. apply eissect.
  - apply path_homomorphism. funext s x. apply eisretr.
Defined.

(** Category isomorphic and algebra isomorphic is equivalent. *)

Global Instance isequiv_catiso_to_uaiso `{Funext} {σ : Signature}
  (A B : object (precategory_algebra σ))
  : IsEquiv (@catiso_to_uaiso _ σ A B).
Proof.
  refine (isequiv_adjointify catiso_to_uaiso uaiso_to_catiso _ _).
  - intros [f F G]. by apply path_isomorphic.
  - intros [f F]. by apply Morphisms.path_isomorphic.
Defined.

(** [Morphisms.idtoiso] factorizes as the composition of equivalences. *)

Lemma path_idtoiso_isomorphic_id `{Funext} {σ : Signature}
  (A B : object (precategory_algebra σ))
  : @Morphisms.idtoiso (precategory_algebra σ) A B
    = catiso_to_uaiso^-1 o isomorphic_id.
Proof.
  funext p. destruct p. by apply Morphisms.path_isomorphic.
Defined.

(** The precategory of set algebras and homomorphisms for a signature
    is a (univalent) category. *)

Lemma iscategory_algebra `{Univalence} (σ : Signature)
  : IsCategory (precategory_algebra σ).
Proof.
  intros A B.
  rewrite path_idtoiso_isomorphic_id.
  apply @isequiv_compose.
  - apply isequiv_compose.
  - apply isequiv_inverse.
Qed.

Definition category_algebra `{Univalence} (σ : Signature) : Category
  := Build_Category (iscategory_algebra σ).


From Flocq3 Require Core Binary.
Import Raux.
Require Import Psatz.
Require Import Recdef.
Require Import float_lemmas.
Import Integers.

Definition main_loop_measure (p : float * float) : nat :=
  float_to_nat (snd p).

Function main_loop (xy : float * float) {measure main_loop_measure} : float :=
    let (x,y) := xy in
   let z := float_div (float_plus y (float_div x y)) (float_of_Z 2) in
    if float_cmp Clt z y then  main_loop (x, z) else z.
Proof.
intros; apply float_to_nat_lt; auto.
Qed.

Definition fsqrt (x: float) : float :=
  if float_cmp Cle x (float_of_Z 0)
  then (float_of_Z 0)
  else
  let y := if float_cmp Cge x (float_of_Z 1)
               then x else float_of_Z 1  in
  main_loop (x,y).


(* week-01_functional-programming-in-Coq.v *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 15 Aug 2020 *)

(* ********** *)

(* Your name: Koo Zhengqun
   Your e-mail address: zhengqun.koo@u.nus.edu
   Your student number: A0164207L
 *)

(* Your name: Bobbie Soedirgo
   Your e-mail address: sram-b@comp.nus.edu.sg
   Your student number: A0181001A
 *)

(**
 %\title{Functional Programming in Coq}%
 %\author{Bobbie Soedirgo, Koo Zhengqun}%
 %\date{\today}%
 %\maketitle%
 %\tableofcontents%
 %\newpage%
 *)

(** * Introduction

    This assignment gets students familiar with defining fixpoints,
    specificially terminating fixpoints, where the parameter in the recursive
    call must be structurally smaller than the given parameter.

    As
    %\href{https://delimited-continuation.github.io/YSC3236/2019-2020_Sem1/week-01_functional-programming-in-coq.html#example-of-recursive-definition-natural-numbers}{Prof
    Danvy alluded to by mentioning the inductive hypothesis}%, the significance
    of this assignment is that it eases students into proving theorems via
    mathematical induction in Coq.

    All fixpoint definitions are based on proof by mathematical induction.
    %\href{https://delimited-continuation.github.io/YSC3236/2019-2020_Sem1/week-01_functional-programming-in-coq.html#example-of-recursive-definition-natural-numbers}{A
    proof sketch for addition is given in the same section where Prof Danvy
    mentioned the inductive hypothesis}%. Similarly, other definitions like
    multiplication, power, and fibonacci, are all defined based on similar
    proofs. However, all these proofs have been elided, because they are
    standard, and can be deduced from the inductive definitions.

    %\newpage%
 *)

(* begin hide *)
(* ********** *)

Check 0.

Check O.

(* Note: "nat" is the type of natural numbers. *)

(* ********** *)

Check 1.

Check (S 0).

Check (S O).

(* ********** *)

Check 2.

Check (S (S 0)).

Check (S (S O)).

(* ********** *)

Check 3.

Compute 3.

(* Note: natural numbers are self-evaluating. *)

(* ********** *)

Compute (4 + 6).

Check (4 + 6).

(* ********** *)

Compute (plus 4 6).

Check (plus 4 6).

(* Note: infix + is syntactic sugar for plus. *)

(* ********** *)

Check (plus 4).

(* Note: plus refers to a library function. *)

Compute (plus 4).
Compute (plus 3).
Compute (plus 2).
Compute (plus 1).
Compute (plus 0).

(* Note: functions are written as in OCaml,
   with the keyword "fun" followed by the formal parameter
   (and optionally its type), "=>", and the body.
 *)

Compute (fun m : nat => S m).

(*
   For comparison,
     fun m : nat => S m
   would be written
     fun m => succ m
   or
     fun m => m + 1
   or
     fun m => 1 + m
   in OCaml and
     (lambda (m) (1+ m))
   in Scheme.
 *)

Compute ((fun m : nat => S m) 3).

(* ********** *)

Definition three := 3.

Check three.

Compute three.

Definition ten := 4 + 6.

Check ten.

Compute ten.

(* ********** *)

(* The following definitions are all equivalent: *)

Definition succ_v0 := fun m : nat => S m.

Definition succ_v1 := fun m => S m.

Definition succ_v2 (m : nat) :=
  S m.

Definition succ_v3 (m : nat) : nat :=
  S m.

Definition succ_v4 m :=
  S m.

(* Note: the definition of succ_v3 is the recommended one here. *)

(* Note: variables are defined once and for all in a file. *)

(* ********** *)

(* Ditto for the following definitions: *)

Definition zerop_v0 : nat -> bool :=
  fun n =>
    match n with
    | O =>
      true
    | S n' =>
      false
    end.

Compute (zerop_v0 0). (* = true : bool *)
Compute (zerop_v0 7). (* = false : bool *)

Definition zerop_v1 (n : nat) : bool :=
  match n with
  | O =>
    true
  | S n' =>
    false
  end.

Compute (zerop_v1 0). (* = true : bool *)
Compute (zerop_v1 7). (* = false : bool *)

(* ********** *)

Require Import Arith Bool.

Check (2 =? 3).
Compute (2 =? 3).

(* Alternatively we can define our own notation: *)

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).
(* end hide *)

(* ********** *)

(** * Exercise 1 *)

(** ** Addition

    Code in this subsection was given by Prof Danvy, whereas comments are mine.

 *)

(** *** Tests

    A suite of unit tests take in a candidate addition function, perform
    equality tests on naturals, and return true only if all tests return true.

 *)
Definition test_add (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 1)
  &&
  (candidate 1 0 =n= 1)
  &&
  (candidate 1 1 =n= 2)
  &&
  (candidate 1 2 =n= 3)
  &&
  (candidate 2 1 =n= 3)
  &&
  (candidate 2 2 =n= 4).

(** A test suite on a recursive function can never have 100%% code coverage,
    because the recursive function has as parameter an inductive type, and this
    inductive type contains infinitely many elements (precisely all the
    naturals, but not the fixpoint $\omega$).

    This suite does not test over many addition parameters (up to [2]), and also
    does not test all combinations of addition parameters.

    However, this suite does test commutativity for some values of addition:
    [0+1=1=1+0], and [1+2=3=2+1].

 *)

(** *** Specification

    Specification is already given by inductive proof at
    %\href{https://delimited-continuation.github.io/YSC3236/2019-2020_Sem1/week-01_functional-programming-in-coq.html#example-of-recursive-definition-natural-numbers}.

 *)

(** *** Implementation

    The following is not tail-recursive, because there is a constructor over the
    recursive call.

 *)
Fixpoint add_v1 (i j : nat) : nat :=
  match i with
  | O => j
  | S i' => S (add_v1 i' j)
  end.

(* begin hide *)
Compute (test_add add_v1).
(* end hide *)

(** The following is tail-recursive.

 *)
Fixpoint add_v2 (i j : nat) : nat :=
  match i with
  | O => j
  | S i' => add_v2 i' (S j)
  end.

(* begin hide *)
Compute (test_add add_v2).
(* end hide *)

(** [visit] in the following is like [add_v1], and [add_v3] passes both [i j] to
    [visit].

    A stark difference compared to [add_v1] is, [visit] recurses only on the
    parameter [i] instead of both [i j] in [add_v1]. This is because [visit]
    does not need to remember [j] across recursive calls: this is already
    handled since recursive calls to [visit] are in the scope of [add_v3], which
    defines [j].

 *)
Definition add_v3 (i j : nat) : nat :=
  let fix visit n :=
      match n with
      | O => j
      | S n' => S (visit n')
      end
  in visit i.

(* begin hide *)
Compute (test_add add_v3).
(* end hide *)

(** A similar thing can be done for [visit] in the following, where [visit] is
    like [add_v2]. Unlike [visit] in [add_v3], here in [add_v4], [visit] must
    have two parameters, because [add_v2] is tail-recursive, and accumulate the
    constructors [S] in one parameter of the recursive call (the other parameter
    is the principally decreasing argument).

 *)
Definition add_v4 (i j : nat) : nat :=
  let fix visit n m :=
      match n with
      | O => m
      | S n' => visit n' (S m)
      end
  in visit i j.

(* begin hide *)
Compute (test_add add_v4).
(* end hide *)

(* ***** *)

(** ** Multiplication *)

(** *** Tests

    This suite of unit tests is defined on the same inputs as [test_add].

 *)
Definition test_mul (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 0)
  &&
  (candidate 1 0 =n= 0)
  &&
  (candidate 1 1 =n= 1)
  &&
  (candidate 1 2 =n= 2)
  &&
  (candidate 2 1 =n= 2)
  &&
  (candidate 2 2 =n= 4).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

    This suite does not test over many addition parameters (up to [2]), and also
    does not test all combinations of addition parameters.

    However, this suite does test commutativity for some values of
    multiplication: [1*2=2=2*1].

 *)

(** *** Specification

    The multiplication function multiplying [i] with [j] was defined using the
    distributivity law of addition and multiplication on naturals: $(k+k')*j =
    k*j+k'*j$ which says for an [i] of the form [k+k'], where [(i j k k' : nat)],
    multiplication distributes over addition. In particular, when [k] is [S O],
    the distributivity law states: $((S O) + k')*j = (S O)*j+k'*j$, and since [S
    O] is the identity of multiplication, we have $(S O)*j=j$, and so $((S O) +
    k')*j = j+k'*j$.

    The base case is when [i] is 0, in which case $0j = 0$. Otherwise, $(1 + n)a
    = a + na$ where $1 + n = i$.

 *)

(** *** Implementation *)
Fixpoint mul_v1 (i j : nat) : nat :=
  match i with
  | O => O
  | S i' => add_v1 j (mul_v1 i' j)
  end.

(* begin hide *)
Compute (test_mul mul_v1).
(* end hide *)

(* ***** *)

(** ** Power *)

(** *** Tests

    This suite of unit tests is defined on the same inputs as [test_add].

 *)
Definition test_power (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 1) (* mathematically undefined *)
  &&
  (candidate 0 1 =n= 0)
  &&
  (candidate 1 0 =n= 1)
  &&
  (candidate 1 1 =n= 1)
  &&
  (candidate 1 2 =n= 1)
  &&
  (candidate 2 1 =n= 2)
  &&
  (candidate 2 2 =n= 4).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

    The unit test $0^0$ is mathematically undefined. But the definition of
    [power_v1] below, has as base case [n] of [1], because $x^0$ is $1$ for $x
    \neq 0$.

    [power_v1] extends the return value $1$ to $x^0$ for $x = 0$, by returning
    [1] on the structural case where [n] is [O]. Coq demands that [power_v1]
    must be a total function, in particular, the case where $x = 0$ and $n = 0$
    must be defined, so we might as well define it by an extension of behavior
    of the power function.

    So, to accomodate this extension of return values, the unit test $0^0$ has
    an expected result of $1$.

 *)

(** *** Specification

    The power function taking [x] to the power [n] was defined using the
    distributivity law of multiplication and power on naturals: $x^{k+k'} =
    x^k*x^{k'}$ which says for an [n] of the form [k+k'], where [(x n k k' :
    nat)], power distributes over multiplication. In particular, when [k] is [S
    O], the distributivity law states: $x^{(S O) + k'} = x^{S O}*x^{k'}$, and
    since [S O] is the identity of exponentiation, we have $x^{S O}=x$, and so
    $x^{(S O) + k'} = x*x^{k'}$.

    The base case is when the power is 0, in which case the result is 1 (with a
    caveat on $x = 0$). Otherwise $x^{1 + m} = x * x^m$ where $1 + m = n$.

 *)

(** *** Implementation *)

Fixpoint power_v1 (x n : nat) : nat :=
  match n with
  | O => 1
  | S n' => mul_v1 x (power_v1 x n')
  end.

(* begin hide *)
Compute (test_power power_v1).
(* end hide *)

(** We can also implement this with tail recursion using an accumulator, like
    so:

 *)
Definition power_v2 (x n : nat) : nat :=
  let fix f n acc :=
      match n with
      | O => acc
      | S n' => f n' (mul_v1 x acc)
      end
  in f n 1.

(* begin hide *)
Compute (test_power power_v2).
(* end hide *)

(** ** Factorial *)

(** *** Tests

    This suite of unit tests is defined on the natural numbers from $0$ to $6$
    as inputs.

 *)
Definition test_fac (candidate: nat -> nat) : bool :=
  (candidate 0 =n= 1)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 2)
  &&
  (candidate 3 =n= 6)
  &&
  (candidate 4 =n= 24)
  &&
  (candidate 5 =n= 120)
  &&
  (candidate 6 =n= 720).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

 *)

(** *** Specification

    A factorial function is defined on [n] with two base cases: [O] with return
    value [1], and [S O] with return value [1]. For the recursive case, we
    assume the inductive hypothesis for the recursive call to the factorial
    function with parameter [n'] where [n = S n'], and with return value $ih =
    n'!$. Mathematically, $ih = (n - 1)!$. Then, we can define [n!] by
    multiplying [ih] with [n].

    The base case is when $n = 0$, in which case the result is 1. The inductive
    case is $(1 + n)! = (1 + n) * n!$.

 *)

(** *** Implementation *)

Fixpoint fac_v1 (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => mul_v1 n (fac_v1 n')
  end.

(* begin hide *)
Compute (test_fac fac_v1).
(* end hide *)

(** We can also implement this with tail recursion using an accumulator, like
    so:

 *)

Definition fac_v2 (n : nat) : nat :=
  let fix f n acc :=
      match n with
      | O => acc
      | S n' => f n' (mul_v1 n acc)
      end
  in f n 1.

(* begin hide *)
Compute (test_fac fac_v2).
(* end hide *)

(* ***** *)

(** ** Fibonacci *)
(** *** Tests

    This suite of unit tests is defined on the natural numbers from $0$ to $6$
    as inputs.

 *)

Definition test_fib (candidate: nat -> nat) : bool :=
  (candidate 0 =n= 0)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 1)
  &&
  (candidate 3 =n= 2)
  &&
  (candidate 4 =n= 3)
  &&
  (candidate 5 =n= 5)
  &&
  (candidate 6 =n= 8).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

 *)

(** *** Specification

    A fibonacci function on [n] has base cases [0] with return value [0], and
    [1] with return value [1], and the recursive case is on $n \geq 2$ which
    assumes two inductive hypotheses via two recursive calls to the fibonacci
    function with parameters [n - 1] and [n - 2], with values [ih_1] and [ih_2]
    respectively. Mathematically, denoting the fibonacci function by $fib$,
    $ih_1 = fib (n-1)$ and $ih_2 = fib (n-2)$. Then, $fib (n)$ can be defined as
    $fib (n-1) + fib (n-2)$.

 *)

(** *** Implementation

    When attempting to define fibonacci for the first time, I actually did not
    read part of the lecture notes, and I made
    %\href{https://delimited-continuation.github.io/YSC3236/2019-2020_Sem1/week-01_exercises.html#food-for-thought}{the
    exact same mistake as Brynja from the conversation}%. Brynja did:
[[
Fixpoint fib_v2 (n : nat) : nat :=
match n with
| 0 => 0
| 1 => 1
| S (S n'') => fib_v2 ??? + fib_v2 n''
end.
]]

    While I did:
[[
Fixpoint fib_v1 (n : nat) : nat :=
match n with
| O => 0
| S O => 1
| S (S n') => add_v1 (fib_v1 n') (fib_v1 (S n'))
end.
]]
    which is the same modulo commutativity of addition, and assuming [add_v1] is
    correct.

    %\href{https://delimited-continuation.github.io/YSC3236/2019-2020_Sem1/week-01_exercises.html#food-for-thought}{As
     alluded to by Prof Danvy}%, the fibonacci fixpoint cannot be defined by
     recursing on [S n'].

    This is in spite that it is intuitively obvious that [fib_v1] does decrease
    on its principal argument [n]: [fib_v1 (S (S n'))] recurses into [fib_v1 n']
    and [fib_v1 (S n')], where [n'] and [S n'] are structurally smaller than [S
    (S n')].

    The problem is: Coq thinks [fib_v1] does not decrease on the principal
    argument [n], and Coq thinks the fixpoint does not terminate.

    The corrected [fib_v1] below was actually given by Thomas Tan, but almost
    exactly matches
    %\href{https://delimited-continuation.github.io/YSC3236/2019-2020_Sem1/week-01_exercises.html#food-for-thought}{the
    solution given by Prof Danvy}%.

 *)
Fixpoint fib_v1 (n : nat) : nat :=
  match n with
  | O => 0
  | S O => 1
  | S n' => match n' with
            | O => 1
            | S n'' => add_v1 (fib_v1 n') (fib_v1 n'')
            end
  end.

(* begin hide *)
Compute (test_fib fib_v1).
(* end hide *)

(* ***** *)

(** ** Evenness *)

(** *** Tests

    This suite of unit tests is defined on the natural numbers from $0$ to $6$
    as inputs.

 *)
Definition test_even (candidate: nat -> bool) : bool :=
  (candidate 0)
  &&
  (negb (candidate 1))
  &&
  (candidate 2)
  &&
  (negb (candidate 3))
  &&
  (candidate 4)
  &&
  (negb (candidate 5))
  &&
  (candidate 6).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

 *)

(** *** Specification

    The evenness function takes in parameter [n], and has base cases [O] and [S
    O] with return values [true] and [false] respectively. The recursive case on
    $n \geq 2$ assumes the inductive hypothesis via a recursive call on the
    mathematical value of $n - 2$, which returns value [ih]. Split by cases on
    [ih]. If $n - 2$ is even, then $n$ is even. If $n - 2$ is odd, then $n$ is
    odd. Hence, the recursive case of the evenness function is [ih].

    The [S O] case can be merged into the [S (S n')] case by defining [S n'] as [negb (even_v1 n').
 *)

(** *** Implementation *)
Fixpoint even_v1 (n : nat) : bool :=
  match n with
  | O => true
  | S n' => negb (even_v1 n')
  end.

(* begin hide *)
Compute (test_even even_v1).
(* end hide *)

(* ***** *)

(** ** Oddness *)

(** *** Tests

    This suite of unit tests is defined on the natural numbers from $0$ to $6$
    as inputs.

 *)
Definition test_odd (candidate: nat -> bool) : bool :=
  (negb (candidate 0))
  &&
  (candidate 1)
  &&
  (negb (candidate 2))
  &&
  (candidate 3)
  &&
  (negb (candidate 4))
  &&
  (candidate 5)
  &&
  (negb (candidate 6)).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

 *)

(** *** Specification

    The oddness function takes in parameter [n], and has base cases [O] and [S
    O] with return values [false] and [true] respectively. The recursive case on
    $n \geq 2$ assumes the inductive hypothesis via a recursive call on the
    mathematical value of $n - 2$, which returns value [ih]. Split by cases on
    [ih]. If $n - 2$ is even, then $n$ is even. If $n - 2$ is odd, then $n$ is
    odd. Hence, the recursive case of the oddness function is [ih].

    The [S O] case can be merged into the [S (S n')] case by defining [S n'] as [negb (odd_v1 n').
 *)

(** *** Implementation *)

Fixpoint odd_v1 (n : nat) : bool :=
  match n with
  | O => false
  | S n' => negb (odd_v1 n')
  end.

(* begin hide *)
Compute (test_odd odd_v1).
(* end hide *)

(** While it's necessary to have 2 base cases for each of [even_v1] and
    [odd_v1], we can reduce this to one base case each if we implement them
    together with mutual recursion:

 *)
Fixpoint even_v2 (n : nat) : bool :=
  match n with
  | O => true
  | S n' => odd_v2 n'
  end with
odd_v2 n :=
  match n with
  | O => false
  | S n' => even_v2 n'
  end.

(* begin hide *)
Compute (test_even even_v2).
Compute (test_odd odd_v2).
(* end hide *)

(* begin hide *)
(* ********** *)

Inductive binary_tree : Type :=
  Leaf : nat -> binary_tree
| Node : binary_tree -> binary_tree -> binary_tree.

Fixpoint beq_binary_tree (t1 t2 : binary_tree) : bool :=
  match t1 with
    Leaf n1 =>
    match t2 with
      Leaf n2 =>
      n1 =n= n2
    | Node t21 t22 =>
      false
    end
  | Node t11 t12 =>
    match t2 with
      Leaf n2 =>
      false
    | Node t21 t22 =>
      (beq_binary_tree t11 t21) && (beq_binary_tree t12 t22)
    end
  end.

Notation "A =bt= B" :=
  (beq_binary_tree A B) (at level 70, right associativity).

(* ***** *)

Definition test_number_of_leaves (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 1) =n= 1)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 2)
(* etc. *)
.

Fixpoint number_of_leaves_v0 (t : binary_tree) : nat :=
  match t with
    Leaf n =>
    1
  | Node t1 t2 =>
    (number_of_leaves_v0 t1) + (number_of_leaves_v0 t2)
  end.

Compute (test_number_of_leaves number_of_leaves_v0).

(* ***** *)
(* end hide *)

(** * Exercise 2 *)

(** ** Number of Nodes *)

(** *** Tests

    This suite of unit tests is defined on all trees of height $0$ to height
    $2$, modulo the content in the leaves.

 *)

Definition test_number_of_nodes (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 1) =n= 0)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 1)
  &&
  (candidate (Node (Leaf 0) (Node (Leaf 0) (Leaf 0))) =n= 2)
  &&
  (candidate (Node (Node (Leaf 0) (Leaf 0)) (Leaf 0)) =n= 2)
  &&
  (candidate (Node (Node (Leaf 0) (Leaf 0)) (Node (Leaf 0) (Leaf 0))) =n= 3).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

 *)

(** *** Specification

    A tree which is a leaf has $0$ nodes. A tree which is a node has two
    subtrees. By inductive hypotheses, the first subtree has [ih_1] number of
    nodes, and the second subtree has [ih_2] number of nodes. Then, the total
    number of nodes in the tree which is a node is $1 + ih_1 + ih_2$.

 *)

(** *** Implementation *)
Fixpoint number_of_nodes_v0 (t : binary_tree) : nat :=
  match t with
  | Leaf _ => O
  | Node t1 t2 => S (add_v1 (number_of_nodes_v0 t1) (number_of_nodes_v0 t2))
  end.

(* begin hide *)
Compute (test_number_of_nodes number_of_nodes_v0).
(* end hide *)

(* ***** *)

(** ** Smallest Leaf *)

(** *** Tests

    This suite of unit tests is defined on all trees of height $0$ to height
    $2$, modulo the content in the leaves.

 *)

Definition test_smallest_leaf (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 1) =n= 1)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 1)
  &&
  (candidate (Node (Leaf 0) (Node (Leaf 1) (Leaf 1))) =n= 0)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 1)) (Leaf 0)) =n= 0)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 1)) (Node (Leaf 1) (Leaf 0))) =n= 0).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

    Each unit test has a [Leaf] which contains a [nat] which is the smallest of
    all [Leaf]s in the tree. Each unit test then asserts that the candidate
    function acting on the tree returns this [nat].

 *)

(** *** Specification

    A tree which is a leaf containing [nat] of value [n] has the smallest leaf of
    [n]. A tree which is a node has two subtrees. By inductive hypotheses, the
    first subtree has the smallest leaf of [ih_1], and the second subtree has
    the smallest leaf of [ih_2]. Then, the smallest leaf in the tree is a node
    is $min(ih_1, ih_2)$.

 *)

(** *** Implementation

    We first define the comparison function $\leq$ on [m n : nat]. As base cases,
    if [m] is [O], then $m \leq n$ is [true], and if [n] is [O], then $m \leq n$
    is [false]. As inductive case, we assume the inductive hypothesis that [ih]
    is the value of $m' \leq n'$, where $S m' = m$ and $S n' = n$. Then, $m'
    \leq n'$ if and only if $m \leq n$, so the return value of $\leq$ is [ih].

 *)
Fixpoint leq_nat (m n : nat) : bool :=
  match m with
  | O => true
  | S m' => match n with
            | O => false
            | S n' => leq_nat m' n'
            end
  end.

(** We also define convenience functions, each with an [if]-[else] statement. An
    [if]-[else] statement can be thought of as syntactic sugar for a
    [match]-statement, so these convenience functions can be thought of as
    structurally defined.

 *)
Definition min_nat (m n : nat) : nat := if leq_nat m n then m else n.

Definition max_nat (m n : nat) : nat := if leq_nat m n then n else m.

(** *** Implementation

    The implementation follows the specification to the tee. The implementation
    uses [min_nat].

 *)

Fixpoint smallest_leaf_v0 (t : binary_tree) : nat :=
  match t with
  | Leaf n => n
  | Node t1 t2 => min_nat (smallest_leaf_v0 t1) (smallest_leaf_v0 t2)
  end.

(* begin hide *)
Compute (test_smallest_leaf smallest_leaf_v0).
(* end hide *)

(* ***** *)

(** ** Weight *)

(** *** Tests

    This suite of unit tests is defined on all trees of height $0$ to height
    $2$, modulo the content in the leaves.

 *)

Definition test_weight (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 1) =n= 1)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 3)
  &&
  (candidate (Node (Leaf 0) (Node (Leaf 1) (Leaf 1))) =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 1)) (Leaf 0)) =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 1)) (Node (Leaf 1) (Leaf 1))) =n= 4).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

 *)

(** *** Specification

    A tree which is a leaf containing [nat] of value [n] has a weight of [n]. A
    tree which is a node has two subtrees. By inductive hypotheses, the first
    subtree has a weight of [ih_1], and the second subtree a weight of [ih_2].
    Then, the weight of the tree which is a node is $ih_1 + ih_2$.

 *)

(** *** Implementation *)

Fixpoint weight_v0 (t : binary_tree) : nat :=
  match t with
  | Leaf n => n
  | Node t1 t2 => weight_v0 t1 + weight_v0 t2
  end.

(* begin hide *)
Compute (test_weight weight_v0).
(* end hide *)

(* ***** *)

(** ** Height *)

(** *** Tests

    This suite of unit tests is defined on all trees of height $0$ to height
    $2$, modulo the content in the leaves.

 *)

Definition test_height (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 1) =n= 0)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 1)
  &&
  (candidate (Node (Leaf 0) (Node (Leaf 1) (Leaf 1))) =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 1)) (Leaf 0)) =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 1)) (Node (Leaf 1) (Leaf 1))) =n= 2).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

 *)

(** *** Specification

    A tree which is a leaf containing [nat] of value [n] has a height of [0]. A
    tree which is a node has two subtrees. By inductive hypotheses, the first
    subtree has a height of [ih_1], and the second subtree a height of [ih_2].
    Then, the height of the tree which is a node is $1 + max(ih_1 + ih_2)$.

 *)

(** *** Implementation *)

Fixpoint height_v0 (t : binary_tree) : nat :=
  match t with
  | Leaf _ => 0
  | Node t1 t2 => S (max_nat (height_v0 t1) (height_v0 t2))
  end.

(* begin hide *)
Compute (test_height height_v0).
(* end hide *)

(* ***** *)

(** ** Mirror *)

(** *** Tests

    This suite of unit tests is defined on all trees of height $0$ to height
    $2$, modulo the content in the leaves.

 *)

Definition test_mirror (candidate: binary_tree -> binary_tree) : bool :=
  (candidate (Leaf 1) =bt= (Leaf 1))
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =bt= (Node (Leaf 2) (Leaf 1)))
  &&
  (let t := (Node (Leaf 1) (Leaf 2))
   in candidate (candidate t) =bt= t)
  &&
  (candidate (Node (Leaf 0) (Node (Leaf 1) (Leaf 1))) =bt= (Node (Node (Leaf 1) (Leaf 1)) (Leaf 0)))
  &&
  (let t := (Node (Node (Leaf 2) (Leaf 1)) (Leaf 0))
   in candidate (candidate t) =bt= t).

(** A test suite on a recursive function can never have 100%% code coverage, and
    this suite is no exception.

 *)

(** *** Specification

    The mirror function acting on a tree which is a leaf containing [nat] of value
    [n] is the identity function. A tree which is a node has two subtrees. By
    inductive hypotheses, the first subtree has a mirror of [ih_1], and the
    second subtree a mirror of [ih_2]. Then, the mirror of the tree which is a
    node is a node which has [ih_1] as the first subtree, and [ih_2] as the
    second subtree.

 *)

(** *** Implementation *)

Fixpoint mirror_v0 (t : binary_tree) : binary_tree :=
  match t with
  | Leaf n => Leaf n
  | Node t1 t2 => Node (mirror_v0 t2) (mirror_v0 t1)
  end.

(* begin hide *)
Compute (test_mirror mirror_v0).
(* end hide *)

(* ********** *)

(** * Conclusion

    Implementing fixpoints is straightforward: just follow the proof by
    structural induction.

    However, we must take care to make sure that the recursive call only has
    parameters that are structurally smaller than the given parameters, see
    [fib_v1]. In the context of Coq, we must make sure Coq knows this.
    Performing structural induction through [match]-statements convinces Coq
    that there is a principally decreasing argument, and thus that the fixpoint
    is terminating.

    The [S O] case has been removed not only from the [even_v1] and [odd_v1], but also removed from [mul_v1], [power_v1], [fac_v1] and [fib_v1]. The reasoning is as follows:

    - Bobbie: So I want to ask this before I continue: is there anything wrong with omitting the [S O] case for mul, power, fac, and others? I haven't read until the end so I might be missing a punchline
    - Zhengqun: Good observation, I did not consider that! I've tried removing [S O] from mul to fib, and all the unit tests pass. So I think [S O] is being captured by the inductive case [S n'], where [n'] is [O], and this is well-defined because we already defined the function on [O].

 *)

(* end of week-01_functional-programming-in-Coq.v *)


Require Import Arith.Wf_nat.

Require Import AngelicComposition.

Theorem by_inclusion :
  forall (T : Type) (R1 R2 : T -> T -> Prop),
    well_founded R2
    -> (forall x y, R1 x y -> R2 x y)
    -> well_founded R1.
Proof.
  intros.
  unfold well_founded; intros.
  pattern a.
  apply (well_founded_ind H).
  intros.
  constructor; intros.
  apply H1.
  auto.
Qed.

Theorem by_extensionality : forall T (R S : T -> T -> Prop), (forall s s', R s s' <-> S s s') -> well_founded R <-> well_founded S.
Proof.
  intros.
  split; intros H1; apply (by_inclusion _ _ _ H1); firstorder.
Qed.

Theorem by_variant :
  forall (T1 T2 : Type) (R : T1 -> T1 -> Prop) (f : T1 -> T2) W,
    well_founded W
    -> (forall x y, R x y -> W (f x) (f y))
    -> well_founded R.
Proof.
  intros T1 T2 R f W HHwfd HHsim.
  intros t1'.
  constructor; intros t1 HHr.
  generalize t1 (HHsim _ _ HHr).
  pattern (f t1'); apply (well_founded_ind HHwfd).
  intros t2' HHind u1 HHw.
  constructor; intros v1 HHrv.
  apply (HHind (f u1)); auto.
Qed.

Theorem by_simulation :
  forall (T1 T2 : Type) (R : T1 -> T1 -> Prop) (S : T1 -> T2 -> Prop) (W : T2 -> T2 -> Prop),
    (forall x, (exists y, R y x) -> exists y, S x y)
    -> well_founded W
    -> (forall x z, (R ⊡ S) x z -> (S ⊡ W) x z)
    -> well_founded R.
Proof.
  intros T1 T2 R S W HHsurj HHwfd HHsim.
  intros t1'.
  constructor; intros t1 HHr.
  destruct (HHsurj t1') as (s1,HHs1); eauto.
  generalize t1 t1' HHr HHs1; clear t1 t1' HHs1 HHr.
  pattern s1; apply (well_founded_ind HHwfd).
  intros.
  constructor; intros.
  destruct (HHsurj t1) as (s1',HHs1'); eauto.
  destruct (HHsim _ _ (ex_intro _ _ (conj HHr HHs1))) as (s1'',HHws).
  destruct HHws.
  eapply H; eauto.
Qed.

Theorem by_functional_simulation :
  forall (T1 T2 : Type) (R : T1 -> T1 -> Prop) (S : T1 -> T2) (W : T2 -> T2 -> Prop),
    well_founded W
    -> (forall x y, R x y -> W (S x) (S y))
    -> well_founded R.
Proof.
  intros.
  apply (by_simulation _ _ _ (fun x y => y = S x) W).
  { intros x _; eauto. }
  { exact H. }
  { intros; unfold "⊡" in *.
    clear - H0 H1.
    destruct H1 as (sx,(H11,H12)); subst.
    eauto.
  }
Qed.

Theorem by_direct_functional_simulation :
  forall (T1 T2 : Type) (S : T1 -> T2) (W : T2 -> T2 -> Prop),
    well_founded W
    -> well_founded (fun x y => W (S x) (S y)).
Proof.
  intros.
  apply (by_functional_simulation _ _ _ S W H).
  clear; auto.
Qed.

Theorem by_nat_variant :
  forall (T1 : Type) (R : T1 -> T1 -> Prop) (f : T1 -> nat),
    (forall x y, R x y -> f x < f y) -> well_founded R.
Proof. intros *. apply (by_variant _ _ _ _ _ lt_wf). Qed.


(* ******************************************************************************* *)
(** * Correspondence graphs

    Marco Maggesi
    June 2019
 ********************************************************************************* *)

(*
We refer to graphs formalized in this file as "correspondence graphs"
(cgraphs for short).  A correspondence is a diagram

    N <--- A ---> N'

In our case A is the type of arcs and N = N' is the type of nodes and
the two arrows are interpreted as source and target of an arc.

This name is chosen to make a name distinction with the graphs
defined in CategoryTheory/Graph.v.

Also, to avoid any overlap of the terminology, here we use the words
"node" and "arc" instead of "vertex" and "edge".

When the type N and A of nodes and arcs are not assumed to be sets,
we use the name "correspondence pregraph", abbreviated "precgraph".
*)

Require Import UniMath.MoreFoundations.Propositions.

(** ** Precgraphs. *)

Definition precgraph : UU
  := ∑ (N : UU) (E : UU), (E → N) × (E → N).

Definition make_precgraph {N : UU} {E : UU} (s t : E → N)
  : precgraph
  := N,, E,, make_dirprod s t.

Definition node : precgraph → UU := pr1.

Definition arc (G : precgraph) : UU
  := pr12 G.

Definition source {G : precgraph}
  : arc G → node G
  := pr122 G.

Definition target {G : precgraph}
  : arc G → node G
  := pr222 G.

Definition has_nodeset (G : precgraph) : UU
  := isaset (node G).

Definition has_arcset (G : precgraph) : UU
  := isaset (arc G).

(** Cgraphs. *)

Definition cgraph : UU
  := ∑ G : precgraph, isaset (node G) × isaset (arc G).

Definition make_cgraph
           (G : precgraph)
           (h : isaset (node G))
           (k : isaset (arc G))
  : cgraph
  := tpair _ G (make_dirprod h k).

Definition precgraph_of_cgraph : cgraph → precgraph := pr1.
Coercion precgraph_of_cgraph : cgraph >-> precgraph.

Definition isaset_node (G : cgraph)
  : isaset (node G)
  := pr12 G.

Definition node_set (G : cgraph) : hSet
  := make_hSet (node G) (isaset_node G).

Definition isaset_arc (G : cgraph)
  : isaset (arc G)
  := pr22 G.

Definition arc_set (G : cgraph) : hSet
  := make_hSet (arc G) (isaset_arc G).

(** ** Cgraph morphisms. *)

Definition is_cgraph_mor {G H : precgraph}
           (p₀ : node G → node H)
           (p₁ : arc G → arc H)
  : UU
  := (∏ f : arc G, source (p₁ f) = p₀ (source f)) ×
     (∏ f : arc G, target (p₁ f) = p₀ (target f)).

Definition cgraph_mor (G H : precgraph) : UU
  := ∑ (p₀ : node G → node H)
       (p₁ : arc G → arc H),
     is_cgraph_mor p₀ p₁.

Definition make_cgraph_mor {G H : precgraph}
           (p₀ : node G → node H)
           (p₁ : arc G → arc H)
           (h : is_cgraph_mor p₀ p₁)
  : cgraph_mor G H
  := p₀,, p₁,, h.

Definition onnode {G H : precgraph}
  : cgraph_mor G H → node G → node H
  := pr1.

Definition onarc {G H : precgraph}
  : cgraph_mor G H → arc G → arc H
  := λ f, pr12 f.

Definition preserves_source {G H : precgraph}
           (p : cgraph_mor G H)
  : ∏ x : arc G, source (onarc p x) = onnode p (source x)
  := pr122 p.

Definition preserves_target {G H : precgraph}
           (p : cgraph_mor G H)
  : ∏ f : arc G, target (onarc p f) = onnode p (target f)
  := pr222 p.

Lemma is_cgraph_mor_id (G : precgraph)
  : is_cgraph_mor (idfun (node G)) (idfun (arc G)).
Proof.
  apply make_dirprod; intros; apply idpath.
Defined.

Definition cgraph_mor_id (G : precgraph)
  : cgraph_mor G G
  := make_cgraph_mor (idfun (node G)) (idfun (arc G))
                    (is_cgraph_mor_id G).

Lemma is_cgraph_mor_comp {G H K : precgraph}
      (p : cgraph_mor G H)
      (q : cgraph_mor H K)
  : is_cgraph_mor (onnode q ∘ onnode p) (onarc q ∘ onarc p).
Proof.
  apply make_dirprod.
  - intros. unfold funcomp.
    etrans. apply (preserves_source q).
    apply maponpaths. apply (preserves_source p).
  - intros. unfold funcomp.
    etrans. apply (preserves_target q).
    apply maponpaths. apply (preserves_target p).
Defined.

Definition cgraph_mor_comp {G H K : precgraph}
           (p : cgraph_mor G H)
           (q : cgraph_mor H K)
  : cgraph_mor G K
  := make_cgraph_mor (onnode q ∘ onnode p) (onarc q ∘ onarc p)
                    (is_cgraph_mor_comp p q).

Lemma cgraph_mor_id_left {G H : precgraph} (p : cgraph_mor G H) :
  cgraph_mor_comp (cgraph_mor_id G) p = p.
Proof.
  induction p as (p₀,(p₁,h)).
  apply pair_path_in2.
  apply pair_path_in2.
  apply dirprod_paths.
  - apply funextsec. intro f. cbn.
    apply pathscomp0rid.
  - apply funextsec. intro f. cbn.
    apply pathscomp0rid.
Defined.

Lemma cgraph_mor_id_right {G H : precgraph} (p : cgraph_mor G H) :
  cgraph_mor_comp p (cgraph_mor_id H) = p.
Proof.
  induction p as (p₀,(p₁,h)).
  apply pair_path_in2.
  apply pair_path_in2.
  apply dirprod_paths.
  - apply funextsec. intro f. cbn.
    apply maponpathsidfun.
  - apply funextsec. intro f. cbn.
    apply maponpathsidfun.
Defined.

Lemma cgraph_mor_comp_assoc {G1 G2 G3 G4 : precgraph}
      (p : cgraph_mor G1 G2) (q : cgraph_mor G2 G3) (r : cgraph_mor G3 G4)
  : cgraph_mor_comp p (cgraph_mor_comp q r) =
    cgraph_mor_comp (cgraph_mor_comp p q) r.
Proof.
  induction p as (p₀,(p₁,h)).
  induction q as (q₀,(q₁,k)).
  induction r as (r₀,(r₁,l)).
  apply pair_path_in2.
  apply pair_path_in2.
  apply dirprod_paths; cbn.
  - apply funextsec. intro f.
    etrans. { apply pathsinv0, path_assoc. }
    apply maponpaths.
    apply pathsinv0.
    etrans. { apply maponpathscomp0. }
    apply maponpaths.
    apply maponpathscomp.
  - apply funextsec. intro f.
    etrans. { apply pathsinv0, path_assoc. }
    apply maponpaths.
    apply pathsinv0.
    etrans. { apply maponpathscomp0. }
    apply maponpaths.
    apply maponpathscomp.
Defined.

Lemma isaprop_is_cgraph_mor {G H : precgraph}
      (p₀ : node G → node H)
      (p₁ : arc G → arc H)
      (h : has_nodeset H)
  : isaprop (is_cgraph_mor p₀ p₁).
Proof.
  apply isapropdirprod; apply impred_isaprop; intro f; apply h.
Qed.

Lemma isaset_cgraph_mor {G H : precgraph}
      (h : has_nodeset H) (k : has_arcset H)
  : isaset (cgraph_mor G H).
Proof.
  apply isaset_total2.
  - exact (funspace_isaset h).
  - intro p₀.
    apply isaset_total2.
    + exact (funspace_isaset k).
    + intro p₁.
      apply isasetaprop.
      apply isaprop_is_cgraph_mor.
      exact h.
Qed.

(** ** Equality of cgraph morphisms *)

Lemma cgraph_mor_eq_aux {G H : precgraph}
      (p q : cgraph_mor G H)
      (e₀ : onnode p = onnode q)
      (e₁ : onarc p = onarc q)
      (h : has_nodeset H)
  : p = q.
Proof.
  induction p as (p₀,(p₁,(psource,ptarget))).
  induction q as (q₀,(q₁,(qsource,qtarget))).
  cbn in *.
  induction e₀.
  apply pair_path_in2.
  induction e₁.
  apply pair_path_in2.
  apply pathsdirprod.
  - apply funextsec.
    intro f. apply h.
  - apply funextsec.
    intro f. apply h.
Qed.

Lemma cgraph_mor_eq {G H : cgraph}
      (p q : cgraph_mor G H)
      (e₀ : ∏ x : node G, onnode p x = onnode q x)
      (e₁ : ∏ f : arc G, onarc p f = onarc q f)
  : p = q.
Proof.
  apply cgraph_mor_eq_aux.
  - apply funextfun.
    exact e₀.
  - apply funextfun.
    exact e₁.
  - apply isaset_node.
Qed.

(** ** Weak equivalence between CGraphs and Graphs *)

Require Import UniMath.MoreFoundations.PartD. (* display *)
Require Import UniMath.Combinatorics.Graph.

Lemma precgraph_weq_pregraph : precgraph ≃ pregraph.
Proof.
  unfold pregraph, precgraph.
  apply weqfibtototal. intro X.
  apply (weqcomp (Y := ∑ E : UU, E → X × X)).
  - apply weqfibtototal. intro Y.
    apply invweq, weqfuntoprodtoprod.
  - apply (weqcomp (Y := X × X → UU)).
    + set (A := X × X).
      apply display_weq.
    + apply weqfunfromdirprod.
Defined.


From Coq Require Import
  ZArith.
From DEZ.Has Require Export
  GroupOperation GroupIdentity.
From DEZ.Offers Require Import
  PositivePowers.
From DEZ.ShouldHave Require Import
  AdditiveGroupNotations.

Definition nopr {A : Type} {has_opr : HasOpr A}
  {has_idn : HasIdn A} (n : N) (x : A) : A :=
  match n with
  | N0 => 0
  | Npos p => popr p x
  end.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__ABCequalsCBA.
Require Export lemma__NCorder.
Require Export lemma__angledistinct.
Require Export lemma__angleorderrespectscongruence.
Require Export lemma__angleorderrespectscongruence2.
Require Export lemma__angletrichotomy.
Require Export lemma__congruencesymmetric.
Require Export lemma__equalanglesreflexive.
Require Export lemma__equalanglessymmetric.
Require Export lemma__equalanglestransitive.
Require Export lemma__trichotomy1.
Require Export logic.
Require Export proposition__05.
Require Export proposition__18.
Definition proposition__19 : forall A B C, (euclidean__axioms.Triangle A B C) -> ((euclidean__defs.LtA B C A A B C) -> (euclidean__defs.Lt A B A C)).
Proof.
intro A.
intro B.
intro C.
intro H.
intro H0.
assert (euclidean__axioms.nCol A B C) as H1 by exact H.
assert (* Cut *) (euclidean__axioms.nCol B C A) as H2.
- assert (* Cut *) ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A C B) /\ (euclidean__axioms.nCol C B A))))) as H2.
-- apply (@lemma__NCorder.lemma__NCorder A B C H1).
-- destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
exact H5.
- assert (* Cut *) (euclidean__axioms.nCol A C B) as H3.
-- assert (* Cut *) ((euclidean__axioms.nCol C B A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A B C) /\ ((euclidean__axioms.nCol B A C) /\ (euclidean__axioms.nCol A C B))))) as H3.
--- apply (@lemma__NCorder.lemma__NCorder B C A H2).
--- destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H11.
-- assert (* Cut *) (~(euclidean__axioms.Cong A C A B)) as H4.
--- intro H4.
assert (* Cut *) (euclidean__axioms.Cong A B A C) as H5.
---- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A C B H4).
---- assert (* Cut *) (euclidean__defs.isosceles A B C) as H6.
----- split.
------ exact H1.
------ exact H5.
----- assert (* Cut *) (euclidean__defs.CongA A B C A C B) as H7.
------ apply (@proposition__05.proposition__05 A B C H6).
------ assert (* Cut *) (euclidean__defs.CongA A C B A B C) as H8.
------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric A B C A C B H7).
------- assert (* Cut *) (euclidean__defs.CongA B C A A C B) as H9.
-------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA B C A H2).
-------- assert (* Cut *) (euclidean__defs.CongA B C A A B C) as H10.
--------- apply (@lemma__equalanglestransitive.lemma__equalanglestransitive B C A A C B A B C H9 H8).
--------- assert (* Cut *) (euclidean__defs.LtA B C A B C A) as H11.
---------- apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence B C A A B C B C A H0 H10).
---------- assert (* Cut *) (~(euclidean__defs.LtA B C A B C A)) as H12.
----------- apply (@lemma__angletrichotomy.lemma__angletrichotomy B C A B C A H11).
----------- apply (@H12 H11).
--- assert (* Cut *) (~(euclidean__defs.Lt A C A B)) as H5.
---- intro H5.
assert (euclidean__axioms.Triangle A C B) as H6 by exact H3.
assert (* Cut *) (euclidean__defs.LtA C B A A C B) as H7.
----- apply (@proposition__18.proposition__18 A C B H6 H5).
----- assert (* Cut *) (euclidean__defs.CongA A B C C B A) as H8.
------ apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA A B C H1).
------ assert (* Cut *) (euclidean__defs.LtA A B C A C B) as H9.
------- apply (@lemma__angleorderrespectscongruence2.lemma__angleorderrespectscongruence2 C B A A C B A B C H7 H8).
------- assert (* Cut *) (euclidean__defs.CongA B C A A C B) as H10.
-------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA B C A H2).
-------- assert (* Cut *) (euclidean__defs.LtA A B C B C A) as H11.
--------- apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence A B C A C B B C A H9 H10).
--------- assert (* Cut *) (~(euclidean__defs.LtA A B C B C A)) as H12.
---------- apply (@lemma__angletrichotomy.lemma__angletrichotomy B C A A B C H0).
---------- apply (@H12 H11).
---- assert (* Cut *) (euclidean__defs.CongA A B C A B C) as H6.
----- apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive A B C H1).
----- assert (* Cut *) (euclidean__axioms.neq A B) as H7.
------ assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ (euclidean__axioms.neq A C)))))) as H7.
------- apply (@lemma__angledistinct.lemma__angledistinct A B C A B C H6).
------- destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H14.
------ assert (* Cut *) (euclidean__axioms.neq A C) as H8.
------- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ (euclidean__axioms.neq A C)))))) as H8.
-------- apply (@lemma__angledistinct.lemma__angledistinct A B C A B C H6).
-------- destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H18.
------- assert (* Cut *) (~(~(euclidean__defs.Lt A B A C))) as H9.
-------- intro H9.
assert (* Cut *) (euclidean__axioms.Cong A B A C) as H10.
--------- apply (@lemma__trichotomy1.lemma__trichotomy1 A B A C H9 H5 H7 H8).
--------- assert (* Cut *) (euclidean__axioms.Cong A C A B) as H11.
---------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A B C H10).
---------- apply (@H4 H11).
-------- apply (@euclidean__tactics.NNPP (euclidean__defs.Lt A B A C)).
---------intro H10.
destruct H1 as [H11 H12].
destruct H2 as [H13 H14].
destruct H3 as [H15 H16].
destruct H12 as [H17 H18].
destruct H14 as [H19 H20].
destruct H16 as [H21 H22].
destruct H18 as [H23 H24].
destruct H20 as [H25 H26].
destruct H22 as [H27 H28].
destruct H24 as [H29 H30].
destruct H26 as [H31 H32].
destruct H28 as [H33 H34].
destruct H30 as [H35 H36].
destruct H32 as [H37 H38].
destruct H34 as [H39 H40].
assert (* Cut *) (False) as H41.
---------- apply (@H9 H10).
---------- contradiction H41.

Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype bigop finset.
Require Import fingroup morphism automorphism quotient gproduct.

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

Import GroupScope.

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

Delimit Scope gFun_scope with gF.

Module GFunctor.

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

Bind Scope gFun_scope with object_map.

Section Definitions.

Implicit Types gT hT : finGroupType.

Variable F : object_map.

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

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

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

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

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

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

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

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

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

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

(* Self-expanding composition, and modulo *)

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

Definition comp_head : object_map := fun gT A => let: tt := k in F1 (F2 A).

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

End Definitions.

Section ClassDefinitions.

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

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

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

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

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

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

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

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

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

End ClassDefinitions.

Module Exports.

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

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

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

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

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

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

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

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

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

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

End Exports.

End GFunctor.
Export GFunctor.Exports.

Bind Scope gFun_scope with GFunctor.object_map.

Notation "F1 \o F2" := (GFunctor.comp_head tt F1 F2) : gFun_scope.
Notation "F1 %% F2" := (GFunctor.modulo F1 F2) : gFun_scope.

Section FunctorGroup.

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

End FunctorGroup.

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

Section IsoFunctorTheory.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

End IsoFunctorTheory.

Section FunctorTheory.

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

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

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

End FunctorTheory.

Section PartialFunctorTheory.

Implicit Types gT rT : finGroupType.

Section BasicTheory.

Variable F : GFunctor.pmap.

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

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

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

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

End BasicTheory.

Section Modulo.

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

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

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

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

End Modulo.

Variables F1 F2 : GFunctor.pmap.

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

Canonical gFmod_pgFun := [pgFun by gFmod_hereditary].

End PartialFunctorTheory.

Section MonotonicFunctorTheory.

Implicit Types gT rT : finGroupType.

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

Section Composition.

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

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

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

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

End Composition.

Variables F1 F2 : GFunctor.mono_map.

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

Canonical gFcomp_mgFun := [mgFun by gFcompS].

End MonotonicFunctorTheory.

Section GFunctorExamples.

Implicit Types gT : finGroupType.

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

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

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

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

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

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

End GFunctorExamples.


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.theory.apartness.
Require Export
  HoTT.Classes.theory.rings.

Generalizable Variables F f.

Section field_properties.
Context `{IsField F}.

Definition recip' (x : F) (apx : x ≶ 0) : F := //(x;apx).

(* Add Ring F : (stdlib_ring_theory F). *)
Lemma recip_inverse' (x : F) (Px : x ≶ 0) : x // (x; Px) = 1.
Proof.
  apply (recip_inverse (x;Px)).
Qed.

Lemma reciperse_alt (x : F) Px : x // (x;Px) = 1.
Proof.
rewrite <-(recip_inverse (x;Px)). trivial.
Qed.

Lemma recip_proper_alt x y Px Py : x = y -> // (x;Px) = // (y;Py).
Proof.
intro E. apply ap.
apply Sigma.path_sigma with E.
apply path_ishprop.
Qed.

Lemma recip_proper x y Py : x // (y;Py) = 1 -> x = y.
Proof.
  intros eqxy.
  rewrite <- (mult_1_r y).
  rewrite <- eqxy.
  rewrite (mult_assoc y x (//(y;Py))).
  rewrite (mult_comm y x).
  rewrite <- (mult_assoc x y (//(y;Py))).
  rewrite (recip_inverse (y;Py)).
  rewrite (mult_1_r x).
  reflexivity.
Qed.

Lemma recip_irrelevant x Px1 Px2 : // (x;Px1) = // (x;Px2).
Proof.
apply recip_proper_alt. reflexivity.
Qed.

Lemma apart_0_proper {x y} : x ≶ 0 -> x = y -> y ≶ 0.
Proof.
intros ? E. rewrite <-E. trivial.
Qed.

Global Instance: IsStrongInjective (-).
Proof.
repeat (split; try apply _); intros x y E.
- apply (strong_extensionality (+ x + y)).
  rewrite simple_associativity, left_inverse, plus_0_l.
  rewrite (commutativity (f:=plus) x y), simple_associativity,
    left_inverse, plus_0_l.
  apply symmetry;trivial.
- apply (strong_extensionality (+ -x + -y)).
  rewrite simple_associativity, right_inverse, plus_0_l.
  rewrite (commutativity (f:=plus) (- x) (- y)),
    simple_associativity, right_inverse, plus_0_l.
  apply symmetry;trivial.
Qed.

Global Instance: IsStrongInjective (//).
Proof.
repeat (split; try apply _); intros x y E.
- apply (strong_extensionality (x.1 *.)).
  rewrite recip_inverse, (commutativity (f:=mult)).
  apply (strong_extensionality (y.1 *.)).
  rewrite simple_associativity, recip_inverse.
  rewrite mult_1_l,mult_1_r. apply symmetry;trivial.
- apply (strong_extensionality (.* // x)).
  rewrite recip_inverse, (commutativity (f:=mult)).
  apply (strong_extensionality (.* // y)).
  rewrite <-simple_associativity, recip_inverse.
  rewrite mult_1_l,mult_1_r. apply symmetry;trivial.
Qed.

Global Instance: forall z, StrongLeftCancellation (+) z.
Proof.
intros z x y E. apply (strong_extensionality (+ -z)).
do 2 rewrite (commutativity (f:=plus) z _),
  <-simple_associativity,right_inverse,plus_0_r.
trivial.
Qed.

Global Instance: forall z, StrongRightCancellation (+) z.
Proof.
intros. apply (strong_right_cancel_from_left (+)).
Qed.

Global Instance: forall z, PropHolds (z ≶ 0) -> StrongLeftCancellation (.*.) z.
Proof.
intros z Ez x y E. red in Ez.
rewrite !(commutativity z).
apply (strong_extensionality (.* // (z;(Ez : (≶0) z)))).
rewrite <-!simple_associativity, !reciperse_alt.
rewrite !mult_1_r;trivial.
Qed.

Global Instance: forall z, PropHolds (z ≶ 0) -> StrongRightCancellation (.*.) z.
Proof.
intros. apply (strong_right_cancel_from_left (.*.)).
Qed.

Lemma mult_apart_zero_l x y : x * y ≶ 0 -> x ≶ 0.
Proof.
intros. apply (strong_extensionality (.* y)).
rewrite mult_0_l. trivial.
Qed.

Lemma mult_apart_zero_r x y : x * y ≶ 0 -> y ≶ 0.
Proof.
intros. apply (strong_extensionality (x *.)).
rewrite mult_0_r. trivial.
Qed.

Instance mult_apart_zero x y :
  PropHolds (x ≶ 0) -> PropHolds (y ≶ 0) -> PropHolds (x * y ≶ 0).
Proof.
intros Ex Ey.
apply (strong_extensionality (.* // (y;(Ey : (≶0) y)))).
rewrite <-simple_associativity, reciperse_alt, mult_1_r, mult_0_l.
trivial.
Qed.

Instance: NoZeroDivisors F.
Proof.
intros x [x_nonzero [y [y_nonzero E]]].
assert (~ ~ apart y 0) as Ey.
- intros E';apply y_nonzero,tight_apart,E'.
- apply Ey. intro y_apartzero.
  apply x_nonzero.
  rewrite <- (mult_1_r x). rewrite <- (reciperse_alt y y_apartzero).
  rewrite simple_associativity, E.
  apply mult_0_l.
Qed.

Global Instance : IsIntegralDomain F := {}.

Global Instance apart_0_sig_apart_0: forall (x : ApartZero F), PropHolds (x.1 ≶ 0).
Proof.
intros [??];trivial.
Qed.

Instance recip_apart_zero x : PropHolds (// x ≶ 0).
Proof.
red.
apply mult_apart_zero_r with (x.1).
rewrite recip_inverse. solve_propholds.
Qed.

Lemma field_div_0_l x y : x = 0 -> x // y = 0.
Proof.
intros E. rewrite E. apply left_absorb.
Qed.

Lemma field_div_diag x y : x = y.1 -> x // y = 1.
Proof.
intros E. rewrite E. apply recip_inverse.
Qed.

Lemma equal_quotients (a c: F) b d : a * d.1 = c * b.1 <-> a // b = c // d.
Proof.
split; intro E.
- rewrite <-(mult_1_l (a // b)),
  <- (recip_inverse d),
  (commutativity (f:=mult) d.1 (// d)),
  <-simple_associativity,
  (simple_associativity d.1),
  (commutativity (f:=mult) d.1 a),
  E,
  <-simple_associativity,
  simple_associativity,
  recip_inverse,
  mult_1_r.
  apply commutativity.
- rewrite <-(mult_1_r (a * d.1)),
  <- (recip_inverse b),
  <-simple_associativity,
  (commutativity (f:=mult) b.1 (// b)),
  (simple_associativity d.1),
  (commutativity (f:=mult) d.1),
  !simple_associativity,
  E,
  <-(simple_associativity c),
  (commutativity (f:=mult) (// d)),
  recip_inverse,
  mult_1_r.
  reflexivity.
Qed.

Lemma recip_distr_alt (x y : F) Px Py Pxy :
  // (x * y ; Pxy) = // (x;Px) * // (y;Py).
Proof.
apply (left_cancellation_ne_0 (.*.) (x * y)).
- apply apart_ne;trivial.
- transitivity ((x // (x;Px)) *  (y // (y;Py))).
  + rewrite 3!reciperse_alt,mult_1_r. reflexivity.
  + rewrite <-simple_associativity,<-simple_associativity.
    apply ap.
    rewrite simple_associativity.
    rewrite (commutativity (f:=mult) _ y).
    rewrite <-simple_associativity.
    reflexivity.
Qed.

Lemma apart_negate (x : F) (Px : x ≶ 0) : (-x) ≶ 0.
Proof.
  (* Have: x <> 0 *)
  (* Want to show: -x <> 0 *)
  (* Since x=x+0 <> 0=x-x, have x<>x or 0<>-x *)
  assert (ap : x + 0 ≶ x - x).
  {
    rewrite (plus_0_r x).
    rewrite (plus_negate_r x).
    assumption.
  }
  refine (Trunc_rec _ (field_plus_ext F x 0 x (-x) ap)).
  intros [apxx|ap0x].
  - destruct (apart_ne x x apxx); reflexivity.
  - symmetry; assumption.
Qed.
Definition negate_apart : ApartZero F -> ApartZero F.
Proof.
  intros [x Px].
  exists (-x).
  exact ((apart_negate x Px)).
Defined.
Lemma recip_negate (x : F) (Px : x ≶ 0) : (-//(x;Px))=//(negate_apart(x;Px)).
Proof.
  apply (left_cancellation (.*.) x).
  rewrite <- negate_mult_distr_r.
  rewrite reciperse_alt.
  apply flip_negate.
  rewrite negate_mult_distr_l.
  refine (_^).
  apply reciperse_alt.
Qed.
Lemma recip_apart (x : F) (Px : x ≶ 0) : // (x;Px) ≶ 0.
Proof.
  apply (strong_extensionality (x*.) (// (x; Px)) 0).
  rewrite (recip_inverse (x;Px)).
  rewrite mult_0_r.
  solve_propholds.
Qed.
Definition recip_on_apart (x : ApartZero F) : ApartZero F.
Proof.
  exists (//x).
  apply recip_apart.
Defined.
Global Instance recip_involutive: Involutive recip_on_apart.
Proof.
  intros [x apx0].
  apply path_sigma_hprop.
  unfold recip_on_apart.
  cbn.
  apply (left_cancellation (.*.) (// (x; apx0))).
  rewrite (recip_inverse' (// (x; apx0)) (recip_apart x apx0)).
  rewrite mult_comm.
  rewrite (recip_inverse (x;apx0)).
  reflexivity.
Qed.

End field_properties.

(* Due to bug #2528 *)
#[export]
Hint Extern 8 (PropHolds (// _ ≶ 0)) =>
  eapply @recip_apart_zero : typeclass_instances.
#[export]
Hint Extern 8 (PropHolds (_ * _ ≶ 0)) =>
  eapply @mult_apart_zero : typeclass_instances.

Section morphisms.
  Context `{IsField F1} `{IsField F2} `{!IsSemiRingStrongPreserving (f : F1 -> F2)}.

(*   Add Ring F1 : (stdlib_ring_theory F1). *)

  Lemma strong_injective_preserves_0 : (forall x, x ≶ 0 -> f x ≶ 0) -> IsStrongInjective f.
  Proof.
  intros E1. split; try apply _. intros x y E2.
  apply (strong_extensionality (+ -f y)).
  rewrite plus_negate_r, <-preserves_minus.
  apply E1.
  apply (strong_extensionality (+ y)).
  rewrite <-simple_associativity,left_inverse,plus_0_l,plus_0_r.
  trivial.
  Qed.

  (* We have the following for morphisms to non-trivial strong rings as well.
    However, since we do not have an interface for strong rings, we ignore it. *)
  Global Instance: IsStrongInjective f.
  Proof.
  apply strong_injective_preserves_0.
  intros x Ex.
  apply mult_apart_zero_l with (f (// exist (≶0) x Ex)).
  rewrite <-rings.preserves_mult.
  rewrite reciperse_alt.
  rewrite (rings.preserves_1 (f:=f)).
  solve_propholds.
  Qed.

  Lemma preserves_recip x Px Pfx : f (// (x;Px)) = // (f x;Pfx).
  Proof.
  apply (left_cancellation_ne_0 (.*.) (f x)).
  - apply apart_ne;trivial.
  - rewrite <-rings.preserves_mult.
    rewrite !reciperse_alt.
    apply preserves_1.
  Qed.
End morphisms.


Lemma Coq_03 : forall A B C D:Prop, (A -> C) /\ (B -> D) /\ A /\ B -> C /\ D.
intros.
destruct H.
destruct H0.
destruct H1.
split.
apply H.
apply H1.
apply H0.
apply H2.
Qed.