From Ordinal Require Import sflib Basics.
From Ordinal Require Export Ordinal Arithmetic.

Require Import ChoiceFacts.

Set Implicit Arguments.
Set Primitive Projections.

Section INACCESSIBLE.
  Let flip A B C (f: A -> B -> C): B -> A -> C := fun b a => f a b.

  Record inaccessible (X: Type) (base: Ord.t) (next: Ord.t -> Ord.t) (k: Ord.t): Prop :=
    mk_inaccessible
      { inaccessible_base: Ord.lt base k;
        inaccessible_next: forall o (LT: Ord.lt o k), Ord.lt (next o) k;
        inaccessible_join: forall (os: X -> Ord.t) (LT: forall a, Ord.lt (os a) k),
            Ord.lt (Ord.join os) k;
        inaccessible_union: forall o0 o1 (LT0: Ord.lt o0 k) (LT1: Ord.lt o1 k),
            Ord.lt (Ord.union o0 o1) k;
      }.

  Lemma inaccessible_mon X0 X1 base0 base1 next0 next1 k
        (SURJ: exists (f: X1 -> X0), forall x0, exists x1, f x1 = x0)
        (BASE: Ord.lt base0 k)
        (NEXT: forall o (LT: Ord.lt o k), Ord.le (next0 o) (next1 o))
        (INACCESSIBLE: inaccessible X1 base1 next1 k)
    :
      inaccessible X0 base0 next0 k.
  Proof.
    econs.
    { des; auto. }
    { i. eapply Ord.le_lt_lt; eauto.
      eapply INACCESSIBLE.(inaccessible_next). auto. }
    { i. des. eapply (@Ord.le_lt_lt (Ord.join (fun (x1: X1) => os (f x1)))).
      { eapply Ord.le_join. i. specialize (SURJ a0).
        des. subst. eexists. reflexivity. }
      { eapply INACCESSIBLE.(inaccessible_join). auto. }
    }
    { eapply INACCESSIBLE. }
  Qed.

  Record ginaccessible (X: Type) (base: Ord.t) (next: Ord.t -> Ord.t) (k: Ord.t): Prop :=
    mk_ginaccessible
      { ginaccessible_base: Ord.lt base k;
        ginaccessible_next: forall o (LT: Ord.lt o k), Ord.lt (next o) k;
        ginaccessible_join: forall (P: X -> Prop) (os: sig P -> Ord.t) (LT: forall a, Ord.lt (os a) k),
            Ord.lt (Ord.join os) k;
        ginaccessible_union: forall o0 o1 (LT0: Ord.lt o0 k) (LT1: Ord.lt o1 k),
            Ord.lt (Ord.union o0 o1) k;
      }.

  Lemma ginaccessible_inaccessible X base next k
        (INACCESSIBLE: ginaccessible X base next k)
    :
      inaccessible X base next k.
  Proof.
    econs; try by apply INACCESSIBLE. i.
    hexploit INACCESSIBLE.(ginaccessible_join).
    { instantiate (1:=fun (p: sig (fun _ => True)) => os (proj1_sig p)). ss. }
    i. eapply Ord.le_lt_lt; eauto.
    eapply Ord.le_join. i. exists (exist _ a0 I). reflexivity.
  Qed.

  Section TREE.
    Variable X: Type.

    Inductive tree: Type :=
    | tree_O
    | tree_S (tr: tree)
    | tree_join (trs: X -> tree)
    | tree_union (tr0 tr1: tree)
    .

    Definition tree_lt (tr0 tr1: tree): Prop :=
      match tr1 with
      | tree_O => False
      | tree_S tr => tr0 = tr
      | tree_join trs => exists x, tr0 = trs x
      | tree_union trl trr => tr0 = trl \/ tr0 = trr
      end.

    Lemma tree_lt_well_founded: well_founded tree_lt.
    Proof.
      ii. induction a.
      { econs. ii. ss. }
      { econs. i. ss. subst. auto. }
      { econs. i. ss. des. subst. auto. }
      { econs. i. ss. des; subst; auto. }
    Qed.

    Lemma tree_O_O: Ord.eq (Ord.from_wf tree_lt_well_founded tree_O) Ord.O.
    Proof.
      Local Transparent Ord.from_wf Ord.from_acc Ord.O.
      split.
      { unfold Ord.from_wf. destruct (tree_lt_well_founded tree_O).
        ss. econs. i. destruct a0. ss. }
      { eapply Ord.O_bot. }
    Qed.

    Lemma tree_S_S tr:
      Ord.eq (Ord.from_wf tree_lt_well_founded (tree_S tr)) (Ord.S (Ord.from_wf tree_lt_well_founded tr)).
    Proof.
      Local Transparent Ord.from_wf Ord.from_acc Ord.O Ord.S.
      split.
      { unfold Ord.from_wf at 1. destruct (tree_lt_well_founded (tree_S tr)).
        ss. econs. i. destruct a0. ss. subst. exists tt.
        ss. eapply Ord.same_acc_le.
      }
      { eapply Ord.S_supremum. eapply Ord.lt_from_wf. ss. }
    Qed.

    Lemma tree_join_build (trs: X -> tree):
      Ord.eq (Ord.from_wf tree_lt_well_founded (tree_join trs)) (Ord.build (fun x => Ord.from_wf tree_lt_well_founded (trs x))).
    Proof.
      split.
      { unfold Ord.from_wf at 1. destruct (tree_lt_well_founded (tree_join trs)).
        ss. econs. i. destruct a0. des. ss. subst. exists x0.
        ss. eapply Ord.same_acc_le.
      }
      { eapply Ord.build_supremum. i. eapply Ord.lt_from_wf. ss. eauto. }
    Qed.

    Lemma tree_union_union_le (tr0 tr1: tree):
      Ord.le (Ord.from_wf tree_lt_well_founded (tree_union tr0 tr1)) (Ord.S (Ord.union (Ord.from_wf tree_lt_well_founded tr0) (Ord.from_wf tree_lt_well_founded tr1))).
    Proof.
      unfold Ord.from_wf at 1. destruct (tree_lt_well_founded (tree_union tr0 tr1)).
      ss. econs. i. destruct a0. ss. exists tt. ss. des; subst.
      { transitivity (Ord.from_wf tree_lt_well_founded tr0).
        { eapply Ord.same_acc_le. }
        { eapply Ord.union_l. }
      }
      { transitivity (Ord.from_wf tree_lt_well_founded tr1).
        { eapply Ord.same_acc_le. }
        { eapply Ord.union_r. }
      }
    Qed.

    Lemma tree_union_union_le_rev (tr0 tr1: tree):
      Ord.le (Ord.union (Ord.from_wf tree_lt_well_founded tr0) (Ord.from_wf tree_lt_well_founded tr1)) (Ord.from_wf tree_lt_well_founded (tree_union tr0 tr1)).
    Proof.
      eapply Ord.union_spec.
      { eapply Ord.lt_le. eapply Ord.lt_from_wf. ss. auto. }
      { eapply Ord.lt_le. eapply Ord.lt_from_wf. ss. auto. }
    Qed.

    Definition tree_top := Ord.from_wf_set tree_lt_well_founded.

    Lemma inaccessible_rec_inaccessible (base0: Ord.t) (next: Ord.t -> Ord.t)
          (NEXTLE: forall o, Ord.le o (next o))
          (NEXTMON: forall o0 o1 (LE: Ord.le o0 o1), Ord.le (next o0) (next o1))
          (INACCESSIBLE: inaccessible X base0 next tree_top)
          base1
          (BASE1: Ord.lt base1 tree_top)
      :
        inaccessible X base0 (Ord.orec base1 next) tree_top.
    Proof.
      Local Transparent Ord.from_wf Ord.from_acc Ord.O Ord.S Ord.rec Ord.from_wf_set.
      econs; eauto.
      { eapply INACCESSIBLE. }
      2: { eapply INACCESSIBLE. }
      2: { eapply INACCESSIBLE. }
      assert (RECS: forall tr, Ord.lt (Ord.orec base1 next (Ord.from_wf tree_lt_well_founded tr)) tree_top).
      { induction tr.
        { eapply (@Ord.eq_lt_lt _ _ base1); auto.
          transitivity (Ord.orec base1 next Ord.O).
          { eapply Ord.eq_orec; auto. eapply tree_O_O. }
          { eapply Ord.orec_O; auto. }
        }
        { eapply (@Ord.eq_lt_lt _ _ (next (Ord.orec base1 next (Ord.from_wf tree_lt_well_founded tr)))).
          { transitivity (Ord.orec base1 next (Ord.S (Ord.from_wf tree_lt_well_founded tr))).
            { eapply Ord.eq_orec; auto. eapply tree_S_S. }
            { eapply Ord.orec_S; auto. }
          }
          { eapply INACCESSIBLE. auto. }
        }
        { eapply (@Ord.eq_lt_lt _ _ _).
          { etransitivity.
            { eapply Ord.eq_orec; auto. eapply tree_join_build. }
            { eapply Ord.orec_build. }
          }
          { eapply INACCESSIBLE; auto. eapply INACCESSIBLE. i.
            eapply INACCESSIBLE. auto. }
        }
        { eapply Ord.le_lt_lt.
          { eapply Ord.le_orec.
            { auto. }
            { eapply tree_union_union_le. }
          }
          eapply Ord.eq_lt_lt.
          { eapply Ord.orec_S; auto. }
          eapply INACCESSIBLE.
          eapply Ord.eq_lt_lt.
          { eapply Ord.orec_union; auto. }
          { eapply INACCESSIBLE; auto. }
        }
      }
      i. eapply Ord.lt_inv in LT. des. eapply (@Ord.le_lt_lt (Ord.orec base1 next (Ord.from_wf tree_lt_well_founded a))); auto.
      eapply Ord.le_orec; auto.
    Qed.

    Lemma tree_top_O
      :
        Ord.lt Ord.O tree_top.
    Proof.
      econs. instantiate (1:=tree_O). eapply Ord.O_bot.
    Qed.

    Lemma tree_top_S o (LT: Ord.lt o tree_top)
      :
        Ord.lt (Ord.S o) tree_top.
    Proof.
      i. eapply Ord.lt_inv in LT. des.
      econs. instantiate (1:=tree_S a).
      eapply Ord.S_supremum. eapply Ord.le_lt_lt; eauto.
      eapply Ord.lt_from_wf. ss.
    Qed.

    Lemma tree_top_union o0 o1 (LT0: Ord.lt o0 tree_top) (LT1: Ord.lt o1 tree_top)
      :
        Ord.lt (Ord.union o0 o1) tree_top.
    Proof.
      eapply Ord.lt_inv in LT0. eapply Ord.lt_inv in LT1. des.
      econs. instantiate (1:=tree_union a0 a). eapply Ord.union_spec.
      { etransitivity; eauto. eapply Ord.lt_le. eapply Ord.lt_from_wf. ss. auto. }
      { etransitivity; eauto. eapply Ord.lt_le. eapply Ord.lt_from_wf. ss. auto. }
    Qed.

    Hypothesis CHOICE: FunctionalChoice_on X tree.

    Lemma tree_top_join (os: X -> Ord.t) (LT: forall x, Ord.lt (os x) tree_top)
      :
        Ord.lt (Ord.join os) tree_top.
    Proof.
      i. hexploit (CHOICE (fun (x: X) (tr: tree) => Ord.le (os x) (Ord.from_wf tree_lt_well_founded tr))).
      { i. specialize (LT x). eapply Ord.lt_inv in LT. eauto. }
      i. des.
      econs. instantiate (1:=tree_join f).
      eapply Ord.join_supremum. i. etransitivity; eauto.
      eapply Ord.lt_le. eapply Ord.lt_from_wf. ss. eauto.
    Qed.

    Lemma tree_top_S_inaccessible
      :
        inaccessible X Ord.O Ord.S tree_top.
    Proof.
      econs.
      { eapply tree_top_O. }
      { eapply tree_top_S. }
      { eapply tree_top_join. }
      { eapply tree_top_union. }
    Qed.

    Lemma tree_top_add_inaccessible
          o (LT: Ord.lt o tree_top)
      :
        inaccessible X Ord.O (OrdArith.add o) tree_top.
    Proof.
      Local Transparent OrdArith.add.
      eapply inaccessible_rec_inaccessible; eauto.
      { i. eapply Ord.S_le. }
      { i. apply Ord.le_S. auto. }
      { eapply tree_top_S_inaccessible. }
    Qed.

    Lemma tree_top_add o0 o1 (LT0: Ord.lt o0 tree_top) (LT1: Ord.lt o1 tree_top)
      :
        Ord.lt (OrdArith.add o0 o1) tree_top.
    Proof.
      eapply tree_top_add_inaccessible; auto.
    Qed.

    Lemma tree_top_flip_add_inaccessible
          o (LT: Ord.lt o tree_top)
      :
        inaccessible X Ord.O (flip OrdArith.add o) tree_top.
    Proof.
      hexploit tree_top_add_inaccessible; eauto. i.
      econs; auto.
      { eapply Ord.le_lt_lt; eauto. eapply Ord.O_bot. }
      { i. eapply (@tree_top_add_inaccessible _ LT0).(inaccessible_next). auto. }
      { i. eapply H. auto. }
      { i. eapply H; auto. }
    Qed.

    Lemma tree_top_mult_inaccessible
          o (LT: Ord.lt o tree_top)
      :
        inaccessible X Ord.O (OrdArith.mult o) tree_top.
    Proof.
      Local Transparent OrdArith.mult.
      eapply inaccessible_rec_inaccessible; eauto.
      { i. eapply OrdArith.add_base_l. }
      { i. eapply OrdArith.le_add_l; auto. }
      { eapply tree_top_flip_add_inaccessible. auto. }
      { eapply Ord.le_lt_lt; eauto. eapply Ord.O_bot. }
    Qed.

    Lemma tree_top_mult o0 o1 (LT0: Ord.lt o0 tree_top) (LT1: Ord.lt o1 tree_top)
      :
        Ord.lt (OrdArith.mult o0 o1) tree_top.
    Proof.
      eapply tree_top_mult_inaccessible; auto.
    Qed.

    Lemma tree_top_flip_mult_inaccessible
          o (LT: Ord.lt o tree_top)
      :
        inaccessible X Ord.O (flip OrdArith.mult o) tree_top.
    Proof.
      hexploit tree_top_mult_inaccessible; eauto. i.
      econs; auto.
      { eapply Ord.le_lt_lt; eauto. eapply Ord.O_bot. }
      { i. eapply (@tree_top_mult_inaccessible _ LT0).(inaccessible_next). auto. }
      { i. eapply H. auto. }
      { i. eapply H; auto. }
    Qed.

    Lemma tree_top_expn_inaccessible
          o (POS: Ord.lt Ord.O o) (LT: Ord.lt o tree_top)
      :
        inaccessible X Ord.O (OrdArith.expn o) tree_top.
    Proof.
      Local Transparent OrdArith.expn.
      eapply inaccessible_rec_inaccessible; eauto.
      { i. unfold flip. eapply OrdArith.mult_le_l. auto. }
      { i. eapply OrdArith.le_mult_l. auto. }
      { eapply tree_top_flip_mult_inaccessible. auto. }
      { eapply tree_top_S. eapply tree_top_O. }
    Qed.

    Lemma tree_top_expn o0 o1 (LT0: Ord.lt o0 tree_top) (LT1: Ord.lt o1 tree_top)
      :
        Ord.lt (OrdArith.expn o0 o1) tree_top.
    Proof.
      eapply (@Ord.le_lt_lt (OrdArith.expn (Ord.S o0) o1)).
      { eapply OrdArith.le_expn_l. eapply Ord.S_le. }
      { eapply tree_top_expn_inaccessible; auto.
        { eapply Ord.S_pos. }
        { eapply tree_top_S. auto. }
      }
    Qed.

    Lemma tree_top_flip_expn_inaccessible
          o (LT: Ord.lt o tree_top)
      :
        inaccessible X Ord.O (flip OrdArith.expn o) tree_top.
    Proof.
      econs.
      { eapply tree_top_O. }
      { i. eapply tree_top_expn; auto. }
      { eapply tree_top_join. }
      { eapply tree_top_union. }
    Qed.
  End TREE.

  Section GTREE.
    Variable X: Type.

    Inductive gtree: Type :=
    | gtree_O
    | gtree_S (tr: gtree)
    | gtree_join (P: X -> Prop) (trs: sig P -> gtree)
    | gtree_union (tr0 tr1: gtree)
    .

    Definition gtree_lt (tr0 tr1: gtree): Prop :=
      match tr1 with
      | gtree_O => False
      | gtree_S tr => tr0 = tr
      | gtree_join trs => exists x, tr0 = trs x
      | gtree_union trl trr => tr0 = trl \/ tr0 = trr
      end.

    Lemma gtree_lt_well_founded: well_founded gtree_lt.
    Proof.
      ii. induction a.
      { econs. ii. ss. }
      { econs. i. ss. subst. auto. }
      { econs. i. ss. des. subst. auto. }
      { econs. i. ss. des; subst; auto. }
    Qed.

    Lemma gtree_O_O: Ord.eq (Ord.from_wf gtree_lt_well_founded gtree_O) Ord.O.
    Proof.
      Local Transparent Ord.from_wf Ord.from_acc Ord.O Ord.S Ord.rec Ord.from_wf_set.
      split.
      { unfold Ord.from_wf. destruct (gtree_lt_well_founded gtree_O).
        ss. econs. i. destruct a0. ss. }
      { eapply Ord.O_bot. }
    Qed.

    Lemma gtree_S_S tr:
      Ord.eq (Ord.from_wf gtree_lt_well_founded (gtree_S tr)) (Ord.S (Ord.from_wf gtree_lt_well_founded tr)).
    Proof.
      split.
      { unfold Ord.from_wf at 1. destruct (gtree_lt_well_founded (gtree_S tr)).
        ss. econs. i. destruct a0. ss. subst. exists tt.
        ss. eapply Ord.same_acc_le.
      }
      { eapply Ord.S_supremum. eapply Ord.lt_from_wf. ss. }
    Qed.

    Lemma gtree_join_build P (trs: sig P -> gtree):
      Ord.eq (Ord.from_wf gtree_lt_well_founded (gtree_join trs)) (Ord.build (fun x => Ord.from_wf gtree_lt_well_founded (trs x))).
    Proof.
      split.
      { unfold Ord.from_wf at 1. destruct (gtree_lt_well_founded (gtree_join trs)).
        ss. econs. i. destruct a0. des. ss. subst. exists x0.
        ss. eapply Ord.same_acc_le.
      }
      { eapply Ord.build_supremum. i. eapply Ord.lt_from_wf. ss. eauto. }
    Qed.

    Lemma gtree_union_union_le (tr0 tr1: gtree):
      Ord.le (Ord.from_wf gtree_lt_well_founded (gtree_union tr0 tr1)) (Ord.S (Ord.union (Ord.from_wf gtree_lt_well_founded tr0) (Ord.from_wf gtree_lt_well_founded tr1))).
    Proof.
      unfold Ord.from_wf at 1. destruct (gtree_lt_well_founded (gtree_union tr0 tr1)).
      ss. econs. i. destruct a0. ss. exists tt. ss. des; subst.
      { transitivity (Ord.from_wf gtree_lt_well_founded tr0).
        { eapply Ord.same_acc_le. }
        { eapply Ord.union_l. }
      }
      { transitivity (Ord.from_wf gtree_lt_well_founded tr1).
        { eapply Ord.same_acc_le. }
        { eapply Ord.union_r. }
      }
    Qed.

    Lemma gtree_union_union_le_rev (tr0 tr1: gtree):
      Ord.le (Ord.union (Ord.from_wf gtree_lt_well_founded tr0) (Ord.from_wf gtree_lt_well_founded tr1)) (Ord.from_wf gtree_lt_well_founded (gtree_union tr0 tr1)).
    Proof.
      eapply Ord.union_spec.
      { eapply Ord.lt_le. eapply Ord.lt_from_wf. ss. auto. }
      { eapply Ord.lt_le. eapply Ord.lt_from_wf. ss. auto. }
    Qed.

    Definition gtree_top := Ord.from_wf_set gtree_lt_well_founded.

    Lemma ginaccessible_rec_ginaccessible (base0: Ord.t) (next: Ord.t -> Ord.t)
          (NEXTLE: forall o, Ord.le o (next o))
          (NEXTMON: forall o0 o1 (LE: Ord.le o0 o1), Ord.le (next o0) (next o1))
          (INACCESSIBLE: ginaccessible X base0 next gtree_top)
          base1
          (BASE1: Ord.lt base1 gtree_top)
      :
        ginaccessible X base0 (Ord.orec base1 next) gtree_top.
    Proof.
      econs; eauto.
      { eapply INACCESSIBLE. }
      2: { eapply INACCESSIBLE. }
      2: { eapply INACCESSIBLE. }
      assert (RECS: forall tr, Ord.lt (Ord.orec base1 next (Ord.from_wf gtree_lt_well_founded tr)) gtree_top).
      { induction tr.
        { eapply (@Ord.eq_lt_lt _ _ base1); auto.
          transitivity (Ord.orec base1 next Ord.O).
          { eapply Ord.eq_orec; auto. eapply gtree_O_O. }
          { eapply Ord.orec_O; auto. }
        }
        { eapply (@Ord.eq_lt_lt _ _ (next (Ord.orec base1 next (Ord.from_wf gtree_lt_well_founded tr)))).
          { transitivity (Ord.orec base1 next (Ord.S (Ord.from_wf gtree_lt_well_founded tr))).
            { eapply Ord.eq_orec; auto. eapply gtree_S_S. }
            { eapply Ord.orec_S; auto. }
          }
          { eapply INACCESSIBLE. auto. }
        }
        { eapply (@Ord.eq_lt_lt _ _ _).
          { etransitivity.
            { eapply Ord.eq_orec; auto. eapply gtree_join_build. }
            { eapply Ord.orec_build. }
          }
          { eapply INACCESSIBLE; auto. eapply INACCESSIBLE. i.
            eapply INACCESSIBLE. auto. }
        }
        { eapply Ord.le_lt_lt.
          { eapply Ord.le_orec.
            { auto. }
            { eapply gtree_union_union_le. }
          }
          eapply Ord.eq_lt_lt.
          { eapply Ord.orec_S; auto. }
          eapply INACCESSIBLE.
          eapply Ord.eq_lt_lt.
          { eapply Ord.orec_union; auto. }
          { eapply INACCESSIBLE; auto. }
        }
      }
      i. eapply Ord.lt_inv in LT. des. eapply (@Ord.le_lt_lt (Ord.orec base1 next (Ord.from_wf gtree_lt_well_founded a))); auto.
      eapply Ord.le_orec; auto.
    Qed.

    Lemma gtree_top_O
      :
        Ord.lt Ord.O gtree_top.
    Proof.
      econs. instantiate (1:=gtree_O). eapply Ord.O_bot.
    Qed.

    Lemma gtree_top_S o (LT: Ord.lt o gtree_top)
      :
        Ord.lt (Ord.S o) gtree_top.
    Proof.
      i. eapply Ord.lt_inv in LT. des.
      econs. instantiate (1:=gtree_S a).
      eapply Ord.S_supremum. eapply Ord.le_lt_lt; eauto.
      eapply Ord.lt_from_wf. ss.
    Qed.

    Lemma gtree_top_union o0 o1 (LT0: Ord.lt o0 gtree_top) (LT1: Ord.lt o1 gtree_top)
      :
        Ord.lt (Ord.union o0 o1) gtree_top.
    Proof.
      eapply Ord.lt_inv in LT0. eapply Ord.lt_inv in LT1. des.
      econs. instantiate (1:=gtree_union a0 a). eapply Ord.union_spec.
      { etransitivity; eauto. eapply Ord.lt_le. eapply Ord.lt_from_wf. ss. auto. }
      { etransitivity; eauto. eapply Ord.lt_le. eapply Ord.lt_from_wf. ss. auto. }
    Qed.

    Hypothesis CHOICE: forall (P: X -> Prop), FunctionalChoice_on (sig P) gtree.

    Lemma gtree_top_join (P: X -> Prop) (os: sig P -> Ord.t)
          (LT: forall x, Ord.lt (os x) gtree_top)
      :
        Ord.lt (Ord.join os) gtree_top.
    Proof.
      i. hexploit (CHOICE (fun (x: sig P) (tr: gtree) => Ord.le (os x) (Ord.from_wf gtree_lt_well_founded tr))).
      { i. specialize (LT x). eapply Ord.lt_inv in LT. eauto. }
      i. des.
      econs. instantiate (1:=gtree_join f).
      eapply Ord.join_supremum. i. etransitivity; eauto.
      eapply Ord.lt_le. eapply Ord.lt_from_wf. ss. eauto.
    Qed.

    Lemma gtree_top_S_ginaccessible
      :
        ginaccessible X Ord.O Ord.S gtree_top.
    Proof.
      econs.
      { eapply gtree_top_O. }
      { eapply gtree_top_S. }
      { eapply gtree_top_join. }
      { eapply gtree_top_union. }
    Qed.

    Lemma gtree_top_add_ginaccessible
          o (LT: Ord.lt o gtree_top)
      :
        ginaccessible X Ord.O (OrdArith.add o) gtree_top.
    Proof.
      Local Transparent OrdArith.add.
      eapply ginaccessible_rec_ginaccessible; eauto.
      { i. eapply Ord.S_le. }
      { i. apply Ord.le_S. auto. }
      { eapply gtree_top_S_ginaccessible. }
    Qed.

    Lemma gtree_top_add o0 o1 (LT0: Ord.lt o0 gtree_top) (LT1: Ord.lt o1 gtree_top)
      :
        Ord.lt (OrdArith.add o0 o1) gtree_top.
    Proof.
      eapply gtree_top_add_ginaccessible; auto.
    Qed.

    Lemma gtree_top_flip_add_ginaccessible
          o (LT: Ord.lt o gtree_top)
      :
        ginaccessible X Ord.O (flip OrdArith.add o) gtree_top.
    Proof.
      hexploit gtree_top_add_ginaccessible; eauto. i.
      econs; auto.
      { eapply Ord.le_lt_lt; eauto. eapply Ord.O_bot. }
      { i. eapply (@gtree_top_add_ginaccessible _ LT0).(ginaccessible_next). auto. }
      { i. eapply H. auto. }
      { i. eapply H; auto. }
    Qed.

    Lemma gtree_top_mult_ginaccessible
          o (LT: Ord.lt o gtree_top)
      :
        ginaccessible X Ord.O (OrdArith.mult o) gtree_top.
    Proof.
      Local Transparent OrdArith.mult.
      eapply ginaccessible_rec_ginaccessible; eauto.
      { i. eapply OrdArith.add_base_l. }
      { i. eapply OrdArith.le_add_l; auto. }
      { eapply gtree_top_flip_add_ginaccessible. auto. }
      { eapply Ord.le_lt_lt; eauto. eapply Ord.O_bot. }
    Qed.

    Lemma gtree_top_mult o0 o1 (LT0: Ord.lt o0 gtree_top) (LT1: Ord.lt o1 gtree_top)
      :
        Ord.lt (OrdArith.mult o0 o1) gtree_top.
    Proof.
      eapply gtree_top_mult_ginaccessible; auto.
    Qed.

    Lemma gtree_top_flip_mult_ginaccessible
          o (LT: Ord.lt o gtree_top)
      :
        ginaccessible X Ord.O (flip OrdArith.mult o) gtree_top.
    Proof.
      hexploit gtree_top_mult_ginaccessible; eauto. i.
      econs; auto.
      { eapply Ord.le_lt_lt; eauto. eapply Ord.O_bot. }
      { i. eapply (@gtree_top_mult_ginaccessible _ LT0).(ginaccessible_next). auto. }
      { i. eapply H. auto. }
      { i. eapply H; auto. }
    Qed.

    Lemma gtree_top_expn_ginaccessible
          o (POS: Ord.lt Ord.O o) (LT: Ord.lt o gtree_top)
      :
        ginaccessible X Ord.O (OrdArith.expn o) gtree_top.
    Proof.
      Local Transparent OrdArith.expn.
      eapply ginaccessible_rec_ginaccessible; eauto.
      { i. unfold flip. eapply OrdArith.mult_le_l. auto. }
      { i. eapply OrdArith.le_mult_l. auto. }
      { eapply gtree_top_flip_mult_ginaccessible. auto. }
      { eapply gtree_top_S. eapply gtree_top_O. }
    Qed.

    Lemma gtree_top_expn o0 o1 (LT0: Ord.lt o0 gtree_top) (LT1: Ord.lt o1 gtree_top)
      :
        Ord.lt (OrdArith.expn o0 o1) gtree_top.
    Proof.
      eapply (@Ord.le_lt_lt (OrdArith.expn (Ord.S o0) o1)).
      { eapply OrdArith.le_expn_l. eapply Ord.S_le. }
      { eapply gtree_top_expn_ginaccessible; auto.
        { eapply Ord.S_pos. }
        { eapply gtree_top_S. auto. }
      }
    Qed.

    Lemma gtree_top_flip_expn_ginaccessible
          o (LT: Ord.lt o gtree_top)
      :
        ginaccessible X Ord.O (flip OrdArith.expn o) gtree_top.
    Proof.
      econs.
      { eapply gtree_top_O. }
      { i. eapply gtree_top_expn; auto. }
      { eapply gtree_top_join. }
      { eapply gtree_top_union. }
    Qed.
  End GTREE.
End INACCESSIBLE.


Require Import Coq.ZArith.ZArith coqutil.Z.div_mod_to_equations.
Require Import bedrock2.NotationsCustomEntry.
Import Syntax BinInt String List.ListNotations ZArith.
Require Import coqutil.Z.Lia.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope.

Definition ipow :=
  ("ipow", (["x";"e"], (["ret"]:list String.string), bedrock_func_body:(
  ret = $1;
  while (e) {
    if (e & $1) { ret = ret * x };
    e = e >> $1;
    x = x * x
  }
))).

From bedrock2 Require Import Semantics BasicC64Semantics WeakestPrecondition ProgramLogic.
From coqutil Require Import Word.Properties Word.Interface Tactics.letexists.

#[global] Instance spec_of_ipow : spec_of "ipow" := fun functions =>
  forall x e t m,
    WeakestPrecondition.call functions
      "ipow" t m [x; e]
      (fun t' m' rets => t=t'/\ m=m' /\ exists v, rets = [v] /\ (
        word.unsigned v = word.unsigned x ^ word.unsigned e mod 2^64)).

Module Z.
  Lemma pow_mod x n m (Hnz: m <> 0) : (x mod m)^n mod m = x^n mod m.
  Proof.
    revert n.
    eapply Z.order_induction_0; intros.
    { intros ???; subst; split; auto. }
    { rewrite 2Z.pow_0_r; trivial. }
    { rewrite 2Z.pow_succ_r by trivial.
      rewrite <-Z.mul_mod_idemp_r by trivial.
      multimatch goal with H: _ |- _ => rewrite H end;
      rewrite Z.mul_mod_idemp_l, Z.mul_mod_idemp_r; solve[trivial]. }
    { rewrite 2Z.pow_neg_r; trivial. }
  Qed.

  Lemma mod2_nonzero x : x mod 2 <> 0 -> x mod 2 = 1.
  Proof. Z.div_mod_to_equations. blia. Qed.

  Lemma land_1_r x : Z.land x 1 = x mod 2.
  Proof.
    change 1 with (Z.ones 1) in *.
    rewrite Z.land_ones in * by discriminate.
    exact eq_refl.
  Qed.
End Z.

Require Import bedrock2.AbsintWordToZ coqutil.Z.Lia.

Ltac t :=
  repeat match goal with x := _ |- _ => subst x end;
  repeat match goal with |- context [word.unsigned ?e] => progress (idtac; let H := rbounded (word.unsigned e) in idtac) end;
  repeat match goal with G: context [word.unsigned ?e] |- _ => progress (idtac; let H := rbounded (word.unsigned e) in idtac) end;
  repeat match goal with |- context [word.unsigned ?e] => progress (idtac; let H := unsigned.zify_expr e in try rewrite H) end;
  repeat match goal with G: context [word.unsigned ?e] |- _ => progress (idtac; let H := unsigned.zify_expr e in try rewrite H in G) end;
  repeat match goal with H: absint_eq ?x ?x |- _ => clear H end;
  cbv [absint_eq] in *.

Lemma ipow_ok : program_logic_goal_for_function! ipow.
Proof.
  repeat straightline.

  refine ((Loops.tailrec
    (* types of ghost variables*) HList.polymorphic_list.nil
    (* program variables *) (["e";"ret";"x"] : list String.string))
    (fun v t m e ret x => PrimitivePair.pair.mk (v = word.unsigned e) (* precondition *)
    (fun   T M E RET X => T = t /\ M = m /\ (* postcondition *)
        word.unsigned RET = word.unsigned ret * word.unsigned x ^ word.unsigned e mod 2^64))
    (fun n m => 0 <= n < m) (* well_founded relation *)
    _ _ _ _ _);
    (* TODO wrap this into a tactic with the previous refine *)
    cbn [HList.hlist.foralls HList.tuple.foralls
         HList.hlist.existss HList.tuple.existss
         HList.hlist.apply  HList.tuple.apply
         HList.hlist
         List.repeat Datatypes.length
         HList.polymorphic_list.repeat HList.polymorphic_list.length
         PrimitivePair.pair._1 PrimitivePair.pair._2] in *.

  { repeat straightline. }
  { exact (Z.lt_wf _). }
  { repeat straightline. } (* init precondition *)
  { (* loop test *)
    repeat straightline; try show_program.
    { (* loop body *)
      letexists; split; [repeat straightline|]. (* if condition evaluation *)
      split. (* if cases, path-blasting *)
      {
        repeat (straightline || (split; trivial; [])). all:t.
        { (* measure decreases *)
          set (word.unsigned x0) in *. (* WHY does blia need this? *)
          Z.div_mod_to_equations; blia. }
        { (* invariant preserved *)
          rewrite H3; clear H3. rename H0 into Hbit.
          change (1+1) with 2 in *.
          eapply Z.mod2_nonzero in Hbit.
          epose proof (Z.div_mod _ 2 ltac:(discriminate)) as Heq; rewrite Hbit in Heq.
          rewrite Heq at 2; clear Hbit Heq.
          (* rewriting with equivalence modulo ... *)
          rewrite !word.unsigned_mul.
          unfold word.wrap.
          rewrite ?Z.mul_mod_idemp_l by discriminate.
          rewrite <-(Z.mul_mod_idemp_r _ (_^_)), Z.pow_mod by discriminate.
          rewrite ?Z.pow_add_r by (pose proof word.unsigned_range x0; Z.div_mod_to_equations; blia).
          rewrite ?Z.pow_twice_r, ?Z.pow_1_r, ?Z.pow_mul_l.
          rewrite Z.mul_mod_idemp_r by discriminate.
          f_equal; ring. } }
      {
        repeat (straightline || (split; trivial; [])).
        all: t.
        { (* measure decreases *)
          set (word.unsigned x0) in *. (* WHY does blia need this? *)
          Z.div_mod_to_equations; blia. }
        { (* invariant preserved *)
          rewrite H3; clear H3. rename H0 into Hbit.
          change (1+1) with 2 in *.
          epose proof (Z.div_mod _ 2 ltac:(discriminate)) as Heq; rewrite Hbit in Heq.
          rewrite Heq at 2; clear Hbit Heq.
          (* rewriting with equivalence modulo ... *)
          rewrite !word.unsigned_mul, ?Z.mul_mod_idemp_l by discriminate.
          cbv [word.wrap].
          rewrite <-(Z.mul_mod_idemp_r _ (_^_)), Z.pow_mod by discriminate.
          rewrite ?Z.add_0_r, Z.pow_twice_r, ?Z.pow_1_r, ?Z.pow_mul_l.
          rewrite Z.mul_mod_idemp_r by discriminate.
          f_equal; ring. } } }
    { (* postcondition *) rewrite H, Z.pow_0_r, Z.mul_1_r, word.wrap_unsigned; auto. } }

  repeat straightline.

  repeat (split || letexists || t || trivial).
  setoid_rewrite H1; setoid_rewrite Z.mul_1_l; trivial.
Defined.


(** * SfLib: Software Foundations Library *)

(* $Date: 2013-01-16 22:29:57 -0500 (Wed, 16 Jan 2013) $ *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

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

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  (* Case "b = true". *)
    reflexivity.
  (* Case "b = false". *)
    rewrite <- H. reflexivity.  Qed.

(* From Poly.v *)

Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem O_le_n : forall n,
  0 <= n.
Proof.
  induction n as [| n'].
  (* Case "n = 0". *) apply le_n.
  (* Case "n = S n'". *) apply le_S. apply IHn'.
Qed.

Theorem n_le_m__Sn_le_Sm : forall n m,
  n <= m -> S n <= S m.
Proof.
  intros. induction H as [| m'].
  (* Case "H = n <= n". *) apply le_n.
  (* Case "H = n <= S m'". *) apply le_S in IHle. apply IHle.
Qed.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
Proof.
  intros. generalize dependent m.
  induction n as [| n'];
    intros.
  (* Case "n = 0". *) apply O_le_n.
  (* Case "n = S n'". *) destruct m. inversion H.
    simpl in H. apply n_le_m__Sn_le_Sm. apply IHn'. apply H.
Qed.

Lemma ble_nat_true_iff : forall n m : nat,
  ble_nat n m = true <-> n <= m.
Proof.
  intros n m. split. apply ble_nat_true.
  generalize dependent m. induction n; intros m H. reflexivity.
    simpl. destruct m. inversion H.
    apply le_S_n in H. apply IHn. assumption.
Qed.

Theorem false_beq_nat : forall n m : nat,
     n <> m ->
     beq_nat n m = false.
Proof.
  intros. generalize dependent m.
  induction n;
    intros;
      unfold not in H;
        destruct m;
          simpl.
  destruct H. reflexivity.
  reflexivity.
  reflexivity.
  apply IHn. unfold not.
  intros H'. apply H.
  rewrite H'. reflexivity.
Qed.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

Definition relation (X:Type) := X -> X -> Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | multi_refl  : forall (x : X),
                 multi X R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi X R y z ->
                    multi X R x z.
Arguments multi {X} _.

(* Tactic Notation "multi_cases" tactic(first) ident(c) := *)
(*   first; *)
(*   [ Case_aux c "multi_refl" | Case_aux c "multi_step" ]. *)

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.   Qed.

(* Identifiers and polymorphic partial maps. *)
Inductive id : Type :=
  Id : nat -> id.

Definition beq_id id1 id2 :=
  match (id1, id2) with
    (Id n1, Id n2) => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall i,
  true = beq_id i i.
Proof.
  intros. destruct i.
  apply beq_nat_refl.  Qed.

Theorem beq_id_eq : forall i1 i2,
  true = beq_id i1 i2 -> i1 = i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_eq in H. subst.
  reflexivity.  Qed.

Theorem beq_id_false_not_eq : forall i1 i2,
  beq_id i1 i2 = false -> i1 <> i2.
Proof.
  intros i1 i2 H.
  destruct i1. destruct i2.
  apply beq_nat_false in H.
  intros C. apply H. inversion C. reflexivity.  Qed.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if beq_id x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite <- beq_id_refl. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  beq_id x2 x1 = false ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite H. auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (beq_id x2 x1)...
Qed.

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.


Require Import HoTT.

From GCTT
     Require Import equiv_lemmas sigma_lemmas finite_types finite.permutations monoidal_1type.

(** Defining the monoidal 1-type of finite sets*)
Section FinType.

  (** This type is equivalent to the path groupoid of the category BSym
of finite sets and isomorphisms*)
  Record FinType :=
    {card_FinType : nat ; fintype_of_FinType :> Finite_Types card_FinType}.
    (* {m : nat & Finite_Types m}. *)
    (* { S : Type & Finite S}. *)

  Definition issig_FinType :
    FinType <~> {A : Type & Finite A}.
  Proof.
    srapply @equiv_adjointify.
    - intros [n A]. exists A. exact _.
    - intros [A [n e]]. exact (Build_FinType n (A; e)).
    - intros [A [n e]]. simpl.
      apply path_sigma_hprop. reflexivity.
    - intros [n A]. simpl. reflexivity.
  Defined.

  Global Instance istrunc_FinType : IsTrunc 1 FinType.
  Proof.
    apply (trunc_equiv' {S : Type & Finite S}).
    - apply equiv_inverse. apply issig_FinType.
    - apply trunc_sigma'.
      +  intro A. exact _.
      +  intros A B.
         srapply @istrunc_paths_Type.
         apply isset_Finite. exact B.2.
  Defined.

  Definition fin_to_FinType {n : nat}
    : Finite_Types n -> FinType
    := Build_FinType n.

  Definition FinType_to_Type : FinType -> Type.
  Proof.
    intros [a [A p]]. exact A.
  Defined.

  (** Canonical objects in FinType*)
  Definition canon_FinType (n : nat) : FinType := fin_to_FinType (canon n).

  Lemma finite_types_eqcard {m n : nat} (A : Finite_Types m) (B : Finite_Types n) :
    A <~> B -> m = n.
  Proof.
    destruct A as [A fA]. destruct B as [B fB]. simpl. intro e.
    strip_truncations.
    apply nat_eq_fin_equiv.
    exact (fB oE e oE (equiv_inverse fA)).
  Qed.

  (** Describing the path types in FinType.  *)
  Definition inv_path_FinType {A B : FinType}
    : A = B -> A <~> B.
  Proof.
    intros []. exact equiv_idmap.
  Defined.

  Definition equiv_path_FinType (A B : FinType) :
    (A <~> B) <~> A = B.
  Proof.
    refine ((equiv_ap issig_FinType A B)^-1 oE _).
    exact (equiv_path_finite_types' (issig_FinType A) (issig_FinType B) ).
  Defined.

  (** Extra lemma to connect to how it is presented in thesis.*)
  Lemma isembedding_FinType_to_Type :
    forall A B : FinType, IsEquiv(@ap _ _ FinType_to_Type A B).
  Proof.
    intros.
    assert
      (rw : (@ap _ _ FinType_to_Type A B) = ((equiv_path_universe _ _ oE equiv_inverse (equiv_path_FinType A B)))).
    { apply path_arrow. simpl.
      intro p. unfold path_universe_uncurried.
      destruct p.  simpl. apply inverse.
      apply eissect. }
    rewrite rw. exact _.
  Qed.

  Definition inv_equiv_path_FinType (A B : FinType) :
    (equiv_inverse (equiv_path_FinType A B)) == inv_path_FinType.
  Proof.
    intros []. reflexivity.
  Defined.

  Definition path_FinType (A B : FinType) : A <~> B -> A = B
    := equiv_path_FinType A B.

  Definition path_FinType_1 (A : FinType) :
    path_FinType _ _ (equiv_idmap A) = idpath.
  Proof.
    unfold path_FinType. unfold equiv_path_FinType. ev_equiv.
    apply moveR_equiv_V. unfold equiv_path_finite_types'. ev_equiv.
    apply moveR_equiv_M. simpl.
    apply (moveR_equiv_M (f := equiv_path_universe _ _)). reflexivity.
  Defined.

  Definition path_FinType_V {A B : FinType} (e : A <~> B)
    : (path_FinType _ _ e)^ = path_FinType _ _ (equiv_inverse e).
  Proof.
    refine (_ @ ap (fun g => path_FinType B A (equiv_inverse g)) (eissect (@path_FinType A B) e)).
    generalize (path_FinType A B e).  intros [].
    simpl. apply inverse.
    refine (_ @ path_FinType_1 A).
    apply (ap (path_FinType _ _)).
    apply path_equiv. simpl.  reflexivity.
  Defined.

  Definition pft_to_pbs {m : nat} {A B : Finite_Types m}
    : A = B -> (fin_to_FinType A) = (fin_to_FinType B)
    := ap (fin_to_FinType).

  Definition path_FinType_fix {m : nat} (A B : Finite_Types m) (e : A <~> B)
    : pft_to_pbs (path_finite_types m A B e)
      = @path_FinType (fin_to_FinType A) (fin_to_FinType B) e.
  Proof.
    refine (_ @ ap (@path_FinType
                      (fin_to_FinType _)
                      (fin_to_FinType _))
              (eissect (path_finite_types m A B) e)).
    generalize (path_finite_types m A B e).
    intros []. simpl.
    refine ((path_FinType_1 _)^).
  Defined.

  Global Instance isequiv_pft_to_pbs {m : nat} {A B : Finite_Types m}
    : IsEquiv (@pft_to_pbs m A B).
  Proof.
    assert (H : @pft_to_pbs m A B
            = equiv_path_FinType
                (fin_to_FinType A) (fin_to_FinType B)
                oE (equiv_path_finite_types m A B)^-1).
    { apply path_arrow. intros []. ev_equiv.
      apply inverse.
      refine (path_FinType_1 _). }
    rewrite H.
    apply equiv_isequiv.
  Qed.

  (** path_FinType respects composition *)
  Definition path_FinType_compose {A B C : FinType} (e1 : A <~> B) (e2 : B <~> C) :
    path_FinType _ _ (e2 oE e1) = path_FinType _ _ e1 @ path_FinType _ _ e2.
  Proof.
    refine
      (ap011 (fun g1 g2 => path_FinType A C (g2 oE g1))
             (eissect (path_FinType A B) e1)^ (eissect (path_FinType B C) e2)^ @ _).
    generalize (path_FinType _ _ e2). intros [].
    generalize (path_FinType _ _ e1). intros []. simpl.
    refine (path_FinType_1 A).
  Qed.

  Definition sum_FinType : FinType -> FinType -> FinType.
  Proof.
    intros [m A] [n B].
    exact (fin_to_FinType (sum_finite_types A B)).
  Defined.

  Definition FinType_id : FinType := canon_FinType 0.

  Local Notation "S1 ⊕ S2" := (sum_FinType S1 S2) (at level 50, no associativity).

  (** path_FinType behaves well with respect to sum *)
  Lemma path_FinType_sum (A1 A2 B1 B2 : FinType)
        (e1 : A1 <~> B1) (e2  : A2 <~> B2)
    : path_FinType (sum_FinType A1 A2) (sum_FinType B1 B2) (e1 +E e2)
      = ap011 sum_FinType (path_FinType _ _ e1) (path_FinType _ _ e2).
  Proof.
    rewrite (ap011 equiv_functor_sum'
                   (eissect (equiv_path_FinType A1 B1) e1)^ (eissect (equiv_path_FinType A2 B2) e2)^).
    change ((equiv_path_FinType ?A ?B) ?e) with (path_FinType A B e).
    destruct (path_FinType A1 B1 e1). destruct (path_FinType A2 B2 e2).
    simpl.
    refine (_ @ path_FinType_1 _).
    apply (ap (path_FinType _ _)).
    apply path_equiv. apply path_arrow.
    intros [a | a]; reflexivity.
  Defined.

  Definition finsum_id (m n : nat) :
    sum_FinType (canon_FinType m) (canon_FinType n) = canon_FinType (n+m)
    :=  path_FinType (sum_FinType (canon_FinType m) (canon_FinType n)) (canon_FinType (n+m))
                     (equiv_finsum m n).

  Definition finsum_id_fix (m n : nat)
    : sum_finite_types (canon m) (canon n) = canon (n + m)
    := path_finite_types _ (sum_finite_types (canon m) (canon n)) (canon (n+m)) (equiv_finsum m n).

  Definition path_FinType_blocksum {a b : nat}
             (alpha : canon_FinType a <~> canon_FinType a)
             (betta : canon_FinType b <~> canon_FinType b)
    : path_FinType (canon_FinType (a +' b)) (canon_FinType (a +' b)) (block_sum alpha betta) =
      (finsum_id a b)^ @ (ap011 sum_FinType (path_FinType _ _ alpha) (path_FinType _ _ betta) @
                                finsum_id a b).
  Proof.
    unfold finsum_id.
    rewrite <- path_FinType_sum.
    rewrite path_FinType_V.
    rewrite <- path_FinType_compose. rewrite <- path_FinType_compose.
    reflexivity.
  Defined.

  Definition natural_path_FinType_l {S1 S2 S3: FinType} (e : S1 <~> S2)
    : ap (fun x : FinType => x ⊕ S3) (path_FinType _ _ e)
    = path_FinType (S1 ⊕ S3) (S2 ⊕ S3) (equiv_functor_sum_r (B := S3) e).
  Proof.
    refine (_ @ ap (fun e' => @path_FinType (S1⊕ S3) (S2 ⊕ S3) (equiv_functor_sum_r e'))
              (eissect (@path_FinType S1 S2) e)).
    generalize (path_FinType _ _ e). intros [].
    simpl. apply inverse.
    refine (_ @ path_FinType_1 (S1 ⊕ S3)).
    apply (ap (path_FinType _ _)).
    apply path_equiv. apply path_arrow. intros [s1 | s3]; reflexivity.
  Qed.

  Definition natural_path_FinType_r {S1 S2 S3: FinType} (e : S2 <~> S3)
    : ap (fun x : FinType => S1 ⊕ x) (path_FinType _ _ e)
      = path_FinType (S1 ⊕ S2) (S1 ⊕ S3) (equiv_functor_sum_l (A := S1) e).
  Proof.
    refine (_ @ ap (fun e' => @path_FinType (S1 ⊕ S2) (S1 ⊕ S3) (equiv_functor_sum_l e'))
              (eissect (@path_FinType S2 S3) e)).
    generalize (path_FinType _ _ e). intros [].
    simpl. apply inverse.
    refine (_ @ path_FinType_1 (S1 ⊕ S2)).
    apply (ap (path_FinType _ _)).
    apply path_equiv. apply path_arrow. intros [s1 | s2]; reflexivity.
  Qed.

  (** The monoidal structure on FinType*)
  Definition FinType_assoc : associative sum_FinType.
  Proof.
    intros S1 S2 S3.
    apply path_FinType.
    apply equiv_sum_assoc'.
  Defined.

  Definition FinType_lid : left_identity_mult sum_FinType (canon_FinType 0).
  Proof.
    intro S. apply path_FinType.
    apply sum_empty_l.
  Defined.

  Definition FinType_rid : right_identity_mult sum_FinType (canon_FinType 0).
  Proof.
    intro S. apply path_FinType.
    apply sum_empty_r.
  Defined.

  Definition FinType_symmetric : symmetric sum_FinType.
  Proof.
    intros S1 S2. apply path_FinType. apply equiv_sum_symm.
  Defined.

  Definition FinType_symsym : forall (a b : FinType), FinType_symmetric a b = (FinType_symmetric b a)^.
  Proof.
    intros A B.
    unfold FinType_symmetric.
    rewrite path_FinType_V.
    apply (ap (path_FinType _ _)).
    apply path_equiv. apply path_arrow.
    intros [a | b]; reflexivity.
  Qed.

  Definition FinType_triangle1 : coherence_triangle1 FinType_assoc FinType_lid.
  Proof.
    intros S1 S2.
    unfold FinType_lid.
    refine (natural_path_FinType_l _ @ _).
    unfold FinType_assoc.
    refine (_ @ (path_FinType_compose _ _)).
    apply (ap (path_FinType _ _)).
    apply path_equiv. apply path_arrow.
    intros [[[] | s1] | s2]; reflexivity.
  Qed.

  Definition FinType_triangle2 : coherence_triangle2 FinType_assoc FinType_lid FinType_rid.
  Proof.
    intros S1 S2. unfold FinType_rid. unfold FinType_assoc. unfold FinType_lid. simpl.
    refine (natural_path_FinType_l _ @ _).
    refine (_ @ whiskerL _ (natural_path_FinType_r _)^).
    refine (_ @ (path_FinType_compose  _ _)).
    apply (ap (path_FinType _ _)).
    apply path_equiv. apply path_arrow.
    intros [[s1 | []] | s2]; reflexivity.
  Qed.

  Definition FinType_pentagon : coherence_pentagon FinType_assoc.
  Proof.
    intros S1 S2 S3 S4.
    refine (natural_path_FinType_l _  @ _).
    apply moveL_pV.
    refine ((path_FinType_compose _ _)^ @ _).
    apply moveL_pV.
    refine (whiskerL _ (natural_path_FinType_r _) @ _).
    refine ((path_FinType_compose _ _)^ @ _).
    refine (_ @ (path_FinType_compose _ _)).
    apply (ap (path_FinType _ _)).
    apply path_equiv. apply path_arrow.
    intros [[[s1 | s2]| s3] | s4]; reflexivity.
  Defined.

  Definition FinType_hexagon : coherence_hexagon FinType_assoc FinType_symmetric.
  Proof.
    intros A B C.
    refine (natural_path_FinType_l _  @ _).
    apply moveL_pV. apply moveL_pV.
    refine (whiskerL _ (natural_path_FinType_r _) @ _).
    rewrite <- path_FinType_compose.
    rewrite <- path_FinType_compose.
    rewrite <- path_FinType_compose.
    rewrite <- path_FinType_compose.
    apply (ap (path_FinType _ _)).
    apply path_equiv. apply path_arrow.
    intros [[a | b] | c]; reflexivity.
  Defined.

  (** A couple auxiliary lemmas. *)
  Definition isinj_functor_sum {A1 A2 B1 B2 : Type} (f1 f1' : A1 -> B1) (f2 f2': A2 -> B2) :
    functor_sum f1 f2 = functor_sum f1' f2' -> (f1 = f1') * (f2 = f2').
  Proof.
    intro p.
    set (p' := ap10 p).
    apply pair.
    - apply path_arrow. intro a.
      apply (path_sum_inl B2). exact (p' (inl a)).
    - apply path_arrow. intro a.
      apply (path_sum_inr B1). exact (p' (inr a)).
  Defined.

  Definition isinj_equiv_functor_sum_r {A1 A2 B : Type} (e1 e2 : A1 <~> A2) :
    equiv_functor_sum_r (B := B) e1 = equiv_functor_sum_r e2 -> e1 = e2.
  Proof.
    intro p. apply path_equiv.
    refine (fst ((isinj_functor_sum e1 e2 idmap idmap) _)).
    apply (path_equiv^-1 p).
  Defined.

  (** FinType has left cancellation  *)
  Definition FinType_lcancel (S1 S2 : FinType) (p q : S1 = S2) (T : FinType) :
    ap (fun x => x ⊕ T) p = ap (fun x => x ⊕ T) q -> p = q.
  Proof.
    intro h.
    apply (equiv_inj (@path_FinType S1 S2)^-1).
    apply (isinj_equiv_functor_sum_r (B:=T)
                                     ((equiv_path_FinType _ _)^-1 p) ((equiv_path_FinType _ _)^-1 q)) .
    apply (equiv_inj (@path_FinType (S1 ⊕ T) (S2 ⊕ T))).
    refine ((natural_path_FinType_l _)^ @ _ @ natural_path_FinType_l _).
    refine (_ @ h @ _);
      apply (ap (ap (fun x : FinType => x ⊕ T))).
      - apply eisretr.
      - apply inverse. apply eisretr.
  Defined.

  (** FinType is a symmetric monoidal category  *)
  Definition FinType_smoncat : Symmetric_Monoidal_1Type :=
    Build_Symmetric_Monoidal_1Type
      (BuildTruncType 1 FinType) sum_FinType (canon_FinType 0) FinType_assoc
      FinType_lid FinType_rid FinType_symmetric FinType_symsym
      FinType_triangle1 FinType_triangle2 FinType_pentagon FinType_hexagon.
End FinType.

From GCTT Require Import monoids_and_groups.
Section Assoc_Nat_to_Assoc_FinType.
  (** Now we prove that associativity of sum_FinType on canonical finite types correspond to
   associativity of natural numbers. *)

  Definition equiv_sum_assoc_Fin (j k l : nat)
    : (Fin l + Fin k) + Fin j <~>
       Fin l + (Fin k + Fin j).
  Proof.
    induction j.
    - refine (_ oE sum_empty_r _).
      apply (equiv_functor_sum_l (sum_empty_r _)^-1).
    - simpl.
      refine (_ oE (equiv_functor_sum' IHj (equiv_idmap Unit)) oE _).
      + refine (_ oE equiv_sum_assoc _ _ _).
        apply equiv_functor_sum_l. apply equiv_sum_assoc.
      +
        refine (_ oE (equiv_sum_assoc _ _ _)^-1 ). apply equiv_idmap.
  Defined.

  Definition id_equiv_sum_assoc_Fin (j k l : nat)
    : equiv_sum_assoc (Fin l) (Fin k) (Fin j) = equiv_sum_assoc_Fin j k l.
  Proof.
    induction j.
    - simpl. apply path_equiv. apply path_arrow.
      intros [[x | x] | []]; reflexivity.
    - simpl. rewrite <- IHj.
      apply path_equiv. apply path_arrow.
      intros [[x | x] | [x | []]]; reflexivity.
  Defined.

  Definition sum_canon_FinType (j k : nat) :
    sum_FinType (canon_FinType j) (canon_FinType k) = canon_FinType (k + j)%nat.
  Proof.
    srapply @path_FinType. apply equiv_finsum.
  Defined.

  Definition canon_assoc (a b c : nat)
    : Fin (a + (b + c)) <~> Fin ((a + b) + c ).
  Proof.
    refine (_ oE (equiv_finsum _ _)^-1).
    refine (_ oE (equiv_functor_sum_r (equiv_finsum _ _))^-1).
    refine (_ oE ((equiv_sum_assoc' _ _ _))).
    refine (equiv_finsum _ _ oE _).
    apply (equiv_functor_sum_l (equiv_finsum _ _)).
  Defined.

  Definition equiv_functor_sum_r_compose
    : forall (A A1 A2 B : Type)
             (e1 : A <~> A1)
             (e2 : A1 <~> A2),
      equiv_functor_sum_r (B := B) (e2 oE e1)
      = equiv_functor_sum_r (B:= B) e2 oE equiv_functor_sum_r (B := B) e1.
  Proof.
    intros. apply path_equiv. apply path_arrow.
    intros [x | x]; reflexivity.
  Defined.

  Definition equiv_finsum_succ (a b : nat)
    : equiv_finsum a (b.+1) = equiv_functor_sum_r (equiv_finsum a b) oE (equiv_sum_assoc' _ _ _)^-1.
  Proof.
    apply path_equiv. apply path_arrow.
    intro x. simpl. apply finsum_succ.
  Defined.

  (** More auxiliary results  *)
  Definition functor_sum_assoc {A B C A' B' C' : Type} (f : A -> A') (g : B -> B') (h : C -> C')
    : functor_sum (functor_sum f g) h  o (sum_assoc_inv _ _ _) ==
      sum_assoc_inv _ _ _  o (functor_sum f (functor_sum g h)).
  Proof.
    intros [a | [b | c]]; reflexivity.
  Defined.

  Definition functor_sum_idmap (A B: Type)
    : @functor_sum A A B B idmap idmap == idmap.
  Proof.
    intros [a | b]; reflexivity.
  Defined.

  Definition functor_sum_compose {A A1 A2 B B1 B2 : Type}
             (f1 : A -> A1) (f2 : A1 -> A2)
             (g1 : B -> B1) (g2 : B1 -> B2)
    : functor_sum (f2 o f1) (g2 o g1) == functor_sum f2 g2 o functor_sum f1 g1.
  Proof.
    intros [a | b]; reflexivity.
  Defined.

    Definition equiv_functor_sum_r_V (A A' B : Type) (e : A <~> A')
    : equiv_functor_sum_r (B := B) (e^-1) = equiv_inverse (equiv_functor_sum_r e).
  Proof.
    apply path_equiv. reflexivity.
  Defined.

  Definition canon_assoc_succ (a b c : nat)
    : canon_assoc (a.+1) b c
      = equiv_functor_sum_r (canon_assoc a b c).
  Proof.
    unfold canon_assoc. simpl.
    apply emoveR_eV. apply emoveR_eV.
    rewrite equiv_finsum_succ. rewrite equiv_finsum_succ.
    rewrite equiv_finsum_succ.
    repeat rewrite equiv_functor_sum_r_compose.
    repeat rewrite equiv_functor_sum_r_V.
    apply path_equiv. apply path_arrow. intro x. ev_equiv. simpl.
    apply (ap (equiv_functor_sum_r (equiv_finsum c (a + b)))).
    rewrite <- (functor_sum_compose (finsum (b + c) a) (finsum_inv (b + c) a) idmap idmap).
    change (finsum_inv ?x ?y) with ((equiv_finsum x y)^-1).
    change (finsum ?x ?y ?z) with (equiv_finsum x y z).
    rewrite (path_arrow _ _ (eissect (equiv_finsum (b + c) a))).
    rewrite functor_sum_idmap.  simpl.
    rewrite functor_sum_assoc.
    rewrite <- (functor_sum_compose (finsum c b) (finsum_inv c b) idmap (functor_sum idmap idmap)).
    change (finsum_inv c b) with ((equiv_finsum c b)^-1).
    change (finsum c b ?x) with (equiv_finsum c b x).
    rewrite (path_arrow _ _ (eissect (equiv_finsum c b))).
    destruct x as [[x | x] | [x | x]]; reflexivity.
  Defined.

  Definition canon_FinType_assoc (a b c : nat) :
    canon_FinType (a + (b + c))%nat = canon_FinType ((a + b) + c)%nat.
  Proof.
    apply path_FinType. exact (canon_assoc a b c).
  Defined.

  (** Associativity in nat and FinType correspond  *)
  Definition eq_canon_FinType_assoc (a b c : nat)
    : canon_FinType_assoc a b c = ap canon_FinType (nat_plus_assoc a b c)^.
  Proof.
    unfold canon_FinType_assoc.
    induction a.
    - simpl. unfold canon_assoc.
      refine (_ @ path_FinType_1 _).
      apply (ap (path_FinType _ _)).
      apply emoveR_eV.
      refine (_ @ (ecompose_1e _)^).
      apply emoveR_eV.
      apply path_equiv. apply path_arrow.
      intros [[x | x] | []]; reflexivity.
    - rewrite canon_assoc_succ.
      simpl.
      assert (H : forall (m n : nat) (p : m = n),
                 ap canon_FinType (ap S p)
                 = @path_FinType (canon_FinType (m.+1)) (canon_FinType (n.+1))
                     (equiv_functor_sum_r
                        (B := Unit)
                        ((equiv_path_FinType (canon_FinType (m)) (canon_FinType (n)))^-1
                                      (ap canon_FinType p)))).
      { intros m n []. simpl.
        apply inverse. refine (_ @ path_FinType_1 _).
        apply (ap (path_FinType _ _)). apply path_equiv. simpl. apply path_arrow.
        intros [x|x]; reflexivity. }
      rewrite <- ap_V.
      rewrite H. clear H.
      apply (ap (path_FinType _ _)). apply (ap equiv_functor_sum_r).
      apply moveL_equiv_V.
      apply IHa.
  Qed.
End Assoc_Nat_to_Assoc_FinType.

(** Would have been better to define this stuff before doing all the above, but but.*)
Require Import monoidal_category.
Section Iso_Fin.
  Definition iso_fin : PreCategory.
  Proof.
    srapply (Build_PreCategory (fun A B : FinType => A <~> B)).
    - intros. cbn. reflexivity.
    - intros A B C. cbn. intros f g.
      exact (f oE g).
    - intros A B C D. cbn. intros f g h.
      apply ecompose_ee_e.
    - intros A B. cbn. intro f.
      apply ecompose_1e.
    - intros A B. cbn. intro f.
      apply ecompose_e1.
  Defined.

  Definition isgroupoid_isofin {A B : iso_fin} (f : morphism iso_fin A B)
    : IsIsomorphism f.
  Proof.
    simpl in f.
    apply (Build_IsIsomorphism _ A B  f (equiv_inverse f)); apply path_equiv; apply path_arrow.
    - apply (eissect f).
    - apply (eisretr f).
  Defined.

  Definition iso_fin_to_pg_fin : Functor iso_fin (Core.groupoid_category FinType).
  Proof.
    srapply (Build_Functor iso_fin (Core.groupoid_category FinType) idmap).
    - intros A B. cbn. apply path_FinType.
    - intros A B C. intros f g. hnf.
      apply path_FinType_compose.
    - intro A. hnf. apply path_FinType_1.
  Defined.

  Definition isfullyfaithful_iso_to_pgfin : forall (A B : iso_fin),
      IsEquiv (morphism_of iso_fin_to_pg_fin (s := A) (d := B)).
  Proof.
    simpl. intros A B. exact _.
  Defined.

  Definition iso_fin_sum : Functor (iso_fin * iso_fin) iso_fin.
  Proof.
    srapply @Build_Functor.
    - intros [A B]. exact (sum_FinType A B).
    - intros [A1 B1] [A2 B2]. simpl.
      intros [alpha betta]. exact (alpha +E betta).
    - cbn. intros [A1 B1] [A2 B2] [A3 B3]. cbn.
      intros [alpha1 betta1] [alpha2 betta2]. cbn.
      apply path_equiv. apply path_arrow. intros [i | j]; reflexivity.
    - cbn. intros [A B]. simpl. unfold reflexive_equiv.
      apply path_equiv. apply path_arrow. intros [i | j]; reflexivity.
  Defined.

  Definition moncat_isofin : Symmetric_Monoidal_Category.
  Proof.
    srefine (Build_Symmetric_Monoidal_Category
               (Build_Cat_Magma _ iso_fin_sum) FinType_id
               (fun A B C => equiv_sum_assoc A B C)
               _ _
               (fun A => sum_empty_l A)
               _ _
               (fun A => sum_empty_r A)
               _ _
               (fun A B => equiv_sum_symm A B ) _ _ _ _ _ _ _); cbn.
    - intros. apply isgroupoid_isofin.
    - intros A B C A' B' C'. intros f g h.
      apply path_equiv; apply path_arrow.
      intro x. destruct x as [[i | j] | k]; reflexivity.
    - intro A. apply isgroupoid_isofin.
    - intros A B f.
      apply path_equiv; apply path_arrow.
      intro x. destruct x as [[] | i]. reflexivity.
    - intro A. apply isgroupoid_isofin.
    - intros A B f.
      apply path_equiv; apply path_arrow.
      intro x. destruct x as [i | []]. reflexivity.
    - intros. apply isgroupoid_isofin.
    - intros A B A' B' f g.
      apply path_equiv; apply path_arrow.
      intro x. destruct x as [i | i]; reflexivity.
    - intros A B.
      apply path_equiv; apply path_arrow.
      intro x. destruct x as [i | i]; reflexivity.
    - intros A B.
      apply path_equiv; apply path_arrow.
      intro x. destruct x as [[[] | i] | i]; reflexivity.
    - intros A B.
      apply path_equiv; apply path_arrow.
      intro x. destruct x as [[i | []] | i]; reflexivity.
    - intros A B C D.
      apply path_equiv; apply path_arrow.
      intro x. destruct x as [[[i | i] | i] | i]; reflexivity.
    - intros A B C.
      apply path_equiv; apply path_arrow.
      intro x. destruct x as [[i | i] | i]; reflexivity.
  Defined.

End Iso_Fin.

From GCTT Require Import  quotients group_complete_category.

Definition group_complete_isofin := group_completion_moncat moncat_isofin.

Definition sum_group_complete_isofin :
  Functor (group_complete_isofin * group_complete_isofin) group_complete_isofin.
Proof.
  srapply @Build_Functor; cbn.
  - intros [[A1 B1] [A2 B2]].
    exact ((sum_FinType A1 A2, sum_FinType B1 B2)).
  - intros [[A1 B1] [A2 B2]] [[A3 B3] [A4 B4]]. simpl.
    intros [f1 f2]. revert f1 f2. simpl.
    srapply @set_quotient_rec2'.
    + intros f1 f2. simpl. apply class_of.
      apply (sum_group_completion_1' moncat_isofin f1 f2).
    + simpl. intros f f' g H.
      apply related_classes_eq.
      apply (welldef_sum_group_completion_1 moncat_isofin f f' g g H).
      apply refl_monact_relation.
    + simpl. intros f g g' H.
      apply related_classes_eq.
      srefine (welldef_sum_group_completion_1 moncat_isofin f f g g' _ H).
      apply refl_monact_relation.
  - simpl. intros [[a1 a2] [b1 b2]] [[c1 c2] [d1 d2]] [[e1 e2] [f1 f2]].
    simpl. intros [alpha betta] [gamma dela]. simpl.
    revert alpha.
    apply set_quotient_ind_prop.
    { intro alpha. exact _. }
    intro alpha. revert betta.
    apply set_quotient_ind_prop.
    { intro betta. exact _. }
    intro betta. revert gamma.
    apply set_quotient_ind_prop.
    { intro gamma. exact _. }
    intro gamma. revert dela.
    apply set_quotient_ind_prop.
    { intro dela. exact _. }
    intro dela. simpl.
    apply related_classes_eq.
    destruct alpha as [s alpha].
    destruct betta as [t betta].
    destruct gamma as [u gamma].
    destruct dela as [v dela].
    srapply @exist.
    { simpl. apply (Build_Isomorphic (isiso_twist_middle moncat_isofin _ _ _ _ )). }
    cbn.
    destruct alpha as [alpha1 alpha2]. destruct betta as [betta1 betta2].
    destruct gamma as [gamma1 gamma2]. destruct dela as [delta1 delta2]. simpl in *.
    simpl.
    apply path_prod; simpl.
    (** Here comes the coherence  *)
    { apply path_equiv. apply path_arrow. intro x.
      destruct x as [[[i|i] | [i|i]] | [i|i]]; reflexivity. }
    { apply path_equiv. apply path_arrow. intro x.
      destruct x as [[[i|i] | [i|i]] | [i|i]]; reflexivity. }
  - intros [[A1 A2] [B1 B2]]. simpl.
    apply related_classes_eq.
    unfold monact_relation. srapply @exist.
    { simpl.
      apply (Build_Isomorphic (isiso_moncat_lid moncat_isofin FinType_id)). }
    simpl.
    apply path_prod; simpl.
    (** This is probably not difficult to show from naturality and coherence triangles, but we use the hamme*)
    { apply path_equiv; apply path_arrow. intro x.
      destruct x as [[[] | []] | [i | i]]; reflexivity. }
    { apply path_equiv; apply path_arrow. intro x.
      destruct x as [[[] | []] | [i | i]]; reflexivity. }
Defined.

Definition FinFin_to_GrpCompl : Functor (iso_fin * iso_fin) group_complete_isofin.
Proof.
  apply cat_to_actcat.
Defined.

Definition assoc_group_complete_isofin (A1 A2 A3 : group_complete_isofin)
  : morphism _ (sum_group_complete_isofin (sum_group_complete_isofin (A1, A2), A3) )
             (sum_group_complete_isofin (A1, sum_group_complete_isofin (A2, A3))).
Proof.
  srefine (FinFin_to_GrpCompl _1 _). cbn.
  (* simpl. apply class_of. *)
  (* exists (moncat_id _). *)
  simpl. (* destruct A1 as [A1 B1]. destruct A2 as [A2 B2]. destruct A3 as [A3 B3]. simpl. *)
  exact (equiv_sum_assoc _ _ _ , equiv_sum_assoc _ _ _ ).
Defined.

Definition lid_group_complete_isofin (A : group_complete_isofin)
  : morphism _ (sum_group_complete_isofin ((FinType_id, FinType_id), A)) A.
Proof.
  srefine (FinFin_to_GrpCompl _1 _). cbn.
  exact (sum_empty_l _ , sum_empty_l _).
Defined.

Definition rid_group_complete_isofin (A : group_complete_isofin)
  : morphism _ (sum_group_complete_isofin (A, (FinType_id, FinType_id))) A.
Proof.
  srefine (FinFin_to_GrpCompl _1 _). cbn.
  exact (sum_empty_r _ , sum_empty_r _).
Defined.

Definition sym_group_complete_isofin (A B : group_complete_isofin)
  : morphism _ (sum_group_complete_isofin (A, B)) (sum_group_complete_isofin (B, A)).
Proof.
  srefine (FinFin_to_GrpCompl _1 _). cbn.
  exact (equiv_sum_symm _ _, equiv_sum_symm _ _).
Defined.

(* Move result to other place *)
(** The symmetric monoidal structure of the category of finite types and isomorphisms.  *)
(** Should ideally restructure somewhat since now this takes a LONG time...  *)
Definition moncat_group_complete_isofin : Symmetric_Monoidal_Category.
Proof.
  srefine (Build_Symmetric_Monoidal_Category
               (Build_Cat_Magma _ sum_group_complete_isofin) (FinType_id ,FinType_id)
               assoc_group_complete_isofin _ _
               lid_group_complete_isofin _ _
               rid_group_complete_isofin _ _
               sym_group_complete_isofin _ _
               _ _(* (fun A => sum_empty_r A) *)
               _ _
               _ ).
  - intros A B C. unfold assoc_group_complete_isofin.
    apply (iso_functor FinFin_to_GrpCompl).
    apply prod_isisomorphism; apply isgroupoid_isofin.
  - intros A B C A' B' C'. simpl in A, B, C, A', B', C'.
    intros f g h. revert f.
    apply set_quotient_ind_prop.
    { intro x. exact _. }
    intro f.
    revert g.
    apply set_quotient_ind_prop.
    { intro x. exact _. }
    intro g. revert h.
    apply set_quotient_ind_prop.
    { intro x. exact _. }
    intro h.
    destruct f as [s f]. destruct g as [t g]. destruct h as [u h]. simpl in *.
    apply related_classes_eq.
    srapply @exist.
    { simpl.
      (* Cheat a little since all morphisms in iso_fin are isomorphisms *)
      srefine (Build_Isomorphic (isgroupoid_isofin _)).
      refine (moncat_sym (moncat_isofin) FinType_id (sum_FinType s (sum_FinType t u)) o _).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      srefine (identity _ +^ _). apply moncat_assoc. }
    hnf. destruct f as [f1 f2]. destruct g as [g1 g2]. destruct h as [h1 h2]. hnf.
    destruct A as [A1 A2]. destruct B as [B1 B2]. destruct C as [C1 C2].
    destruct A' as [A1' A2']. destruct B' as [B1' B2']. destruct C' as [C1' C2'].
    unfold monoidal_action_cat_compose'. simpl.
    apply path_prod; cbn.
    (* here comes the coherence *)
    { apply path_equiv. apply path_arrow.
      intro x. destruct x as [[[] | i] | i]; repeat destruct i as [i | i]; reflexivity. }
    { apply path_equiv. apply path_arrow.
      intro x. destruct x as [[[] | i] | i]; repeat destruct i as [i | i]; reflexivity. }
  - intro A. unfold lid_group_complete_isofin.
    apply (iso_functor FinFin_to_GrpCompl).
    apply prod_isisomorphism; apply isgroupoid_isofin.
  - intros A A'. simpl in A, A'.
    apply set_quotient_ind_prop.
    {intro x. exact _. }
    intro f. destruct f as [s [f1 f2]]. simpl in f1, f2.
    destruct A as [A1 A2]. destruct A' as [A1' A2']. simpl.
    apply related_classes_eq.
    srapply @exist.
    { simpl.
      (* Cheat a little since all morphisms in iso_fin are isomorphisms *)
      srefine (Build_Isomorphic (isgroupoid_isofin _)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      srefine (_ o moncat_lid moncat_isofin _).
      apply moncat_sym. }
    hnf. unfold monoidal_action_cat_compose'. simpl.
    (* coherence: *)
    apply path_prod; simpl;
      apply path_equiv; apply path_arrow; intro i;
        repeat try destruct i as [i | i]; try destruct i as []; reflexivity.
  - intro A.
    apply (iso_functor FinFin_to_GrpCompl).
    apply prod_isisomorphism; apply isgroupoid_isofin.
  - intros A A'. simpl in A, A'.
    apply set_quotient_ind_prop.
    { intro x. exact _. }
    intros [s [f1 f2]]. simpl in f1, f2.
    destruct A as [A1 A2]. destruct A' as [A1' A2']. simpl in *.
    apply related_classes_eq.
    srapply @exist.
    { simpl.
      srefine (Build_Isomorphic (isgroupoid_isofin _)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      srefine (moncat_lid moncat_isofin _). }
    (* coherence *)
    apply path_prod; simpl;
      apply path_equiv; apply path_arrow; intro i;
        repeat try destruct i as [i | i]; try destruct i as []; reflexivity.
  - intros A B.
    apply (iso_functor FinFin_to_GrpCompl).
    apply prod_isisomorphism; apply isgroupoid_isofin.
  - intros [A1 A2] [B1 B2] [A1' A2'] [B1' B2'].
    intros f g. revert f.
    apply set_quotient_ind_prop.
    { intro x. exact _. } intro f.
    revert g.
    apply set_quotient_ind_prop.
    { intro x. exact _. } intro g.
    destruct f as [s f]. destruct g as [t g]. simpl in *.
    apply related_classes_eq.
    srapply @exist.
    { simpl. srefine (Build_Isomorphic (isgroupoid_isofin _)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      srefine (moncat_sym moncat_isofin _ _ o _).
      srefine (1 +^ _). apply moncat_sym. }
    (* coherence *)
    apply path_prod; simpl;
      apply path_equiv; apply path_arrow; intro i;
        repeat try destruct i as [i | i]; try destruct i as []; reflexivity.
  - intros [A1 A2] [B1 B2]. simpl.
    apply related_classes_eq.
    srapply @exist.
    { simpl. srefine (Build_Isomorphic (isgroupoid_isofin _)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      apply (moncat_lid moncat_isofin). }
    (* coherence *)
    apply path_prod; simpl;
      apply path_equiv; apply path_arrow; intro i;
        repeat try destruct i as [i | i]; try destruct i as []; reflexivity.
  - intros [A1 A2] [B1 B2]. simpl.
    apply related_classes_eq.
    srapply @exist.
    { reflexivity. }
    (* coherence *)
    apply path_prod; simpl;
      apply path_equiv; apply path_arrow; intro i;
        repeat try destruct i as [i | i]; try destruct i as []; reflexivity.
  - intros [A1 A2] [B1 B2]. simpl.
    apply related_classes_eq.
    srapply @exist.
    { simpl.
      srefine (Build_Isomorphic (isgroupoid_isofin _)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      apply (moncat_rid moncat_isofin). }
    (* coherence *)
    apply path_prod; simpl;
      apply path_equiv; apply path_arrow; intro i;
        repeat try destruct i as [i | i]; try destruct i as []; reflexivity.
  - intros [A1 A2] [B1 B2] [C1 C2] [D1 D2]. simpl.
    apply related_classes_eq.
    srapply @exist.
    { simpl.  apply symmetry.
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      srefine (Build_Isomorphic (isgroupoid_isofin _)).
      srefine (_ +^ (moncat_lid moncat_isofin FinType_id) ).
      srefine (_ o moncat_rid moncat_isofin _ ).
      srefine (moncat_rid moncat_isofin _ ). }
    (* coherence *)
    apply path_prod; simpl;
      apply path_equiv; apply path_arrow; intro i;
        repeat try destruct i as [i | i]; try destruct i as []; reflexivity.
  - intros [A1 A2] [B1 B2] [C1 C2]. simpl.
    apply related_classes_eq.
    srapply @exist.
    { simpl. apply symmetry.
      srefine (Build_Isomorphic (isgroupoid_isofin _)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      change (sum_FinType ?a ?b) with (@binary_op moncat_isofin (a, b)).
      srefine (_ +^ (moncat_lid moncat_isofin FinType_id) ).
      exact ((moncat_lid moncat_isofin FinType_id) +^ 1). }
    (* coherence *)
    apply path_prod; simpl;
      apply path_equiv; apply path_arrow; intro i;
        repeat try destruct i as [i | i]; try destruct i as []; reflexivity.
Defined.


(*
vim: set fenc=utf-8 ff=unix sts=2 sw=2 et ft=coq :
*)
(*
Copyright (C) 2016-2019 Philip H. Smith

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

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.
*)

Require Import Way.Tactics.

Require Import Way.Conversion.
Require Import Way.Open.
Require Import Way.Preterm.
Require Import Way.Relation.
Require Import Way.Term.

(* The subtyping relation.

Subtyping serves two roles in this logic.  First it includes conversion, and so the
conversion typing rule becomes the subtyping rule.  Second it brings transitivity to the
type hierarchy, allowing (type 0) to be considered a term of (type 2), for example.
*)
Inductive subtyping : relation :=

(* Convertible types are subtypes of each other. *)
| conversion : forall (T U : preterm), Conversion.conversion T U -> subtyping T U

(* Each sort is a subtype of the next in the hierarchy. *)
| type : forall (n : nat), subtyping (Preterm.type n) (Preterm.type (S n))

(* Subtyping descends into codomains of products with convertible domains. *)
| product : forall (l : list atom) (T V : preterm), Conversion.conversion T V ->
  forall (U W : preterm), (fresh (a : l), subtyping (open_free a U) (open_free a W)) ->
  subtyping (Preterm.product T U) (Preterm.product V W)

(* Terms are reflexivily subtypes of themselves. *)
(* TODO(phs): If we could move this guard then we could use star. *)
(* TODO(phs): Alternately, we could demand relations deal only in terms *)
| reflexivity : forall (T : preterm), term T -> subtyping T T

(* Subtyping is transitive. *)
| transitivity :
    forall (U T V : preterm), subtyping T U -> subtyping U V -> subtyping T V.

Hint Resolve conversion type reflexivity : way.

Module Examples.

Import Aliases.

Example convertible_terms_are_subtypes :
  subtyping
    (app (abs (type 1) (bvar 0)) (type 0))
    (type 0).
Proof.
  infer.
Defined.

Example sort_is_subtype_of_next : subtyping (type 2) (type 3).
Proof.
  infer.
Defined.

Example subtyping_descends_into_product_codomains :
  subtyping
    (prod (type 0) (app (abs (type 1) (bvar 0)) (type 0)))
    (prod (type 0) (type 0)).
Proof.
  infer.
Defined.

Example subtyping_is_reflexive_for_terms :
  subtyping
    (abs (type 0) (bvar 0))
    (abs (type 0) (bvar 0)).
Proof.
  infer.
Defined.

Example subtyping_is_transitive : subtyping (type 0) (type 2).
Proof.
  apply (Subtyping.transitivity (type 1));
  infer.
Defined.

End Examples.


(* SPDX-License-Identifier: GPL-2.0 *)
Require Import List.
Require Import Bool.
Require Import NArith PArith ZArith.

Set Implicit Arguments.

Definition Value := nat.
Definition default : Value := 0.
Definition Address := nat.
Definition TID := nat.
Definition RegID := nat.
Definition View := nat.

Inductive Promise :=
| WRITE : TID -> Value -> Address -> Promise
| PUSH : TID -> Address -> Promise
| PULL : TID -> Address -> Promise
.

Inductive Expr :=
| CONST (val : Value) : Expr
| VAR (reg : RegID) : Expr
| ADD (e1 : Expr) (e2 : Expr) : Expr
.

Inductive InternalEvent :=
| MOV : RegID -> Expr -> InternalEvent
| BRANCH : RegID -> InternalEvent
.

Inductive Event :=
| INTERNAL : InternalEvent -> Event
| LOAD : Address -> View -> RegID -> Event
| ACQ : View -> Address -> Event
| STORE : Address -> View -> RegID -> Event
| REL : View ->  Address -> Event
.

Definition RegState := RegID -> Value.
Definition MemState := Address -> Value.

Definition update {T : Type} s addr (val : T) :=
    (fun (x : nat) => if beq_nat x addr then val else s x).

(* Lemma about update *)
Lemma update_same :
    forall {T} s addr (val : T), update s addr val addr = val.
Proof.
    intros. unfold update. rewrite <- beq_nat_refl. reflexivity.
Qed.

Lemma update_not_same :
    forall {T} s addr (val : T) addr' (Hneq : addr <> addr'), update s addr val addr' = s addr'.
Proof.
    intros. unfold update. replace (beq_nat addr' addr) with false. easy.
    symmetry. rewrite beq_nat_false_iff. auto.
Qed.

Definition OwnershipMap := Address -> option TID.

Fixpoint eval (e : Expr) (st : RegState) : option Value :=
    match e with
    | CONST val => Some val
    | VAR reg => Some (st reg)
    | ADD e1 e2 =>
        match eval e1 st with
        | None => None
        | Some v1 =>
            match eval e2 st with
            | None => None
            | Some v2 => Some (v1 + v2)
            end
        end
    end.

Lemma eval_exists :
    forall e st, exists v, eval e st = Some v.
Proof.
    induction e; intro.
    -   esplit; simpl; auto.
    -   esplit; simpl; auto.
    -   specialize (IHe1 st). destruct IHe1 as (v1 & Hv1).
        specialize (IHe2 st). destruct IHe2 as (v2 & Hv2).
        esplit. simpl.
        rewrite Hv1. rewrite Hv2. reflexivity.
Qed.

Definition execute_internal (i : InternalEvent) (st : RegState) : option RegState :=
    match i with
    | MOV reg e =>
                match eval e st with
                | None => None
                | Some val => Some (update st reg val)
                end
    | _ => Some st
    end.

Lemma execute_internal_exists :
        forall i st, exists rs, execute_internal i st = Some rs.
Proof.
    destruct i.
    -   intros. induction e.
        +   simpl. eexists. reflexivity.
        +   simpl. eexists. reflexivity.
        +   simpl. destruct IHe1 as (rs1 & Hrs1).
            destruct IHe2 as (rs2 & Hrs2).
            simpl in *. destruct (eval e1 st); try discriminate.
            destruct (eval e2 st); try discriminate.
            esplit. reflexivity.
    -   intros. simpl. esplit. reflexivity.
Qed.


Require Coq.Arith.Arith.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Core.Type.
Require Import ExtLib.Structures.Monoid.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.Injection.

Set Implicit Arguments.
Set Strict Implicit.

Global Instance RelDec_eq : RelDec (@eq nat) :=
{ rel_dec := EqNat.beq_nat }.

Global Instance type_nat : type nat :=
{ equal := @eq nat
; proper := fun _ => True
}.

Global Instance typeOk_nat : typeOk type_nat.
Proof.
  constructor.
  { compute; auto. }
  { compute; auto. }
  { compute; auto. }
  { compute. intros. etransitivity; eauto. }
Qed.

Global Instance nat_proper (n : nat) : proper n.
Proof. exact I. Qed.

Require Coq.Numbers.Natural.Peano.NPeano.

Global Instance RelDec_lt : RelDec lt :=
{ rel_dec := NPeano.Nat.ltb }.

Global Instance RelDec_le : RelDec le :=
{ rel_dec := NPeano.Nat.leb }.

Global Instance RelDec_gt : RelDec gt :=
{ rel_dec := fun x y => NPeano.Nat.ltb y x }.

Global Instance RelDec_ge : RelDec ge :=
{ rel_dec := fun x y => NPeano.Nat.leb y x }.

Global Instance RelDecCorrect_eq : RelDec_Correct RelDec_eq.
Proof.
  constructor; simpl. apply EqNat.beq_nat_true_iff.
Qed.

Global Instance RelDecCorrect_lt : RelDec_Correct RelDec_lt.
Proof.
  constructor; simpl. eapply NPeano.Nat.ltb_lt.
Qed.

Global Instance RelDecCorrect_le : RelDec_Correct RelDec_le.
Proof.
  constructor; simpl. eapply NPeano.Nat.leb_le.
Qed.

Global Instance RelDecCorrect_gt : RelDec_Correct RelDec_gt.
Proof.
  constructor; simpl. unfold rel_dec; simpl.
  intros. eapply NPeano.Nat.ltb_lt.
Qed.

Global Instance RelDecCorrect_ge : RelDec_Correct RelDec_ge.
Proof.
  constructor; simpl. unfold rel_dec; simpl.
  intros. eapply NPeano.Nat.leb_le.
Qed.

Inductive R_nat_S : nat -> nat -> Prop :=
| R_S : forall n, R_nat_S n (S n).

Theorem wf_R_S : well_founded R_nat_S.
Proof.
  red; induction a; constructor; intros.
    inversion H.
    inversion H; subst; auto.
Defined.

Inductive R_nat_lt : nat -> nat -> Prop :=
| R_lt : forall n m, n < m -> R_nat_lt n m.

Theorem wf_R_lt : well_founded R_nat_lt.
Proof.
  red; induction a; constructor; intros.
  { inversion H. exfalso. subst. inversion H0. }
  { inversion H; clear H; subst. inversion H0; clear H0; subst; auto.
    inversion IHa. eapply H. constructor. eapply H1. }
Defined.

Definition Monoid_nat_plus : Monoid nat :=
{| monoid_plus := plus
 ; monoid_unit := 0
 |}.

Definition Monoid_nat_mult : Monoid nat :=
{| monoid_plus := mult
 ; monoid_unit := 1
 |}.

Global Instance Injective_S (a b : nat) : Injective (S a = S b).
refine {| result := a = b |}.
abstract (inversion 1; auto).
Defined.

Definition nat_get_eq (n m : nat) (pf : unit -> n = m) : n = m :=
  match PeanoNat.Nat.eq_dec n m with
  | left pf => pf
  | right bad => match bad (pf tt) with end
  end.


(*
 * Strong Normalization for Nested Relational Calculus.
 * Copyright Ezra Cooper, 2008-2020.
 *)

Require Import Arith.

Load "eztactics.v".

Definition outside_range a b x :=
  if le_gt_dec a x then
    if le_gt_dec b x then true else false
  else true.

(* TODO: Use this everywhere, instead of outside_range *)
Definition Outside_Range a b x :=
  {x < a} + {x >= b}.

Lemma outside_range_elim a b x: true = outside_range a b x -> Outside_Range a b x.
 unfold outside_range.
 unfold Outside_Range.
 break; try break; solve [intuition | discriminate].
Qed.


Require Import Omega Psatz.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From LCAC Require Import seq_ext_base.

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

Definition natE :=
  (addSn, addnS, add0n, addn0, sub0n, subn0, subSS,
   min0n, minn0, max0n, maxn0, leq0n).

(* Extended comparison predicates. *)

Variant leq_xor_gtn' m n :
    bool -> bool -> bool -> bool ->
    nat -> nat -> nat -> nat -> nat -> nat -> Set :=
  | LeqNotGtn' of m <= n :
    leq_xor_gtn' m n (m < n) false true (n <= m) n n m m 0 (n - m)
  | GtnNotLeq' of n < m :
    leq_xor_gtn' m n false true false true m m n n (m - n) 0.

Lemma leqP' m n : leq_xor_gtn' m n
  (m < n) (n < m) (m <= n) (n <= m)
  (maxn m n) (maxn n m) (minn m n) (minn n m)
  (m - n) (n - m).
Proof.
case: (leqP m n) => H.
- by move: (H); rewrite -subn_eq0 => /eqP ->; constructor.
- rewrite (ltnW H) leqNgt ltnS ltnW //.
  by move: (ltnW H); rewrite -subn_eq0 => /eqP ->; constructor.
Qed.

Variant compare_nat' m n :
    bool -> bool -> bool -> bool -> bool ->
    nat -> nat -> nat -> nat -> nat -> nat -> Set :=
  | CompareNatLt' of m < n :
    compare_nat' m n true false false true false n n m m 0 (n - m)
  | CompareNatGt' of m > n :
    compare_nat' m n false true false false true m m n n (m - n) 0
  | CompareNatEq' of m = n :
    compare_nat' m n false false true true true m m m m 0 0.

Lemma ltngtP' m n : compare_nat' m n
  (m < n) (n < m) (m == n) (m <= n) (n <= m)
  (maxn m n) (maxn n m) (minn m n) (minn n m)
  (m - n) (n - m).
Proof.
case: (ltngtP m n) => [H|H|->]; last by rewrite subnn; constructor.
- by move: (ltnW H); rewrite -subn_eq0 => /eqP ->; constructor.
- by move: (ltnW H); rewrite -subn_eq0 => /eqP ->; constructor.
Qed.

(* simpl_natarith *)

Module simpl_natarith.
Lemma lem1_1 ml mr n r : ml = r + n -> ml + mr = r + mr + n.
Proof. by move => ->; rewrite addnAC. Qed.
Lemma lem1_2 ml mr n r : mr = r + n -> ml + mr = ml + r + n.
Proof. by move => ->; rewrite addnA. Qed.
Lemma lem1_3 m' n r : m' = r + n -> m'.+1 = r.+1 + n.
Proof. by move => ->; rewrite addSn. Qed.
Lemma lem2_1 ml mr n r : ml - n = r -> ml - mr - n = r - mr.
Proof. by move => <-; rewrite subnAC. Qed.
Lemma lem2_2 m' n r : m' - n = r -> m'.-1 - n = r.-1.
Proof. by move => <-; rewrite -subnS -add1n subnDA subn1. Qed.
Lemma lem2_3 m n r : m = r + n -> m - n = r.
Proof. by move => ->; rewrite addnK. Qed.
Lemma lem3_1 m m' m'' nl nl' nl'' nr nr' :
  m - nl = m' - nl' -> m' - nl' - nr = m'' - nl'' - nr' ->
  m - (nl + nr) = m'' - (nl'' + nr').
Proof. by rewrite !subnDA => -> ->. Qed.
Lemma lem3_2 m n r : m - (n + 1) = r -> m - n.+1 = r.
Proof. by rewrite addn1. Qed.
Lemma lem3_3 m n r : m - n = r -> m - n = r - 0.
Proof. by rewrite subn0. Qed.
Lemma lem4_1 m n m' n' : m - n = m' - n' -> (m <= n) = (m' <= n').
Proof. by rewrite -!subn_eq0 => ->. Qed.
End simpl_natarith.

Ltac simpl_natarith1 m n :=
  match m with
    | n => constr: (esym (add0n n))
    | ?ml + ?mr => let H := simpl_natarith1 ml n in
                   constr: (simpl_natarith.lem1_1 mr H)
    | ?ml + ?mr => let H := simpl_natarith1 mr n in
                   constr: (simpl_natarith.lem1_2 ml H)
    | ?m'.+1 => let H := simpl_natarith1 m' n in
                constr: (simpl_natarith.lem1_3 H)
    | ?m'.+1 => match n with 1 => constr: (esym (addn1 m')) end
  end.

Ltac simpl_natarith2 m n :=
  match m with
    | ?ml - ?mr => let H := simpl_natarith2 ml n in
                   constr: (simpl_natarith.lem2_1 mr H)
    | ?m'.-1 => let H := simpl_natarith2 m' n in
                constr: (simpl_natarith.lem2_2 H)
    | _ => let H := simpl_natarith1 m n in constr: (simpl_natarith.lem2_3 H)
  end.

Ltac simpl_natarith3 m n :=
  lazymatch n with
    | ?nl + ?nr =>
      simpl_natarith3 m nl;
      match goal with |- _ = ?m1 -> _ =>
        let H := fresh "H" in
        move => H; simpl_natarith3 m1 nr; move/(simpl_natarith.lem3_1 H) => {H}
      end
    | _ =>
      match n with
        | ?n'.+1 =>
          lazymatch n' with
            | 0 => fail
            | _ => simpl_natarith3 m (n' + 1); move/simpl_natarith.lem3_2
          end
        | _ => let H := simpl_natarith2 m n in move: (simpl_natarith.lem3_3 H)
        | _ => move: (erefl (m - n))
      end
  end.

Ltac simpl_natarith :=
  let tac x :=
    lazymatch goal with
      | |- ?x = ?x -> _ => move => _; rewrite !natE
      | _ => move => ->; rewrite ?natE
    end in
  repeat
    (match goal with
       H : context [?m - ?n] |- _ => move: H; simpl_natarith3 m n; tac 0 => H
     end ||
     match goal with
       |- context [?m - ?n] => simpl_natarith3 m n; tac 0
     end ||
     match goal with
       H : context [?m <= ?n] |- _ =>
       move: H; simpl_natarith3 m n; move/simpl_natarith.lem4_1; tac 0 => H
     end ||
     match goal with
       |- context [?m <= ?n] =>
         simpl_natarith3 m n; move/simpl_natarith.lem4_1; tac 0
     end);
  try done;
  repeat match goal with
    | H : is_true true |- _ => clear H
                               (* "move => {H}" may unfold the "is_true" *)
  end.

(* elimleq *)

Tactic Notation "elimleq" :=
  match goal with |- is_true (?n <= ?m) -> _ =>
    is_var m;
    (let H := fresh "H" in move/subnKC => H; rewrite <- H in *; clear H);
    let rec tac :=
      lazymatch reverse goal with
        | H : context [m] |- _ => move: H; tac => H
        | _ => move: {m} (m - n) => m; rewrite ?(addKn, addnK)
      end in tac; simpl_natarith
  end.

Tactic Notation "elimleq" constr(H) := move: H; elimleq.

(* ssromega *)

Tactic Notation "find_minneq_hyp" constr(m) constr(n) :=
  match goal with
    | H : is_true (m <= n) |- _ => rewrite (minn_idPl H)
    | H : is_true (n <= m) |- _ => rewrite (minn_idPr H)
    | H : is_true (m < n) |- _ => rewrite (minn_idPl (ltnW H))
    | H : is_true (n < m) |- _ => rewrite (minn_idPr (ltnW H))
    | |- _ => case (leqP' m n)
  end; rewrite ?natE.

Tactic Notation "find_maxneq_hyp" constr(m) constr(n) :=
  match goal with
    | H : is_true (m <= n) |- _ => rewrite (maxn_idPr H)
    | H : is_true (n <= m) |- _ => rewrite (maxn_idPl H)
    | H : is_true (m < n) |- _ => rewrite (maxn_idPr (ltnW H))
    | H : is_true (n < m) |- _ => rewrite (maxn_idPl (ltnW H))
    | |- _ => case (leqP' m n)
  end; rewrite ?natE.

Ltac replace_minn_maxn :=
  try (rewrite <- minnE in * || rewrite <- maxnE in * );
  match goal with
    | H : context [minn ?m ?n] |- _ => move: H; find_minneq_hyp n m => H
    | H : context [maxn ?m ?n] |- _ => move: H; find_maxneq_hyp n m => H
    | |- context [minn ?m ?n] => find_minneq_hyp m n
    | |- context [maxn ?m ?n] => find_maxneq_hyp m n
  end;
  try (let x := fresh "x" in move => x).

Ltac arith_hypo_ssrnat2coqnat :=
  match goal with
    | H : is_true false    |- _ => by move: H
    | H : is_true (_ && _) |- _ => let H0 := fresh "H" in case/andP: H => H H0
    | H : is_true (_ || _) |- _ => case/orP in H
    | H : is_true (_ <  _) |- _ => move/ltP in H
    | H : is_true (_ <= _) |- _ => move/leP in H
    | H : is_true (_ == _) |- _ => move/eqP in H
    | H : is_true (_ != _) |- _ => move/eqP in H
  end.

Ltac arith_goal_ssrnat2coqnat :=
  match goal with
    | |- is_true (_ && _) => apply/andP; split
    | |- is_true (_ || _) => apply/orP
    | |- is_true (_ <  _) => apply/ltP
    | |- is_true (_ <= _) => apply/leP
    | |- is_true (_ == _) => apply/eqP
    | |- is_true (_ != _) => apply/eqP
  end.

Ltac ssromega :=
  repeat (let x := fresh "x" in move => /= x);
  do ?replace_minn_maxn;
  try done;
  repeat match goal with H : is_true (?m <= ?n) |- _ => elimleq H end;
  repeat (rewrite <- leqNgt in * || rewrite <- ltnNge in * );
  do ?unfold addn, subn, muln, addn_rec, subn_rec, muln_rec in *;
  do ?arith_hypo_ssrnat2coqnat;
  do ?arith_goal_ssrnat2coqnat;
  simpl Equality.sort in *;
  lia.
(*
  omega.
*)

Ltac elimif' :=
  (match goal with
     | |- context [if ?m < ?n then _ else _] => case (leqP' n m)
     | |- context [if ?m <= ?n then _ else _] => case (leqP' m n)
     | |- context [if ?b then _ else _] => case (ifP b)
   end;
   move => //=; elimif'; let hyp := fresh "H" in move => hyp) ||
  idtac.

Ltac elimif :=
  elimif'; simpl_natarith;
  repeat match goal with H : is_true (?m <= ?n) |- _ => elimleq H end.

Ltac elimif_omega :=
  elimif;
  try (repeat match goal with
    | |- @eq nat _ _ => idtac
    | |- nth _ _ _ = nth _ _ _ => apply nth_equal
    | |- _ => f_equal
  end; ssromega).

(* congruence' *)

Ltac congruence' := simpl; try (move: addSn addnS; congruence).

(* test code for ssromega *)

Module ssromega_test.
Goal forall m n, minn (maxn m n) m = m. ssromega. Qed.
Goal forall m n, minn n (maxn m n) = n. ssromega. Qed.
Goal forall m n, maxn (minn m n) m = m. ssromega. Qed.
Goal forall m n, maxn n (minn m n) = n. ssromega. Qed.
Goal forall m n, maxn m n = m + (n - m). ssromega. Qed.
Goal forall m n, minn m n = m - (m - n). ssromega. Qed.
Goal forall m n, minn m n = m <-> m <= n. split; ssromega. Qed.
Goal forall m n, maxn m n = n <-> m <= n. split; ssromega. Qed.
Goal forall m n, maxn m n - minn m n = (m - n) + (n - m). ssromega. Qed.
Goal forall m n, minn m n - maxn m n = 0. ssromega. Qed.
Goal forall m n, minn m n + maxn m n = m + n. ssromega. Qed.
Goal forall m n, minn m n + (m - n) = m. ssromega. Qed.
Goal forall m n, maxn m n - (n - m) = m. ssromega. Qed.
End ssromega_test.


(*|
##############################################################
Difference between ``sumbool`` and intuitionnistic disjunction
##############################################################

:Link: https://stackoverflow.com/q/51288196
|*)

(*|
Question
********

According to Coq's documentation

    ``sumbool`` is a boolean type equipped with the justification of
    their value

I thought that was already a property of the disjunction, in the
intuitionnistic (or constructive) logic that Coq implements.

For example, to prove an excluded middle ``p \/ ~p`` in Coq, you have
to do actual work, it is not a logical axiom. So a proof of ``p \/ q``
must either be a proof of ``p`` or a proof of ``q``.

Then why do we need ``sumbool p q``?

**EDIT**

By replacing the tactics by exact proofs, I got more specific error
messages. This one is fine:
|*)

Lemma sumbool_or : forall p q : Prop, sumbool p q -> p \/ q.
Proof.
  exact (fun (p q : Prop) (H : sumbool p q) =>
           match H with
           | left p0 => or_introl p0
           | right q0 => or_intror q0
           end).
Qed.

(*| However this one tells me |*)

Lemma or_sumbool : forall p q : Prop, p \/ q -> sumbool p q.
Proof.
  Fail exact (fun (p q : Prop) (H : p \/ q) =>
                match H with
                | or_introl p0 => left p0
                | or_intror q0 => right q0
                end). (* .fails .unfold .no-goals *)

(*|
I'm a bit surprised. So a primitive like ``match`` depends on the sort
of thing we want to prove? It looks low-level lambda-calculus though.
|*)

(*|
Answer
******

The ``sumbool`` type lives in Coq's computationally relevant universe
``Type`` (or ``Set``). In particular, we can write programs using
functions that return elements of ``{P} + {Q}`` (for instance, the
standard library's ``Nat.eq_dec : forall n m : nat, {n = m} + {n <>
m}``, which tests whether two numbers are equal).

Logical disjunction, on the other hand, belongs to the computationally
irrelevant universe ``Prop``. We cannot perform case analysis on a
proof of type ``P \/ Q`` because Coq was designed to erase proofs when
a program is extracted, and such a case analysis might alter the
outcome of a computation. This makes it safe for us, for example, to
add the excluded middle axiom ``forall P : Prop, P \/ ~ P`` without
impacting the execution of extracted programs.

It would also be possible to add a strong form of the excluded middle
that lives in ``Type``: ``forall P : Prop, {P} + {~P}``; however, if
we use this axiom to write programs, we will not be able to execute
them.

----

**A:** Think of what is going to happen at runtime. When extracting a
program (i.e. erasing all the proofs since you don't need them at
runtime) all arguments of type ``or A B`` can be erased, i.e. those
cannot have any influence on program execution. Whereas it's not
possible to remove a term of type ``sumbool A B``, we can only hope
that the extractor would erase the proofs ``left`` and ``right``
constructors carry. Essentially ``sumbool`` should turn into a plain
simple ``bool`` type at runtime (that was a part of my answer I was
writing, but Arthur beat me to it :)).

**A:** Note that the resulting type is ``Prop`` for ``or`` and ``Set``
for ``sumbool``. This means you can use terms of ``sumbool`` type as
*data*, but terms of ``or`` type is for *specification* purposes only.
Which one to use depends on what you are trying to achieve.
``sumbool`` can be used inside the logical world, but ``or`` can't
affect computations. You can prove ``Lemma sumbool_to_or P Q : {P} +
{Q} -> P \/ Q.``, but not ``P \/ Q -> {P} + {Q}``.
|*)


Load "Example13".

(*****************forall x y, (EQ_M x y) = (EQ_M y x)**********)

Theorem Example14_M: forall (n1 m1 : nat),  (EQ_M (Mvar n1) (Mvar m1) ) ##  (EQ_M (Mvar m1) (Mvar n1)).
Proof.
intros .
assert(H : (Bvar 1) ## (if_then_else_B (Bvar 1) TRue FAlse)).
rewrite IFTF with (n:=1). reflexivity.
apply Forall_ELM_EVAL_B with (n:=1)(b:= (EQ_M (Mvar n1) (Mvar m1))) in H .
simpl in H.
assert ( Eq: (EQ_M (Mvar n1) (Mvar n1)) ## TRue).
apply EQmsg.
reflexivity.
rewrite <- Eq in H.

assert(H2: ( if_then_else_B (EQ_M (Mvar n1) (Mvar m1)) [[ (n1+m1+1):= (Mvar n1)]](EQ_M (Mvar (n1+m1 +1)) (Mvar n1))
      FAlse) ## (if_then_else_B (EQ_M (Mvar n1) (Mvar m1)) [[ (n1+m1+1):= (Mvar m1)]](EQ_M (Mvar (n1+m1+1)) (Mvar n1))
      FAlse)).

apply EQ_BRmsg_bol with (n1:= n1)(n2:= m1)(n3:=(n1+m1+1))(b1:= (EQ_M (Mvar (n1+m1+1)) (Mvar n1))) (b2:= FAlse).
simpl in H2.
assert(H4: n1<> n1+m1+1).
omega.
assert (H3: beq_nat n1 (n1+m1+1) = false).
SearchAbout beq_nat.
apply beq_nat_false_iff  with (x:=n1)(y:=n1+m1+1) in H4.
assumption.
rewrite H3 in H2.
simpl.
rewrite <- beq_nat_refl in H2.
rewrite H2 in H.

assert(H5 :  (Bvar 1) ##  (if_then_else_B (Bvar 1) TRue FAlse)).

rewrite IFTF with (n:=1). reflexivity.
apply Forall_ELM_EVAL_B2 with (n:=1)(b:= (EQ_M (Mvar m1) (Mvar n1))) in H5 .
simpl in H5.
rewrite H5 in H.
assert(H6:(if_then_else_B (Bvar 1) (if_then_else_B (Bvar 2 ) TRue FAlse) FAlse) ## (if_then_else_B (Bvar 2)(if_then_else_B (Bvar 1) TRue FAlse)(if_then_else_B (Bvar 1) FAlse FAlse))).
rewrite <- IFMORPH_B1 with (n2 :=1)(b:=TRue ) (b1:=FAlse)(b2:= FAlse).
reflexivity.
apply Forall_ELM_EVAL_B with (n:=1)(b:= (EQ_M (Mvar n1) (Mvar m1))) in H6 .
simpl in H6.
apply Forall_ELM_EVAL_B with (n:=2)(b:= (EQ_M (Mvar m1) (Mvar n1))) in H6 .
simpl in H6.
pose proof(IFSAME_B).
rewrite IFSAME_B in H6.
rewrite H6 in H.
assert(H7 : (Bvar 1) ## (if_then_else_B (Bvar 1) TRue FAlse)).
rewrite IFTF with (n:=1). reflexivity.
apply Forall_ELM_EVAL_B2 with (n:=1)(b:= (EQ_M (Mvar n1) (Mvar m1))) in H7 .
simpl in H7.
rewrite <- H7 in H.
assert(H8:  (if_then_else_B (EQ_M (Mvar m1) (Mvar n1)) [[ (n1+m1+1):= (Mvar m1)]](EQ_M (Mvar (n1+m1 +1)) (Mvar m1))
      FAlse) ##  (if_then_else_B (EQ_M (Mvar m1) (Mvar n1)) [[ (n1+m1+1):= (Mvar n1)]](EQ_M (Mvar (n1+m1+1)) (Mvar m1))
      FAlse)).
apply EQ_BRmsg_bol with (n1:= m1)(n2:= n1)(n3:=(n1+m1+1))(b1:= (EQ_M (Mvar (n1+m1+1)) (Mvar m1))) (b2:= FAlse).
simpl in H8.
assert(H9: m1<> n1+m1+1).
omega.
assert (H10: beq_nat m1 (n1+m1+1) = false).
apply beq_nat_false_iff  with (x:=m1)(y:=n1+m1+1) in H9.
assumption.
rewrite H10 in H8.
simpl in H8.
rewrite <- beq_nat_refl in H8.
rewrite <- H8 in H.
assert(H11:( EQ_M (Mvar m1) (Mvar m1)) ## TRue).
apply  EQmsg with (x:= (Mvar m1)) (y:= (Mvar m1)).
reflexivity.
rewrite H11 in H.
assert(H12 : (Bvar 1) ## (if_then_else_B (Bvar 1) TRue FAlse)).
rewrite IFTF with (n:=1).
reflexivity.
apply Forall_ELM_EVAL_B2 with (n:=1)(b := (EQ_M (Mvar m1)(Mvar n1))) in H12.
simpl in H12.
rewrite <- H12 in H.
apply H.
Qed.

(**
Theorem Example14_B: forall (n1 m1 : nat),  (EQ_B (Bvar n1) (Bvar m1) ) ##  (EQ_B (Bvar m1) (Bvar n1)).
Proof.
intros .
assert(H : (Bvar 1) ## (if_then_else_B (Bvar 1) TRue FAlse)).
rewrite IFTF with (n:=1). reflexivity.
apply Forall_ELM_EVAL_B with (n:=1)(b:= (EQ_B (Bvar n1) (Bvar m1))) in H .
simpl in H.
assert ( Eq: (EQ_B (Bvar n1) (Bvar n1)) ## TRue).
apply EQ_Bool with (x := (Bvar n1)) (y:= (Bvar n1)).
reflexivity.
rewrite <- Eq in H.
assert(H2: ( if_then_else_B (EQ_B (Bvar n1) (Bvar m1)) [ (n1+m1+1):= (Bvar n1)](EQ_B (Bvar (n1+m1 +1)) (Bvar n1))
      FAlse) ## (if_then_else_B (EQ_B (Bvar n1) (Bvar m1)) [(n1+m1+1):= (Bvar m1)](EQ_B (Bvar (n1+m1+1)) (Bvar n1))
      FAlse)).
apply EQ_BRbol_bol with (n1:= n1)(n2:= m1)(n3:=(n1+m1+1))(b1:= (EQ_B (Bvar (n1+m1+1)) (Bvar n1))) (b2:= FAlse).
simpl in H2.
assert(H4: n1<> n1+m1+1).
omega.
assert (H3: beq_nat n1 (n1+m1+1) = false).
SearchAbout beq_nat.
apply beq_nat_false_iff  with (x:=n1)(y:=n1+m1+1) in H4.
assumption.
rewrite H3 in H2.
simpl.
rewrite <- beq_nat_refl in H2.
rewrite H2 in H.

assert(H5 :  (Bvar 1) ##  (if_then_else_B (Bvar 1) TRue FAlse)).

rewrite IFTF with (n:=1). reflexivity.
apply Forall_ELM_EVAL_B2 with (n:=1)(b:= (EQ_B (Bvar m1) (Bvar n1))) in H5 .
simpl in H5.
rewrite H5 in H.
assert(H6:(if_then_else_B (Bvar (n1+m1+1)) (if_then_else_B (Bvar n1 ) TRue FAlse) FAlse) ## (if_then_else_B (Bvar n1)(if_then_else_B (Bvar (n1+m1+1)) TRue FAlse)(if_then_else_B (Bvar (n1+m1+1)) FAlse FAlse))).
pose proof(IFMORPH_B).
rewrite <- IFMORPH_B1 with (n2 := n1+m1+1)(b:=TRue ) (b1:=FAlse)(b2:= FAlse).
reflexivity.
apply Forall_ELM_EVAL_B with (n:=n1+m1+1)(b:= (EQ_B (Bvar n1) (Bvar m1))) in H6 .
simpl in H6. rewrite H3 in H6.
apply Forall_ELM_EVAL_B with (n:=n1)(b:= (EQ_M (Mvar m1) (Mvar n1))) in H6 .
simpl in H6.
rewrite H3 in H6.
rewrite <- beq_nat_refl in H6.
assert (H7: beq_nat (n1 + m1 + 1) n1 = false). omega.

simpl in H6.
pose proof(IFSAME_B).
rewrite IFSAME_B in H6.
rewrite H6 in H.
assert(H7 : (Bvar 1) ## (if_then_else_B (Bvar 1) TRue FAlse)).
rewrite IFTF with (n:=1). reflexivity.
apply Forall_ELM_EVAL_B2 with (n:=1)(b:= (EQ_M (Mvar n1) (Mvar m1))) in H7 .
simpl in H7.
rewrite <- H7 in H.
assert(H8:  (if_then_else_B (EQ_M (Mvar m1) (Mvar n1)) [[ (n1+m1+1):= (Mvar m1)]](EQ_M (Mvar (n1+m1 +1)) (Mvar m1))
      FAlse) ##  (if_then_else_B (EQ_M (Mvar m1) (Mvar n1)) [[ (n1+m1+1):= (Mvar n1)]](EQ_M (Mvar (n1+m1+1)) (Mvar m1))
      FAlse)).
apply EQ_BRANCH_M1 with (n1:= m1)(n2:= n1)(n3:=(n1+m1+1))(b1:= (EQ_M (Mvar (n1+m1+1)) (Mvar m1))) (b2:= FAlse).
simpl in H8.
assert(H9: m1<> n1+m1+1).
omega.
assert (H10: beq_nat m1 (n1+m1+1) = false).
apply beq_nat_false_iff  with (x:=m1)(y:=n1+m1+1) in H9.
assumption.
rewrite H10 in H8.
simpl in H8.
rewrite <- beq_nat_refl in H8.
rewrite <- H8 in H.
assert(H11:( EQ_M (Mvar m1) (Mvar m1)) ## TRue).
apply  EQmsg with (x:= (Mvar m1)) (y:= (Mvar m1)).
reflexivity.
rewrite H11 in H.
assert(H12 : (Bvar 1) ## (if_then_else_B (Bvar 1) TRue FAlse)).
rewrite IFTF with (n:=1).
reflexivity.
apply Forall_ELM_EVAL_B2 with (n:=1)(b := (EQ_M (Mvar m1)(Mvar n1))) in H12.
simpl in H12.
rewrite <- H12 in H.
apply H.
Qed.
**)