Definition id {A: Type} (a: A) : A := a.

Lemma id_step :
  forall {A: Type} (a: A), id a = a.
Proof.
reflexivity.
Qed.

Definition equiv {A B: Type} (f g: A -> B) : Prop :=
  forall (a: A), f a = g a.

Notation "f ~~ g" := (equiv f g)
                     (at level 100, right associativity).

Axiom func_extensionality: forall (A B:Type) (f g: A -> B),
  (f ~~ g) -> f = g.

Definition compose {A B C: Type} (f: A -> B) (g: B -> C) : A -> C :=
  fun (a: A) => g (f a).

Lemma compose_step :
  forall {A B C: Type} (f: A -> B) (g: B -> C) (a: A),
    (compose f g) a = g (f a).
Proof.
reflexivity.
Qed.

Notation "f ;; g" := (compose f g)
                    (at level 80, right associativity).

Lemma compose_id_l :
  forall {A B: Type} (f: A -> B),
    (@id A);; f ~~ f.
Proof.
intros A B f a.
rewrite -> compose_step.
rewrite -> id_step.
reflexivity.
Qed.

Lemma compose_id_r :
  forall {A B: Type} (f: A -> B),
    f;; (@id B) ~~ f.
Proof.
intros A B F a.
rewrite -> compose_step.
rewrite -> id_step.
reflexivity.
Qed.

Lemma compose_assoc :
  forall {A B C D: Type} (f: A -> B) (g: B -> C) (h: C -> D),
    (f;; g);; h ~~ f;; (g;; h).
Proof.
intros A B C D f g h a.
repeat rewrite -> compose_step.
reflexivity.
Qed.

Lemma compose_assoc_ext :
  forall {A B C D: Type} (f: A -> B) (g: B -> C) (h: C -> D),
    ((f;; g);; h) = (f;; (g;; h)).
Proof.
intros.
repeat rewrite -> compose_step.
reflexivity.
Qed.

Record Functor : Type := mkFunctor {
  FObj : Type -> Type;
  FMorph : forall {A B: Type} (f: A -> B), FObj A -> FObj B;
  FId : forall (A: Type), FMorph (@id A) ~~ @id (FObj A);
  FCompose : forall (A B C: Type) (f: A -> B) (g: B -> C),
               FMorph (f;; g) ~~ (FMorph f);; (FMorph g)
}.

Inductive list (A: Type) : Type :=
  | nil : list A
  | cons : A -> list A -> list A.

Arguments nil {A}.
Arguments cons {A}.

Fixpoint map {A B: Type} (f: A -> B) (l: list A) : list B :=
  match l with
  | nil => nil
  | cons a t => cons (f a) (map f t)
  end.

Lemma map_id :
  forall {A: Type}, map (@id A) ~~ @id (list A).
Proof.
intros A a.
induction a as [| first rest IH].
 + rewrite -> id_step.
   reflexivity.
 + rewrite -> id_step.
   simpl.
   rewrite -> IH.
   repeat rewrite -> id_step.
   reflexivity.
Qed.

Lemma map_compose :
  forall {A B C: Type} (f: A -> B) (g: B -> C),
    map (f;; g) ~~ (map f);; (map g).
Proof.
intros.
intros a.
induction a as [| first rest IH].
+ reflexivity.
+ simpl.
  repeat rewrite -> IH.
  reflexivity.
Qed.

Definition ListF : Functor := {|
  FObj := list;
  FMorph := @map;
  FId := @map_id;
  FCompose := @map_compose
|}.

Record Monad: Type :=
mkMonad
  {
    M: Functor;
    Eta{A: Type}: A -> FObj M A;
    Mu: forall {A: Type}, FObj M (FObj M A) -> FObj M A;
    MuNatural : forall {A: Type},
      FMorph M (@Mu A) ;; Mu ~~ Mu ;; Mu;
    EtaNatural1 : forall {A: Type}, @Eta(FObj M A) ;; Mu ~~ @id(FObj M A);
    EtaNatural2 : forall {A: Type}, FMorph M (@Eta A) ;; (Mu) ~~ @id(FObj M A)
  }.

Fixpoint concat {A: Type} (xs ys: list A): list A :=
  match xs with
  | nil => ys
  | cons xs_first xs_rest => cons xs_first (concat xs_rest ys)
  end.

Lemma nil_right_concat_ident :
  forall {A: Type} (xs: list A),
    concat xs nil = xs.
Proof.
intros.
induction xs as [|first rest IH].
+ reflexivity.
+ simpl.
  rewrite -> IH.
  reflexivity.
Qed.

Lemma nil_left_concat_ident :
  forall {A: Type} (xs: list A),
    concat nil xs = xs.
Proof. reflexivity. Qed.

Fixpoint flatten {A: Type} (xs: list (list A)): list A :=
  match xs with
  | nil => nil
  | cons xs_first xs_rest => concat xs_first (flatten xs_rest)
  end.

Lemma concat_assoc:
  forall {A: Type} (xs ys zs: list A),
  concat xs (concat ys zs) = concat (concat xs ys) zs.
Proof. induction xs as [| first_xs rest_xs IH].
  + reflexivity.
  + simpl. destruct ys as [| first_ys rest_ys].
    - simpl. rewrite -> nil_right_concat_ident. reflexivity.
    - simpl. destruct zs as [| first_zs rest_zs].
      * simpl. repeat rewrite -> nil_right_concat_ident. reflexivity.
      * rewrite <- IH. reflexivity.
Qed.

Lemma flatten_natural :
  forall {A: Type} (xs: list (list (list A))),
    (map flatten ;; flatten) xs = (flatten ;; flatten) xs.
Proof.
intros.
repeat rewrite -> compose_step.
induction xs as [|first_xs rest_xs IH].
+ reflexivity.
+ simpl.
  rewrite -> IH.
  induction first_xs as [|first_x rest_x IH2].
  - reflexivity.
  - simpl.
    destruct first_x as [| first_first_x rest_first_x].
    * simpl.
      rewrite <- IH2.
      reflexivity.
    * simpl.
      rewrite <- IH2.
      rewrite <- IH.
      destruct rest_x as [| first_rest_x rest_rest_x].
      ++ simpl.
         rewrite -> nil_right_concat_ident.
         reflexivity.
      ++ simpl.
         rewrite -> IH.
         destruct rest_rest_x as [| f_r_r_x r_r_r_x].
         +++ simpl.
             rewrite -> nil_right_concat_ident.
             rewrite -> concat_assoc.
             reflexivity.
        +++ simpl. repeat rewrite -> concat_assoc. reflexivity.
Qed.

Definition cons_simp {A: Type} (x: A) := cons x nil.

Lemma cons_natural_1 :
  forall {A: Type} (xs: list A),
    (cons_simp ;; flatten) xs = xs.
Proof.
intros.
rewrite -> compose_step.
simpl.
induction xs as [| first rest IH].
+ reflexivity.
+ simpl.
  rewrite -> nil_right_concat_ident.
  reflexivity.
Qed.

Lemma cons_natural_2 :
  forall {A: Type} (xs: list A),
    ((map cons_simp) ;; flatten) xs = xs.
Proof.
intros.
rewrite -> compose_step.
induction xs as [| first rest IH].
+ reflexivity.
+ simpl.
  rewrite -> IH.
  reflexivity.
Qed.

Definition ListM: Monad := {|
  M := ListF;
  Eta(A: Type):= cons_simp;
  Mu(A: Type)(xs: list(list(A))) := flatten xs;
  MuNatural := @flatten_natural;
  EtaNatural1 := @cons_natural_1;
  EtaNatural2 := @cons_natural_2
|}.

Record KleisliTriple: Type :=
mkTriple {
  T: Type -> Type;
  Unit(A: Type): A -> T(A);
  Bind: forall {A B: Type}(f: A -> T(B)), T(A) -> T(B);
  UnitReturn(A: Type): (Bind (Unit A)) ~~ @id(T A);
  UnitComposeReturn(A B: Type): forall (f: A -> T(B)),
    Unit A ;; Bind f ~~ f;
  BindProp(A B C: Type): forall (f: A -> T(B)) (g: B -> T(C)),
    Bind (f ;; (Bind g)) ~~ (Bind f) ;; (Bind g);
  Mult{A: Type}: T(T(A)) -> T(A) := Bind (@id (T A))
}.

Definition fmorph_from_triple (kt: KleisliTriple) {A B: Type} (f: A -> B): (T kt A -> T kt B) :=
(Bind kt) (f ;; @Unit kt B).

Lemma fid_from_triple(kt: KleisliTriple): forall {A: Type}, @fmorph_from_triple kt A A id ~~ id.
Proof.
intros.
unfold fmorph_from_triple.
unfold equiv.
intros a.
rewrite id_step.
cut (Bind kt (id ;; Unit kt A) ~~ Bind kt (Unit kt A)).
- unfold equiv.
  intros.
  rewrite -> H.
  rewrite -> UnitReturn.
  reflexivity.
- unfold equiv.
  intros.
  repeat rewrite -> UnitReturn.
  reflexivity.
Qed.

Lemma fcompose_from_triple(kt: KleisliTriple): forall (A B C: Type) (f: A -> B) (g: B -> C),
  fmorph_from_triple kt (f ;;g) ~~ fmorph_from_triple kt f ;; fmorph_from_triple kt g.
Proof.
intros.
unfold fmorph_from_triple.
unfold equiv.
intros.
rewrite <- BindProp.
cut (((f;; Unit kt B);; Bind kt (g;; Unit kt C)) = (f;; (Unit kt B;; Bind kt (g;; Unit kt C)))).
+ intros.
  rewrite H.
  cut ((Unit kt B;;Bind kt (g;; Unit kt C)) = (g;;Unit kt C)).
  - intros.
    rewrite H0.
    reflexivity.
  - cut ((Unit kt B;; Bind kt (g;; Unit kt C)) ~~ (g;; Unit kt C)).
    * intros. apply func_extensionality. apply H0.
    * apply UnitComposeReturn.
+ cut (((f;; Unit kt B);; Bind kt (g;; Unit kt C)) ~~ (f;; Unit kt B;; Bind kt (g;; Unit kt C))).
  - apply func_extensionality.
  - apply compose_assoc.
Qed.

Definition mu_from_triple (kt: KleisliTriple) {A: Type}: (T kt (T kt A)) -> T kt A :=
Bind kt (@id (T kt A)).

Lemma mu_natural_from_triple (kt: KleisliTriple): forall (A: Type),
  (fmorph_from_triple kt) (@mu_from_triple kt A) ;; mu_from_triple kt ~~
  mu_from_triple kt ;; mu_from_triple kt.
Proof.
  intros.
  unfold fmorph_from_triple.
  unfold mu_from_triple.
  unfold equiv.
  intros.
  rewrite <- BindProp.
  cut (((Bind kt id;; Unit kt (T kt A));; Bind kt id) = (Bind kt id;; (Unit kt (T kt A);; Bind kt id))).
  + intros.
    rewrite -> H.
    repeat rewrite -> compose_step.
    cut ((Unit kt (T kt A);; Bind kt id) = id).
    - intros H0.
    rewrite H0.
    cut ((@Bind kt (T kt (T kt A)) A (Bind kt id;; id)) ~~ (Bind kt id ;; Bind kt id)).
    * intros.
      cut ((Bind kt id (Bind kt id a)) = (Bind kt id ;; Bind kt id) a).
      ++ intros. rewrite H2.
         cut (forall (b: T kt (T kt (T kt A))), Bind kt (Bind kt id;; id) b = (Bind kt id;; Bind kt id) b).
         -- intros. apply H3.
         -- apply BindProp.
      ++ cut (forall (b: T kt (T kt (T kt A))), Bind kt id (Bind kt id b) = (Bind kt id;; Bind kt id) b).
         -- intros.  apply H2.
         -- cut (forall c: (T kt (T kt (T kt A))), Bind kt id (Bind kt id c) = (Bind kt id;; Bind kt id) c) .
            ** intros. apply H2.
            ** intros. rewrite compose_step. reflexivity.
    * apply BindProp.
  - cut ((@id (T kt A) = Bind kt (Unit kt A))).
     * intros.
       cut ((Unit kt (T kt A);; Bind kt id) ~~ id).
       ++ intros. apply func_extensionality. apply H1.
       ++ apply UnitComposeReturn.
     * cut (id ~~ Bind kt (Unit kt A)) .
       ++ apply func_extensionality.
       ++ unfold equiv. symmetry.
          cut (forall b: T kt A, Bind kt (Unit kt A) b = id b).
          -- intros. apply H0.
          -- intros. apply UnitReturn.
  + cut (((Bind kt id;; Unit kt (T kt A));; Bind kt id) ~~(Bind kt id;; Unit kt (T kt A);; Bind kt id)).
  - intros. apply func_extensionality. apply H.
  - apply compose_assoc.
Qed.

Lemma eta_natural_from_triple_1 (kt: KleisliTriple): forall (A: Type),
(@Unit kt (T kt A)) ;; mu_from_triple kt ~~ @id (T kt A).
Proof. intros. unfold mu_from_triple. apply UnitComposeReturn.
Qed.

Lemma eta_natural_from_triple_2 (kt: KleisliTriple): forall (A: Type),
(fmorph_from_triple kt) (Unit kt A) ;; mu_from_triple kt ~~ id.
Proof. unfold fmorph_from_triple. unfold mu_from_triple.
  unfold equiv.
  intros.
  cut ((Bind kt (Unit kt A;; Unit kt (T kt A));; Bind kt id) = Bind kt ((Unit kt A;; Unit kt (T kt A));; Bind kt id)).
  + intros. rewrite H.
    cut (((Unit kt A;; Unit kt (T kt A));; Bind kt id) = (Unit kt A;; (Unit kt (T kt A);; Bind kt id))).
    - intros.
      rewrite H0.
      cut ((Unit kt (T kt A);; Bind kt id) = id).
      * intros.
        rewrite H1.
        cut ((Unit kt A;; id) = Unit kt A).
        ++ intros. rewrite H2. rewrite UnitReturn. reflexivity.
        ++ cut ((Unit kt A;; id) ~~ Unit kt A) .
           -- intros. apply func_extensionality. apply H2.
           -- apply compose_id_r.
      * cut ((Unit kt (T kt A);; Bind kt id) ~~ id).
        ++ intros. apply func_extensionality. apply H1.
        ++ apply UnitComposeReturn.
    - apply compose_assoc_ext.
  + cut ((Bind kt (Unit kt A;; Unit kt (T kt A));; Bind kt id) ~~ Bind kt ((Unit kt A;; Unit kt (T kt A));; Bind kt id)).
    - intros. apply func_extensionality. apply H.
    - remember (Unit kt A;; Unit kt (T kt A)) as f.
      remember id as g.
      unfold equiv. symmetry. apply BindProp.
Qed.

(*Definitions for Ringads.*)

Class MZero `(m: Monad) : Type := {
  Zero{A: Type}: FObj (M m) A;
  MuDistributesZero: forall {A: Type}, Mu m (@Zero (FObj (M m) A)) = Zero
}.

Class MPlus `(m: Monad): Type := {
  Plus{A: Type}: FObj (M m) A -> FObj (M m) A -> FObj (M m) A;
  MuDistributesPlus: forall {A: Type} (x y: FObj (M m) (FObj (M m) A)), Mu m (Plus x y) = Plus (Mu m x) (Mu m y)
}.

Class Ringad `(m: Monad, mzero: MZero(m), mplus: MPlus(m)): Type := {
  MZeroUnit: forall {A: Type} (xs: FObj (M m) A),
    (Plus xs Zero = xs) /\ (Plus Zero xs = xs)
}.

Lemma flatten_nil: forall (A: Type), Mu ListM (@nil (list A)) = @nil A.
Proof. intuition. Qed.

Instance listZero: MZero(ListM):= {
  Zero{A: Type} := @nil A;
  MuDistributesZero := flatten_nil
}.

Lemma flatten_distributes_concat: forall (A : Type) (xs ys : FObj (M ListM) (FObj (M ListM) A)),
Mu ListM (concat xs ys) = concat (Mu ListM xs) (Mu ListM ys).
Proof.
intros. simpl.
induction xs as [| first_xs rest_xs IH].
  + reflexivity.
  + induction ys as [| first_ys rest_ys IH2].
    - simpl.
      repeat rewrite -> nil_right_concat_ident.
      reflexivity.
    - simpl.
      rewrite -> concat_assoc.
      induction first_xs as [|first_first_xs rest_first_xs IH3].
        * repeat rewrite -> nil_left_concat_ident.
          rewrite <- concat_assoc.
          induction rest_xs as [|first_rest_xs rest_rest_xs IH4].
          ++ simpl. reflexivity.
          ++ induction first_ys as [|first_first_ys rest_first_ys IH5].
          Admitted. (* Do this later. *)

Instance listConcat: MPlus ListM := {
  Plus{A: Type} := @concat A;
  MuDistributesPlus := flatten_distributes_concat
}.

Lemma nil_concat_ident : forall (A : Type) (xs : FObj (M ListM) A),
Plus xs Zero = xs /\ Plus Zero xs = xs.
Proof. simpl. split.
+ apply nil_right_concat_ident.
+ apply nil_left_concat_ident.
Qed.

Instance list_ringad: Ringad ListM listZero listConcat := {
  MZeroUnit:= nil_concat_ident
}.

Import Nat.

(*type A with linear order*)
Inductive Sorted : list nat -> Prop :=
  | Sorted_nil : Sorted nil
  | Sorted_cons_1 a : Sorted (cons a nil)
  | Sorted_cons_n a b l :
      Sorted (cons b l) -> a <= b -> Sorted (cons a (cons b l)).

Lemma inversion_sorted: forall (xs: list nat),
Sorted xs ->
xs = nil \/
(exists single_x, xs = cons single_x nil) \/
exists a b l, Sorted (cons b l) /\ a <= b /\ xs = cons a (cons b l).
Proof. intros. destruct H.
+ left. reflexivity.
+ right. left. exists a. reflexivity.
+ right. right. exists a, b, l. split.
  - apply H.
  - split.
    * apply H0.
    * reflexivity.
Qed.

Lemma inversion_sorted_2: forall (a b: nat) (l: list nat),
Sorted (cons a (cons b l)) -> a <= b.
Proof.
Admitted.

Fixpoint mergeNat (xs ys: list nat): list nat :=
  let fix merge_help ys :=
  match xs, ys with
  | nil, _ => ys
  | _, nil => xs
  | cons first_xs rest_xs, cons first_ys rest_ys =>
    if first_xs <=? first_ys then cons first_xs (mergeNat rest_xs ys)
    else cons first_ys (merge_help rest_ys)
    end
   in merge_help ys.

Require Import Coq.Arith.Compare_dec.
Lemma merge_sorted_lists: forall (xs ys: list nat),
Sorted xs -> Sorted ys -> Sorted (mergeNat xs ys).
Proof. induction xs, ys.
+ intros. apply H.
+ intros. apply H.
+ intros. apply H.
(*
+ intros. simpl. remember (a <=? n) as b. destruct b.
  - cut (Sorted (mergeNat xs (cons n ys))).
    * destruct xs.
      ++ intros. simpl. apply Sorted_cons_n.
        -- apply H.
        -- apply leb_complete. symmetry. apply Heqb.
      ++ intros. simpl. remember (n0 <=? n) as b1. destruct b1.
        -- destruct xs.
          ** simpl. apply Sorted_cons_n.
             +++ apply Sorted_cons_n.
                 apply H. apply leb_complete. symmetry. apply Heqb1.
             +++ destruct H.
                 apply inversion_sorted_2 in H.
                 apply H.
          ** apply Sorted_cons_n.
             +++ simpl. remember (n1 <=? n) as b2. destruct b2.
                 --- apply Sorted_cons_n.
                    *** destruct xs.
                      ++++ simpl.
                           apply Sorted_cons_n.
                           apply H.
                           apply leb_complete.
                           symmetry.
                           apply Heqb2.
                      ++++ simpl. remember (n2 <=? n) as b3. destruct b3.
                           ---- apply Sorted_cons_n.
                              **** Admitted.
 *)


Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma prime329719147332060395689499: prime 329719147332060395689499.
Proof.
 apply (Pocklington_refl
(Ell_certif
329719147332060395689499
8209062
((40165264598163841,1)::nil)
329719147332060395595419
9834496
0
3136)
((SPock_certif
40165264598163841
2
((303179835433, 1)::nil))
::
         (Pock_certif 303179835433 5 ((7951, 1)::(2,3)::nil) 59386) ::
         (Proof_certif 7951 prime7951) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Time Qed.


Require Export Coq.Logic.FunctionalExtensionality.

Axiom tertium_non_datur : forall (P : Prop), P \/ ~P.

Lemma FunctionUniq : forall {X : Type} (f : X -> X) (x x' : X),
  x = x' -> f x = f x'.
Proof.
  intros.
  rewrite H.
  apply equal_f.
  reflexivity.
Qed.

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

Class Group (X : Type) (f : X -> X -> X) := {
  e : X;
  Assoc : forall (a b c : X), f a (f b c) = f (f a b) c;
  Inver : forall x e, exists x', f x' x = e;
  Ident : forall (x : X), f e x = x;
}.

Lemma group_injective_l : forall {X} {f} (g : Group X f) y x x',
  f y x = f y x' -> x = x'.
Proof.
  intros.
  destruct g eqn:G. clear G.
  destruct (tertium_non_datur (x = x')) as [T | T].
  - apply T.
  - apply ex_falso_quodlibet.
    apply T. destruct (Inver0 y e) as [y']. pose proof H0. apply Ident0 in H0.
    apply (FunctionUniq (f y')) in H.
    rewrite Assoc in H. rewrite H0 in H.
    rewrite Assoc in H. rewrite H0 in H.
    rewrite H2 in H. rewrite H2 in H.
    apply H.
Qed.

Lemma group_id_r : forall {X} {f} (g : Group X f), exists e, forall x, f x e = x.
Proof.
  intros.
  destruct g eqn:G.
  destruct Ident0 as [e].
  exists e.
  intros.
  destruct (Inver0 x e) as [x'].
  apply (group_injective_l g x').
  rewrite Assoc.
  rewrite H. rewrite e0. reflexivity.
  apply e0.
Qed.

Lemma group_inv_r : forall {X} {f} (g : Group X f) x e, exists x',
  (forall y, f e y = y) -> f x x' = e.
Proof.
  intros.
  pose proof g.
  destruct g.
  destruct (Inver x e) as [x'].
  exists x'.
  intros.
Admitted.

Lemma group_id_equal : forall {X} {f} (g : Group X f) e e',
  (forall x, f x e = x) -> (forall x, f e' x = x) -> e = e'.
Proof.
  intros.
  rewrite <- (H0 e).
  rewrite <- (H e').
  rewrite H. rewrite H.
  reflexivity.
Qed.

Lemma group_inv_equal : forall {X} {f} (g : Group X f) x x' x'' e,
  (forall y, f e y = y) -> f x x' = e -> f x'' x = e -> x' = x''.
Proof.
  intros.
  pose proof g.
  destruct H2.
  apply (group_injective_l g x).
  rewrite H0.
  apply (group_injective_l g x'').
  rewrite Assoc0. rewrite H1.
  rewrite H.
  destruct (group_id_r g) as [e'].
  assert (e' = e). { apply (group_id_equal g). apply H2. apply H. }
  rewrite <- H3. apply H2.
Qed.

Definition flip {X : Type} (f : X -> X -> X) (a : X) (b : X) : X :=
  f b a.

Theorem group_flip : forall {X} {f}, Group X f -> Group X (flip f).
Proof.
  intros.
  pose proof H.
  destruct H.
  split.
  - unfold flip. symmetry. apply Assoc0.
  - unfold flip. intros.
    destruct(Inver0 x e) as [x'].
    exists x'. intros. destruct Ident0 as [e'].
    assert (e = e'). { rewrite <- (H2 e). rewrite H1. reflexivity. }
    rewrite <- H3 in H2. clear H3. clear e'.
    pose proof H2.
    apply H in H2.
    destruct (group_inv_r H0 x e) as [x''].
    pose proof H3. apply H4 in H3.
    assert (x' = x''). { apply (group_inv_equal H0 x e).  }

intros. unfold flip. destruct Ident0 as [x'].
    exists x'. intros.

Lemma group_injective_r : forall {X} {f} (g : Group X f) y x x',
  f y x = f y x' -> x = x'.
Proof.
  intros.
  assert (Group X (flip f)).
  -

Section myGroup.

Variable X : Type.
Variable f : X -> X -> X.
Variable e : X.

Definition Group : Prop :=
     (forall (x y z: X), f z (f x y) = f (f z x) y)   (* Associativity        *)
  /\ (forall (x : X), f e x = x)                      (* Identity             *)
  /\ (forall (x : X), exists (x' : X), f x' x = e).   (* Existence of inverse *)

Lemma GroupInjectiveL : Group -> forall (y x x' : X), f y x = f y x' -> x = x'.
Proof.
  intros [Assc [Ident Inv]].
  intros.
  destruct (tertium_non_datur (x = x')).
  - apply H0.
  - apply ex_falso_quodlibet.
    apply H0. destruct (Inv y) as [y'].
    apply (FunctionUniq (f y')) in H.
    rewrite -> Assc in H.
    rewrite -> Assc in H.
    rewrite H1 in H.
    rewrite Ident in H.
    rewrite Ident in H.
    apply H.
Qed.

Lemma ExistsIdR : Group ->
  forall (x : X), f x e = x.
Proof.
  intros [Assc [Ident Inv]] x.
  destruct (Inv x) as [x'].
  apply (GroupInjectiveL (Assc /\ Ident /\ Inv) x').
  rewrite Assc. rewrite H.
  apply (Ident e).
Qed.

Lemma ExistsInverseR : Group ->
  forall (x : X), exists (x' : X), f x x' = e.
Proof.
  unfold Group.
  intros.
  decompose record H.
  destruct (H3 x).
  exists x0.
  apply (GroupInjectiveL H x0).
  rewrite H0. rewrite H1. rewrite H2.

  destruct (H3 x0).
  apply (GroupInjectiveL H x1).
  rewrite H0. rewrite H2.
  rewrite H0.
  reflexivity.
Qed.

End myGroup.

Definition Group {X : Type} (f : X -> X -> X) : Prop :=
     forall (x y z: X), f z (f x y) = f (f z x) y   (* Associativity *)
  /\ forall (x y: X), exists (x' : X), f x' x = y.  (* Existence of solutions *)

(* Miscellaneous group lemmas *)

(* Lemma InjectiveL {X : Type} (f : X -> X -> X) :
  Group f ->
*)

Lemma ExistsNeutralL {X : Type} (f : X -> X -> X)

Lemma ExistsNeutralR {X : Type} (f : X -> X -> X) :
  Group f -> exists (e : X), forall (x : X), f x e = x.
Proof.
  intros.
  destruct H.
  destruct H0.
  unfold ExistsNeutralL in H0.
  destruct H0 as [e]. exists e.
  intros.
  assert (forall (x : X), f x e = f e x).
  { intros y. unfold Assoc in H.
    unfold ExistsInverseL in H1.
    destruct (H1 y e) as [y'].
  }
  rewrite <- (H0 x).


(**
プログラミング Coq --- 使えるタクティク集

http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt5.html
をSSReflectに書き直した。
*)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Goal forall (P Q R S : Prop), (S /\ P) /\ (Q /\ R) -> (P /\ S) /\ (R /\ Q).
Proof.
  move=> P Q R S.
  elim.
  have H1 : forall (X Y : Prop), X /\ Y -> Y /\ X => H H0.
    by elim.
  split.
  - by apply: (H1 S P H).
  - by apply: (H1 Q R H0).
Qed.

Theorem app_eq_nil :
  forall (A : Type) (l l' : seq A), l ++ l' = nil -> l = nil /\ l' = nil.
Proof.
  move=> A l l' H.
  split.
  - by elim: l H.
  - elim: l' H.
    + by [].
    + by elim: l.
Qed.

Goal forall (A : Type) (a : A), nil <> a :: nil.
Proof.
  by [].
Qed.

Goal forall (n m : nat) (f : nat -> nat),
       f n = n -> S (f (f n)) = S m -> n = m.
Proof.
  (* congruence. *)
  move=>  n m f H H0.
  case: H0.
  by rewrite 2!H.
Qed.

Goal forall (A : Type) (x y : A),
       x :: y :: nil <> x :: nil.
Proof.
  (* congruence. *)
  by [].
Qed.

Goal forall (P Q : nat -> Prop) (a : nat), P (a * 2) \/ Q (a * 2).
Proof.
  move=> P Q a.
  rewrite (_: (Q (a * 2)) = (Q (2 * a))).
  (* replace (Q (a * 2)) with (Q (2 * a)). *)
  Admitted.                                 (* OK *)

Goal forall (P : nat -> nat -> Prop) (a b c d : nat),
       P a d -> a = b -> c = d -> P b c.
Proof.
  move=> P a b c d H H0 H1.
  subst.
  by [].
Qed.

Fixpoint removelast (A : Type) (l : seq A) : seq A :=
  match l with
    | nil => nil
    | a :: nil => nil
    | a :: l => a :: removelast l
  end.

Lemma removelast_cons : forall (A : Type) (a : A) (l : list A), l <> nil ->
  removelast (a :: l) = a :: removelast l.
Proof.
  move=> A a.
  by elim=> [//= | a' l] => H0 H1.
Qed.

Lemma app_is_nil (A : Type) (l l' : seq A) : l ++ l' = [::] -> l' = [::].
Proof.
  by elim: l.
Qed.
(*
  elim: l => [//= | a l H H0].
  inversion H0.
*)

Lemma contra' (S : Type) (a b c d : S) : (a = b -> c = d) -> (c <> d -> a <> b).
Proof.
  move=> H.
  rewrite /not => H0 H1.
  by apply H0,H,H1.
Qed.

Lemma removelast_app : forall (A : Type) (l l' : seq A),
                         l' <> nil -> removelast (l ++ l') = l ++ removelast l'.
Proof.
  move=> A l l' H.
  elim: l => [//= | a l IHl].
  rewrite 2!cat_cons.
  rewrite removelast_cons.
  - by rewrite IHl.
  - apply: contra' H.                       (* H は generalize *)
    by apply: app_is_nil.
Qed.

Inductive InList (A : Type) (a : A) : list A -> Prop :=
| headIL : forall xs, InList a (a :: xs)
| consIL : forall x xs, InList a xs -> InList a (x :: xs).

Goal forall (A : Type)(l : seq A) (a a' : A),
       InList a (a' :: l) -> a = a' \/ InList a l.
Proof.
  move=> A l a a' H.
  by inversion H; [left | right].
Qed.

(* END *)


(*common header begin*)
Require Import Utf8.
From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Maximal Implicit Insertion.

Require Import List.
Import ListNotations.
(*common header end*)

Require Import Omega.
Require Import Bool.

(*used for free variables*)
Definition label : Set := nat * nat.

Module Label.
Lemma eq_dec : forall (a b : label), {a = b} + {a <> b}.
Proof.
case => a1 a2; case => b1 b2.
have := Nat.eq_dec a1 b1; have := Nat.eq_dec a2 b2.
case => ?; case => ?; first auto.
all : right; case; auto.
Qed.

Definition eqb (a : label) (b : label) : bool :=
  match a, b with
  | (a1, a2), (b1, b2) => (a1 =? b1) && (a2 =? b2)
  end.

Lemma eqb_eq : forall (a b : label), (eqb a b = true) <-> a = b.
Proof.
move => a b.
constructor.
rewrite -> (surjective_pairing a), (surjective_pairing b); cbn.
case /andb_true_iff.
by move /Nat.eqb_eq => -> /Nat.eqb_eq => ->.

move => ->.
rewrite -> (surjective_pairing b); cbn.
by rewrite <- ? beq_nat_refl.
Qed.

Lemma neqb_neq : forall (a b : label), (eqb a b = false) <-> a <> b.
Proof.
case => a1 a2; case => b1 b2; cbn.
rewrite andb_false_iff; rewrite ? Nat.eqb_neq. split.

case; intro; case; intros; by subst.

have := Nat.eq_dec a1 b1; have := Nat.eq_dec a2 b2.
firstorder auto.
Qed.
End Label.


Require Import Reals.
Require Import Psatz.
Require Import Ensembles.
Local Open Scope R.

Definition continuous_on_set (AUTO : Ensemble R) (f : {x : R | A x} -> R) :=
  forall x, continuity_pt f x.

Definition D (x : R) :=
  0 <= x <= 1 \/ x = 2 \/ 3 <= x < 4.

Check {x : R | D x} -> R.

Theorem continuous_at_2 : forall (f : {x : R | D x} -> R), continuous_on_set f D.
Proof.
  intros f.
  unfold continuous_on_set.
  intros x H.
  unfold continuity_pt, continue_in, limit1_in, limit_in.
  intros eps H__eps.
  unfold D in H.
  unfold D_x.


Require Import List.
Require Import Setoid. (* Generalized rewriting *)
Require Import FSets. (* Efficient functional sets *)
Require Import FMaps. (* Efficient functional maps *)
Require Import PArith. (* Positives *)
From VFA Require Import Perm.

Module E := PositiveOrderedTypeBits.
Print Module E.
Print E.t.

Module S <: FSetInterface.S := PositiveSet.
Print Module PositiveSet.
Print Module S.
Print S.elt.

Module M <: FMapInterface.S := PositiveMap.
Print Module M.
Print M.E.

Module WF := WFacts_fun E M. (* Library of useful lemmas about maps *)
Module WP := WProperties_fun E M. (* More useful stuff about maps *)
Print Module WF.
Print Module WP.
Check E.lt.

Lemma lt_strict: StrictOrder E.lt.
Proof. exact M.ME.MO.IsTO.lt_strorder. Qed.

Lemma lt_proper: Proper (eq ==> eq ==> iff) E.lt.
Proof. exact M.ME.MO.IsTO.lt_compat. Qed.

(* TODO *)


(***************************************************************************
* Preservation and Progress for mini-ML (CBV) - Definitions                *
* Arthur Charguéraud, March 2007, Coq v8.1                                 *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory List.

(* ********************************************************************** *)
(** ** Description of types *)

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_bvar  : nat -> typ
  | typ_fvar  : var -> typ
  | typ_arrow : typ -> typ -> typ.

(** Types are inhabited, giving us a default value. *)

Definition typ_def := typ_bvar 0.

(** Type schemes. *)

Record sch : Set := Sch {
  sch_arity : nat ;
  sch_type  : typ }.

(** Opening body of type schemes. *)

Fixpoint typ_open (T : typ) (Vs : list typ) {struct T} : typ :=
  match T with
  | typ_bvar i      => nth i Vs typ_def
  | typ_fvar x      => typ_fvar x
  | typ_arrow T1 T2 => typ_arrow (typ_open T1 Vs) (typ_open T2 Vs)
  end.

(** Opening body of type schemes with variables *)

Definition typ_fvars :=
  List.map typ_fvar.

Definition typ_open_vars T Xs :=
  typ_open T (typ_fvars Xs).

(** Instanciation of a type scheme *)

Definition sch_open M :=
  typ_open (sch_type M).

Definition sch_open_vars M :=
  typ_open_vars (sch_type M).

Notation "M ^^ Vs" := (sch_open M Vs)
  (at level 67, only parsing) : typ_scope.
Notation "M ^ Xs" :=
  (sch_open_vars M Xs) (only parsing) : typ_scope.

Bind Scope typ_scope with typ.
Open Scope typ_scope.

(** Locally closed types *)

Inductive type : typ -> Prop :=
  | type_fvar : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2).

(** List of n locally closed types *)

Definition types := list_for_n type.

(** Body of a scheme *)

Definition typ_body n T :=
  exists L, forall Xs,
  fresh L n Xs ->
  type (typ_open_vars T Xs).

(** Definition of a well-formed scheme *)

Definition scheme M :=
   typ_body (sch_arity M) (sch_type M).

(* ********************************************************************** *)
(** ** Description of terms *)

(** Grammar of terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_let  : trm -> trm -> trm
  | trm_app  : trm -> trm -> trm.

(** Opening term binders. *)

Fixpoint trm_open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => if k === i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (trm_open_rec (S k) u t1)
  | trm_let t1 t2 => trm_let (trm_open_rec k u t1) (trm_open_rec (S k) u t2)
  | trm_app t1 t2 => trm_app (trm_open_rec k u t1) (trm_open_rec k u t2)
  end.

Definition trm_open t u := trm_open_rec 0 u t.

Notation "{ k ~> u } t" := (trm_open_rec k u t) (at level 67).
Notation "t ^^ u" := (trm_open t u) (at level 67).
Notation "t ^ x" := (trm_open t (trm_fvar x)).

(** Locally closed termessions *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_let : forall L t1 t2,
      term t1 ->
      (forall x, x \notin L -> term (t2 ^ x)) ->
      term (trm_let t1 t2)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2).

(** Definition of the body of an abstraction *)

Definition term_body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

(* ********************************************************************** *)
(** ** Description of typing *)

(** Definition of typing environments *)

Definition env := env sch.

(** The typing judgment *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x M Us,
      ok E ->
      binds x M E ->
      types (sch_arity M) Us ->
      scheme M ->
      E |= (trm_fvar x) ~: (M ^^ Us)
  | typing_abs : forall L E U T t1,
      type U ->
      (forall x, x \notin L ->
        (E & x ~ Sch 0 U) |= (t1 ^ x) ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_let : forall M L1 L2 E T2 t1 t2,
      (forall Xs, fresh L1 (sch_arity M) Xs ->
         E |= t1 ~: (M ^ Xs)) ->
      (forall x, x \notin L2 -> (E & x ~ M) |= (t2 ^ x) ~: T2) ->
      E |= (trm_let t1 t2) ~: T2
  | typing_app : forall E S T t1 t2,
      E |= t1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T

where "E |= t ~: T" := (typing E t T).

(* ********************************************************************** *)
(** ** Description of the semantics *)

(** Grammar of values *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1, term (trm_abs t1) -> value (trm_abs t1).

(** Reduction rules *)

Inductive red : trm -> trm -> Prop :=
  | red_abs : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | red_let : forall t1 t2,
      term (trm_let t1 t2) ->
      value t1 ->
      red (trm_let t1 t2) (t2 ^^ t1)
  | red_let_1 : forall t1 t1' t2,
      term_body t2 ->
      red t1 t1' ->
      red (trm_let t1 t2) (trm_let t1' t2)
  | red_app_1 : forall t1 t1' t2,
      term t2 ->
      red t1 t1' ->
      red (trm_app t1 t2) (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_app t1 t2) (trm_app t1 t2').

Notation "t --> t'" := (red t t') (at level 68).

(* ********************************************************************** *)
(** ** Description of the results *)

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ exists t', t --> t'.


Module Type Magic.
  Parameter LEVEL : nat.
  Parameter nodesTotal : nat.
  Parameter nodeCap : nat.
End Magic.

Module MyModule (m : Magic).
  Definition foo := S m.LEVEL.

  Lemma foo_is_OK: foo > 0.
  Proof.
    intros. unfold foo. auto with arith.
  Qed.

End MyModule.

Module Magic3 <: Magic.
  Definition LEVEL := 3.
  Definition nodesTotal := 60.
  Definition nodeCap := 4.
End Magic3.

Module MyModule3 := MyModule(Magic3).

Eval compute in MyModule3.foo.
Check MyModule3.foo_is_OK.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base modular_hilbert sltype.

Require Import CTL_def dags demo agreement.
Require Import hilbert hilbert_ref hilbert_LS hilbert_Eme90.
Require Import gen_def gen_dec gen_hsound gen_ref.

(** * Main Results *)

(** Equivalence of Hilbert Systems *)

Theorem IC_soundness s : IC.prv s -> forall (M:cmodel) (w:M), eval s w.
Proof. exact: IC.soundness. Qed.

Theorem IC_LS_equivalence s : IC.prv s <-> LS.prv s.
Proof. split. exact: LS_translation. exact: LS_sound. Qed.

Theorem IC_Eme90_equivalence s : IC.prv s <-> Eme90.prv s.
Proof. split. exact: Eme90_translation. exact: Eme90_sound. Qed.

(** Soundness and Completeness for IC *)
Import IC.

Theorem soundness s : prv s -> forall (M:cmodel) (w:M), eval s w.
Proof. exact: soundness. Qed.

Theorem informative_completeness s :
     ( prv (~~: s) )
  +  (exists2 M : fmodel, #|M| <= f_size s * 2^(4 * f_size s + 2) & exists (w:M), eval s w).
Proof. exact: informative_completeness. Qed.

Corollary fin_completeness s : (forall (M:fmodel) (w:M), eval s w) -> prv s.
Proof. exact: fin_completeness. Qed.

(** Decidability and Small-Model-Property *)

Corollary prv_dec s : decidable (prv s).
Proof. exact: prv_dec. Qed.

Corollary sat_dec s : decidable (exists (M:cmodel) (w:M), eval s w).
Proof. exact: sat_dec. Qed.

Corollary valid_dec s : decidable (forall (M:cmodel) (w:M), eval s w).
Proof. exact: valid_dec. Qed.

Corollary small_models s :
  (exists (M:cmodel) (w:M), eval s w) ->
  (exists2 M : fmodel, #|M| <= f_size s * 2^(4 * f_size s + 2) & exists (w:M), eval s w).
Proof. exact: small_models. Qed.

(** Gentzen System *)

Theorem plain_soundness C : gen (C,aVoid) -> prv (~~: [af C]).
Proof. exact: plain_soundness. Qed.

Theorem gen_complete C :
  gen (C,aVoid) + (exists (M:fmodel) (w:M), forall s, s \in C -> eval (interp s) w).
Proof. exact: gen_complete. Qed.

Theorem gen_dec (A : clause * annot) : decidable (gen A).
Proof. exact: gen_dec. Qed.

(** Agreement of Path semantics with Inductive Semantics *)

Lemma evalP2 (M:fmodel) s (w : M) : (@satisfies M s w) <-> (@eval M s w).
Proof. exact: evalP2. Qed.

Lemma fin_path_soundness s : prv s -> forall (M : fmodel) (w:M), @satisfies M s w.
Proof. move => H M w. apply/evalP2. exact: soundness M w. Qed.

Lemma sts_agreement : XM -> DC -> forall (M:sts) (w :M) s, eval s w <-> satisfies s w.
Proof. exact: sts_agreement. Qed.

(** Soundness wrt. to Path semantics implies XM and DX *)

Lemma XM_required :
  (forall s, prv s -> forall (M : sts) (w : M), satisfies s w) -> XM.
Proof. exact: XM_required. Qed.

Lemma DC_required :
  (forall s, prv s -> forall (M : sts) (w : M), satisfies s w) -> DC.
Proof. exact: DC_required. Qed.

(** Agreement of coinductive AR and disjunctive AR implies LPO *)

Section LPO.
  Hypothesis hyp_AR : forall (M : fmodel) (w : M) (s t : form),
    cAR (@trans M) (eval s) (eval t) w -> pAR' (@trans M) (satisfies s) (satisfies t) w.

  Lemma LPO_of_disjunctive_AR (f : nat -> bool) :
    (forall n, f n = false) \/ exists n, f n = true.
  Proof. exact: LPO_of_disjunctive_AR. Qed.
End LPO.


(******************************************)
(******************************************)
(****                                  ****)
(****   A simple admissibility graph   ****)
(****                                  ****)
(******************************************)
(******************************************)

Require Import Coq.Relations.Operators_Properties.
Require Import Coq.Relations.Relation_Operators.
Require Import Main.AdmissibilityGraph.AdmissibilityGraph.
Require Import Main.AdmissibilityGraph.AdmissibilityGraphTheorems.
Require Import Main.Tactics.

Module Simple <: AdmissibilityGraph.
  #[local] Arguments clos_trans {A} _ _ _.
  #[local] Arguments clos_trans_1n {A} _ _ _.
  #[local] Arguments clos_trans_n1 {A} _ _ _.
  #[local] Hint Constructors clos_trans : main.
  #[local] Hint Constructors clos_trans_1n : main.
  #[local] Hint Constructors clos_trans_n1 : main.
  #[local] Hint Resolve clos_t1n_trans : main.
  #[local] Hint Resolve clos_trans_t1n : main.
  #[local] Hint Resolve clos_tn1_trans : main.
  #[local] Hint Resolve clos_trans_tn1 : main.

  Inductive nodeLabels := A | B | C | D.

  #[export] Hint Constructors nodeLabels : main.

  Definition node : Type := nodeLabels.

  #[export] Hint Unfold node : main.

  Definition dependency (n1 n2 : node) :=
    match n1, n2 with
    | A, A => True
    | A, B => True
    | A, C => True
    | A, D => False
    | B, A => True
    | B, B => True
    | B, C => True
    | B, D => False
    | C, A => True
    | C, B => True
    | C, C => True
    | C, D => True
    | D, A => True
    | D, B => True
    | D, C => True
    | D, D => True
    end.

  #[export] Hint Unfold dependency : main.

  Definition parent (n1 : node) (n2 : node) :=
    match n1, n2 with
    | A, A => True
    | B, A => True
    | C, A => True
    | D, A => False
    | A, B => False
    | B, B => True
    | C, B => False
    | D, B => False
    | A, C => False
    | B, C => False
    | C, C => True
    | D, C => True
    | A, D => False
    | B, D => False
    | C, D => False
    | D, D => True
    end.

  #[export] Hint Unfold parent : main.

  (* Coq requires that we copy this verbatim from `AdmissibilityGraph`. *)
  Definition ancestor := clos_trans parent.

  #[export] Hint Unfold ancestor : main.

  (* Coq requires that we copy this verbatim from `AdmissibilityGraph`. *)
  Definition admissible n1 n2 :=
    exists n3 n4, ancestor n1 n3 /\ parent n4 n3 /\ ancestor n4 n2.

  #[export] Hint Unfold admissible : main.

  Theorem reflexivity : forall n, parent n n.
  Proof.
    clean.
    destruct n; search.
  Qed.

  #[export] Hint Resolve reflexivity : main.

  Theorem antisymmetry :
    forall n1 n2, ancestor n1 n2 -> ancestor n2 n1 -> n1 = n2.
  Proof.
    #[local] Ltac eliminate H :=
      match type of H with
      | clos_trans_n1 parent ?n1 ?n2 =>
        remember n2; induction H; repeat match goal with
        | [n : node |- _] => destruct n; search
        end
      end.

    clean.
    apply clos_trans_tn1 in H, H0.
    destruct n1, n2; solve [
      reflexivity + eliminate H + eliminate H0; solve [eliminate H1]
    ].
  Qed.

  #[export] Hint Resolve antisymmetry : main.

  Theorem admissibility : forall n1 n2, dependency n1 n2 -> admissible n1 n2.
  Proof.
    clean.
    unfold admissible.
    destruct n1, n2; search; try (
      exists A + exists B + exists C + exists D;
      exists A + exists B + exists C + exists D;
      split; search; solve [
        apply t_trans with (y := A) +
        apply t_trans with (y := B) +
        apply t_trans with (y := C) +
        apply t_trans with (y := D);
        solve [search]
      ]
    ).
  Qed.

  #[export] Hint Resolve admissibility : main.
End Simple.

Module SimpleTheorems := AdmissibilityGraphTheorems Simple.


(** A program to guess the number of the user using comparisons. *)
Require Import Coq.Lists.List.
Require Import Io.All.
Require Import Io.Evaluate.

Import C.Notations.

Module Command.
  Inductive t (A : Type) :=
  | Propose : A -> t A.
  Arguments Propose {A} _.

  Definition answer {A : Type} (c : t A) : Type :=
    match c with
    | Propose _ => comparison
    end.
End Command.

Definition E (A : Type) : Effect.t :=
  Effect.New (Command.t A) Command.answer.

Definition propose {A : Type} (x : A) : C.t (E A) comparison :=
  call (E A) (Command.Propose x).

Fixpoint guess {A} (mean : A -> A -> A) (steps : nat) (min max : A)
  : C.t (E A) (option A) :=
  match steps with
  | O => ret None
  | S steps =>
    let m := mean min max in
    let! answer := propose m in
    match answer with
    | Lt => guess mean steps min m
    | Gt => guess mean steps m max
    | Eq => ret (Some m)
    end
  end.

Module Run.
  Definition propose {A} (x : A) (c : comparison) : Run.t (propose x) c.
    apply (Run.Call (E := E A) (Command.Propose x) c).
  Defined.

  Fixpoint never {A} (mean : A -> A -> A) (min max : A) (l : list bool)
    : Run.t (guess mean (List.length l) min max) None.
    destruct l as [|b l]; simpl.
    - apply Run.Ret.
    - destruct b.
      + eapply Run.Let. apply (propose _ Lt).
        apply never.
      + eapply Run.Let. apply (propose _ Gt).
        apply never.
  Defined.

  Definition simple_ok {A} (mean : A -> A -> A) (min max : A)
    : Run.t (guess mean 1 min max) (Some (mean min max)).
    eapply Run.Let. apply (propose _ Eq).
    apply Run.Ret.
  Defined.

  Fixpoint ok {A} (mean : A -> A -> A) (min max : A) (l : list bool)
    : {x : A & Run.t (guess mean (S (List.length l)) min max) (Some x)}.
    destruct l; simpl.
    - exists (mean min max).
      eapply Run.Let. apply (propose _ Eq).
      apply Run.Ret.
    - destruct b.
      + destruct (ok _ mean min (mean min max) l) as [x r].
        exists x.
        eapply Run.Let. apply (propose _ Lt).
        apply r.
      + destruct (ok _ mean (mean min max) max l) as [x r].
        exists x.
        eapply Run.Let. apply (propose _ Gt).
        apply r.
  Defined.

  Fixpoint mean_n {A} (mean : A -> A -> A) (steps : nat) (min max : A) : A :=
    match steps with
    | O => mean min max
    | S steps => mean_n mean steps min (mean min max)
    end.

  Fixpoint lts {A} (mean : A -> A -> A) (min max : A) (steps : nat)
    : Run.t (guess mean (S steps) min max) (Some (mean_n mean steps min max)).
    destruct steps as [|steps]; simpl.
    - eapply Run.Let. apply (propose _ Eq).
      apply Run.Ret.
    - eapply Run.Let. apply (propose _ Lt).
      apply lts.
  Defined.
End Run.

Module Eval.
  Definition eval_command {A} (compare : A -> A -> comparison) (x : A)
    (c : Command.t A) : Effect.answer (E A) c :=
    match c with
    | Command.Propose x' => compare x x'
    end.

  Definition eval {A B} (compare : A -> A -> comparison) (x : A)
    (e : C.t (E A) B) : B :=
    Evaluate.pure (E := E A) (eval_command compare x) (fun _ x _ => x) e.
End Eval.

Module Nat.
  Require Import Coq.Arith.Compare_dec.
  Require Import Coq.Arith.Div2.

  Definition mean (n m : nat) : nat :=
    div2 (n + m).

  Definition ex1 : Run.t (guess mean 5 0 10) (Some 4).
    apply (Run.Let (Run.propose 5 Lt)).
    apply (Run.Let (Run.propose 2 Gt)).
    apply (Run.Let (Run.propose 3 Gt)).
    apply (Run.Let (Run.propose 4 Eq)).
    apply Run.Ret.
  Defined.

  Definition ex2 : Eval.eval nat_compare 4 (guess mean 5 0 10) = Some 4 :=
    eq_refl.
End Nat.


(** We give three different definitions of the type W A B:

      1) Using dependent elimination and computation rules.
      2) Using simple elimination and computation rules, together with
         uniqueness and coherence laws.
      3) Using h-initiality.
**)

Require Import HoTT.
Require Import w_alg.

Local Open Scope path_scope.
Local Open Scope fibration_scope.

Section AssumeFunext.
Context `{Funext}.

Definition hasWDepElimCompRules (A: Type) (B : A -> Type) (W : Type) (sup : forall (x : A), (B x -> W) -> W) : Type :=
  forall (E : W -> Type) (e : forall x f, (forall b, E (f b)) -> E (sup x f)),
  { drec : forall (x : W), E x &
  forall x f, drec (sup x f)  = e x f (fun b => drec (f b)) }.

Definition hasWSimpElimCompRules (A : Type) (B : A -> Type) (W : Type) (sup : forall (x : A), (B x -> W) -> W) : Type :=
  forall (C : Type) (c : forall x, (B x -> C) -> C),
  { srec : W -> C &
  forall x f, srec (sup x f)  = c x (fun b => srec (f b)) }.

Definition hasWDepUniqCohRules (A : Type) (B : A -> Type) (W : Type) (sup : forall (x : A), (B x -> W) -> W) : Type :=
  forall (E : W -> Type) (e : forall x f, (forall b, E (f b)) -> E (sup x f))
  (g : forall w, E w) (p : forall x f, g (sup x f) = e x f (fun b => g (f b)))
  (h : forall w, E w) (q : forall x f, h (sup x f) = e x f (fun b => h (f b))),
  { alpha : forall (w : W), g w = h w &
  forall x f,
  alpha (sup x f) = p x f @ ap (e x f) (path_forall _ _ (fun b => alpha (f b))) @ (q x f)^ }.

Definition hasWSimpUniqCohRules (A : Type) (B : A -> Type) (W : Type) (sup : forall (x : A), (B x -> W) -> W) : Type :=
  forall (C : Type) (c : forall x, (B x -> C) -> C)
  (g : W -> C) (p : forall x f, g (sup x f) = c x (fun b => g (f b)))
  (h : W -> C) (q : forall x f, h (sup x f) = c x (fun b => h (f b))),
  { alpha : forall (w : W), g w = h w &
  forall x f,
  alpha (sup x f) = p x f @ ap (c x) (path_arrow _ _ (fun b => alpha (f b))) @ (q x f)^ }.

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

(* Definition of W A B #1. *)
Definition WDep (A : Type) (B : A -> Type) : Type :=
  { W : Type &
  { sup : forall (x : A), (B x -> W) -> W &
  hasWDepElimCompRules A B W sup }}.

(* Definition of W A B #2. *)
Definition WSimp (A : Type) (B : A -> Type) : Type :=
  { W : Type &
  { sup : forall (x : A), (B x -> W) -> W &
  hasWSimpElimCompRules A B W sup *
  hasWSimpUniqCohRules A B W sup }}.

(* Definition of W A B #3. *)
Definition WHinit (A : Type) (B : A -> Type) : Type
  := { X : WAlg A B & wHinit A B X }.

End AssumeFunext.


Require Import Metalib.Metatheory.

Require Import LibTactics.

Require Import syntax_ott.

Require Import List. Import ListNotations.

Fixpoint sizeTyp (s : styp) : nat :=
  match s with
  | styp_nat => 0
  | styp_top => 0
  | styp_arrow t1 t2 => S (sizeTyp t1 + sizeTyp t2)
  | styp_and t1 t2 => S (sizeTyp t1 + sizeTyp t2)
  | styp_rcd _ t => S (sizeTyp t)
  end.

Definition size_elem (s : st) : nat :=
  match s with
  | st_ty A => sizeTyp A
  | st_la _ => 0
  end.

Definition sizefs (fs : ls) := fold_right (fun l acc => l + acc) 0 (map size_elem fs).

Definition applyfs (fs : ls) (A : styp) :=
  fold_right (fun el acc =>
                match el with
                | st_ty A => styp_arrow A acc
                | st_la l => styp_rcd l acc
                end) A fs.

(** Lemma 25 *)
Lemma arrowTop : forall fs,
    sub styp_top (applyfs fs styp_top) (calTop fs).
Proof.
  intros.
  induction fs; simpls~.
  destruct a.

  apply S_trans with (A2 := styp_arrow A styp_top); auto.
  apply S_trans with (A2 := styp_arrow styp_top styp_top); auto.
  eapply S_trans; eauto.

  apply S_trans with (A2 := styp_rcd l styp_top); auto.
Qed.

(** Lemma 26 *)
Lemma arrowAnd : forall fs A B,
    sub (styp_and (applyfs fs A) (applyfs fs B))
        (applyfs fs (styp_and A B)) (calAnd fs).
Proof.
  intros fs.
  induction fs; intros; simpls~.
  destruct* a.
Qed.

Lemma applyArrow_append : forall fs B1 B2,
    applyfs (fs ++ [st_ty B1]) B2 = applyfs fs (styp_arrow B1 B2).
Proof.
  intros.
  unfolds.
  rewrite fold_right_app.
  reflexivity.
Qed.

Lemma applyLabel_append : forall fs l A,
    applyfs (fs ++ [st_la l]) A = applyfs fs (styp_rcd l A).
Proof.
  intros.
  unfolds.
  rewrite fold_right_app.
  reflexivity.
Qed.

(** *Soundness *)

Theorem ASub2sub : forall fs A B c,
    ASub fs A B c -> sub A (applyfs fs B) c.
Proof.
  introv H.
  induction* H; simpls*.

  - Case "rcd".
    rewrite applyLabel_append in IHASub; auto.

  - Case "top".
    eapply S_trans; eauto.
    apply arrowTop.

  - Case "and2".

    lets R : S_and IHASub1 IHASub2.
    eapply S_trans; eauto.
    apply arrowAnd.

  - Case "arrNat".
    unfold applyfs in IHASub.
    rewrite fold_right_app in IHASub.
    simpls*.

Qed.

(** *Porting Pierce's proofs *)

(** [Rel A] denotes a set of reflexive supertypes of [A] *)
Inductive Rel : styp -> styp -> Prop :=
| R_top : Rel styp_top styp_top
| R_rcd : forall l A B,
    Rel A B ->
    Rel (styp_rcd l A) (styp_rcd l B)
| R_and : forall A B C,
    Rel A C \/ Rel B C \/ C = styp_and A B ->
    Rel (styp_and A B) C
| R_arrow : forall A B B',
    Rel B B' ->
    Rel (styp_arrow A B) (styp_arrow A B')
| R_nat : Rel styp_nat styp_nat.

Hint Constructors Rel.

Notation "A ∈R B" := (Rel B A)  (at level 1).

Notation "A ⊆R B" := (forall C, Rel A C -> Rel B C )  (at level 1).

(** [Rel] is reflexive (Lemma 14) *)
Lemma setRefl : forall A, A ∈R A.
Proof.
  intros.
  induction* A.
Qed.

Lemma setAnd : forall A B C,
    (styp_and A B) ∈R C -> A ∈R C /\ B ∈R C.
Proof.
  intros A B C.
  gen A B.
  induction C; introv H.
  inverts H.
  inverts H.
  inverts H.
  branches.
  forwards * : IHC1.
  forwards * : IHC2.
  inverts H.
  splits.
  constructor.
  branch 1.
  apply setRefl.
  constructor.
  branch 2.
  apply setRefl.
  inverts H.
  inverts H.
Qed.

(** [Rel] is transitive *)
Lemma setTrans : forall A B C,
    A ∈R B ->
    B ∈R C ->
    A ∈R C.
Proof.
  intros A B C.
  gen A C.
  induction B; introv AsubB BsubC; try inverts* AsubB.

  - Case "styp_and".
    lets (? & ?): setAnd BsubC.
    branches.
    forwards * : IHB1.
    forwards * : IHB2.
    substs*.

  - Case "styp_arrow".
    gen B1 B2 B'.
    induction C; intros.

    + inverts BsubC.
    + inverts BsubC.
    + inverts BsubC.
      branches.
      SCase "B1 -> B2 ∈R C1".
        constructor.
        branch 1.
        sapply IHC1; eauto.
      SCase "B1 -> B2 ∈R C2".
        constructor.
        branch 2.
        sapply IHC2; eauto.
      SCase "Impossible case".
        inverts H.
    + inverts BsubC.
      constructor*.
    + inverts BsubC.

  - Case "styp_rcd".
    gen B B0.
    induction C; intros; try solve [inverts* BsubC].
    + inverts BsubC.
      branches.
      auto_star.
      auto_star.
      inverts H.
Qed.

(** Lemma 15

Pierce's proof of this lemma is very vague, which is not that obvious. We need
[setTrans] to make progress.

 *)
Lemma setSubset : forall A B,
    A ∈R B ->
    A ⊆R B.
Proof.
  introv H.
  induction* H.

  - Case "R_rcd".
    intros D HH.
    inverts* HH.

  - Case "R_and".
    branches.
    intros D HH.
    constructor.
    branch 1.
    sapply setTrans; eauto.
    constructor.
    branch 2.
    sapply setTrans; eauto.
    substs~.

  - Case "R_arrow".
    intros C HH.
    inverts HH.
    constructor.
    sapply setTrans; eauto.

Qed.

(** Lemma 16 *)
Lemma setList : forall fs A B,
    (applyfs fs A) ∈R (applyfs fs (styp_and A B)) /\
    (applyfs fs B) ∈R (applyfs fs (styp_and A B)).
Proof.
  intros fs.
  induction fs; intros; simpls.

  splits.
  constructor; branch 1; apply setRefl.
  constructor; branch 2; apply setRefl.

  destruct a;
  specializes IHfs A B.
Qed.

Require Import Omega.

Lemma sizefs_cons1 : forall s fs,
    sizefs (s :: fs) = size_elem s + sizefs fs.
Proof.
  intros.
  simpls~.
Qed.

Lemma sizefs_cons2 : forall s fs,
    sizefs (fs ++ [s]) = sizefs fs + size_elem s.
Proof.
  intros.
  induction fs.
  unfolds.
  simpls~.

  simpls.
  rewrite sizefs_cons1.
  rewrite IHfs.
  rewrite sizefs_cons1.
  omega.
Qed.

Lemma sizefs_nil : sizefs [] = 0.
Proof.
  unfolds.
  simpls~.
Qed.

Hint Rewrite sizefs_cons1 sizefs_cons2 sizefs_nil : base.

Tactic Notation "my_autorewrite" "in" "*" :=
  autorewrite_in_star_patch
    ltac:(fun tt => autorewrite with base).

Lemma set2Sub_aux : forall k fs A B,
    sizeTyp A + sizeTyp B + sizefs fs <= k ->
    (applyfs fs B) ∈R A ->
    exists c, ASub fs A B c.
Proof with my_autorewrite in * ; simpls; try omega.
  intros k.
  induction k; intros.

  - Case "k = 0".
    inverts H as HSize.
    destruct B...
    + SCase "B = styp_top".
      exists~ (co_trans (calTop fs) co_top).
    + SCase "B = styp_nat".
      destruct A...
      * SSCase "A = styp_top".
        destruct fs.
        inverts H0.
        destruct s;
        inverts H0.
      * SSCase "A = styp_nat".
        destruct fs.
        exists~ co_id.
        destruct s;
        inverts H0.

  - Case "k = S n".
    destruct B; simpls.
    + SCase "B = styp_top".
      exists~ (co_trans (calTop fs) co_top).
    + SCase "B = styp_nat".
      destruct A; simpls.
      * SSCase "A = styp_top".
        destruct fs.
        simpls; inverts H0.
        destruct s; inverts H0.
      * SSCase "A = styp_nat".
        destruct fs.
        exists~ co_id.
        destruct s; inverts H0.
      * SSCase "A = styp_and".
        inverts H0 as HH.
        destruct HH as [HH1 | [HH2 | HH3]].
        apply IHk in HH1...
        destruct HH1 as (c & ?).
        exists~ (co_trans c co_proj1).
        apply IHk in HH2...
        destruct HH2 as (c & ?).
        exists~ (co_trans c co_proj2).
        destruct fs. inverts HH3.
        destruct s; inverts HH3.
      * SSCase "A = styp_arrow".
        destruct fs; try solve [inverts H0].
        destruct s; simpls; try solve [inverts H0].
        inverts H0 as H0.
        lets HH : setRefl A.
        change A with (applyfs [] A) in HH.
        apply IHk in HH...
        destruct HH as (c1 & ?).
        apply IHk in H0...
        destruct H0 as (c2 & ?).
        exists~ (co_arr c1 c2).

      * SSCase "A = styp_rcd".
        destruct fs; try solve [ inverts H0 ].
        destruct s; inverts H0.
        apply IHk in H2...
        destruct H2 as (c & ?).
        exists~ (co_rcd l0 c).

    + SCase "B = styp_and".
      lets (HH1 & HH2): setList fs B1 B2.
      lets H1 : setTrans HH1 H0.
      lets H2 : setTrans HH2 H0.
      apply IHk in H1...
      destruct H1 as (c1 & ?).
      apply IHk in H2...
      destruct H2 as (c2 & ?).
      exists~ (co_trans (calAnd fs) (co_pair c1 c2)).

    + SCase "B = styp_arrow".
      rewrite <- applyArrow_append in H0.
      apply IHk in H0...
      destruct H0 as (c & ?).
      exists~ c.

    + SCase "B = styp_rcd".
      rewrite <- applyLabel_append in H0.
      apply IHk in H0...
      destruct H0 as (c & ?).
      exists~ c.

Qed.

(** Proposition 17 *)
Lemma set2Sub : forall fs A B,
    (applyfs fs B) ∈R A ->
    exists c, ASub fs A B c.
Proof.
  intros.
  apply set2Sub_aux with (sizeTyp A + sizeTyp B + sizefs fs); auto.
Qed.

Inductive Phi : ls -> ls -> Prop :=
| phi_empty : Phi [] []
| phi_cons1 : forall A B c fs1 fs2,
    ASub [] A B c ->
    Phi fs1 fs2 ->
    Phi (st_ty A :: fs1) (st_ty B :: fs2)
| phi_cons2 : forall l fs1 fs2,
    Phi fs1 fs2 ->
    Phi (st_la l :: fs1) (st_la l :: fs2).

Hint Constructors Phi.

Lemma phi_append1 : forall fs1 fs2 A B c,
    Phi fs1 fs2 ->
    ASub [] A B c ->
    Phi (fs1 ++ [st_ty A]) (fs2 ++ [st_ty B]).
Proof.
  introv phi.
  gen A B c.
  induction phi; intros; simpls*.
Qed.

Lemma phi_append2 : forall fs1 fs2 l,
    Phi fs1 fs2 ->
    Phi (fs1 ++ [st_la l]) (fs2 ++ [st_la l]).
Proof.
  introv phi.
  induction phi; intros; simpls*.
Qed.

(** Pierce's proof is wrong: should do complete induction also on [sizefs fs3],
otherwise the induction hypothesis is not applicable *)

Lemma ASub_trans_wrt_Phi_aux : forall k A B C fs1 fs2 fs3 c1 c2,
    sizeTyp A + sizefs fs1 + sizeTyp B + sizefs fs2 + sizeTyp C + sizefs fs3 <= k ->
    ASub fs1 A B c1 ->
    Phi fs3 fs1 ->
    ASub fs2 B C c2 ->
    exists c, ASub (fs3 ++ fs2) A C c.
Proof with my_autorewrite in *; simpls; try omega.
  intros k.
  induction k; introv Sum AsubB phi BsubC.

  - Case "k = 0".
    inverts Sum.
    destruct C...
    + SCase "C = styp_top".
      exists~ (co_trans (calTop (fs3 ++ fs2)) co_top).
    + SCase "C = styp_nat".
      destruct B...
      * SSCase "B = styp_top".
        inverts BsubC.
      * SSCase "B = styp_nat".
        inverts BsubC.
        destruct A...
        ** SSSCase "A = styp_top".
           inverts AsubB.
        ** SSSCase "A = styp_nat".
           inverts AsubB.
           inverts phi.
           exists~ co_id.

  - Case "k = S n".
    destruct C...
    + SCase "C = styp_top".
      exists~ (co_trans (calTop (fs3 ++ fs2)) co_top).
    + SCase "C = styp_nat".
      destruct B...
      * SSCase "B = styp_top".
        inverts BsubC.
      * SSCase "B = styp_nat".
        inverts BsubC.
        destruct A...
        ** SSSCase "A = styp_top".
           inverts AsubB.
        ** SSSCase "A = styp_nat".
           inverts AsubB.
           inverts phi.
           exists~ co_id.
        ** SSSCase "A = styp_and".
           inverts AsubB as HH.
           assert (HH1 : ASub nil styp_nat styp_nat co_id) by auto.
           forwards (cc & H) : >> IHk HH phi HH1...
           exists~ (co_trans cc co_proj1).

           assert (HH1 : ASub nil styp_nat styp_nat co_id) by auto.
           forwards (cc & H) : >> IHk HH phi HH1...
           exists~ (co_trans cc co_proj2).
        ** SSSCase "A = styp_arrow".
           inverts AsubB as HH1 HH2.
           inverts phi as HH phi.
           assert (HH' : ASub nil styp_nat styp_nat co_id) by auto.

           forwards (cc1 & ?) : >> IHk HH2 phi HH'...
           forwards (cc2 & ?) : >> IHk HH phi_empty HH1...
           exists~ (co_arr cc2 cc1).
        ** SSSCase "A = styp_rcd".
           inverts AsubB as HH.
           inverts phi as phi.
           assert (HH' : ASub nil styp_nat styp_nat co_id) by auto.
           forwards (cc & ?) : >> IHk HH phi HH'...
           exists~ (co_rcd l cc).

      * SSCase "B = styp_and".
        inverts AsubB as HH1 HH2.
        inverts BsubC as HH.
        forwards (cc & ?) : IHk HH1 phi HH...
        exists~ cc.
        forwards (cc & ?) : IHk HH2 phi HH...
        exists~ cc.

      * SSCase "B = styp_arrow".
        destruct fs2.
        inverts BsubC.
        inverts BsubC as HH1 HH2.
        inverts AsubB.
        assert (phi2 : Phi (fs3 ++ [st_ty A0]) (fs1 ++ [st_ty B1])) by (sapply phi_append1; eauto).
        forwards (cc & ?) : IHk H4 phi2 HH2...
        rewrite <- app_assoc in H.
        exists~ cc.

      * SSCase "B = styp_rcd".
        destruct fs2.
        inverts BsubC.
        inverts BsubC as HH1.
        inverts AsubB as HH2.
        assert (phi2 : Phi (fs3 ++ [st_la l]) (fs1 ++ [st_la l])) by (sapply phi_append2; eauto).
        forwards (cc & ?) : IHk HH2 phi2 HH1...
        rewrite <- app_assoc in H.
        exists~ cc.

    + SCase "C = styp_and".
      inverts BsubC as HH1 HH2.
      forwards (cc1 & ?) : IHk AsubB phi HH1...
      forwards (cc2 & ?) : IHk AsubB phi HH2...
      exists~ (co_trans (calAnd (fs3 ++ fs2)) (co_pair cc1 cc2)).
    + SCase "C = styp_arrow".
      inverts BsubC.
      forwards (cc & ?) : IHk AsubB phi H4...
      rewrite app_assoc in H.
      exists~ cc.

    + SCase "C = styp_rcd".
      inverts BsubC.
      forwards (cc & ?) : IHk AsubB phi H4...
      rewrite app_assoc in H.
      exists~ cc.
Qed.

Lemma ASub_trans_wrt_Phi : forall A B C fs1 fs2 fs3 c1 c2,
    ASub fs1 A B c1 ->
    Phi fs3 fs1 ->
    ASub fs2 B C c2 ->
    exists c, ASub (fs3 ++ fs2) A C c.
Proof.
  intros.
  eapply ASub_trans_wrt_Phi_aux
    with (k := sizeTyp A + sizefs fs1 + sizeTyp B + sizefs fs2 + sizeTyp C + sizefs fs3); eauto.
Qed.

(** [ASub] is transitive *)
Lemma ASub_trans : forall A B C c1 c2,
    ASub nil A B c1 -> ASub nil B C c2 -> exists c, ASub nil A C c.
Proof.
  introv H1 H2.
  forwards * : ASub_trans_wrt_Phi H1 phi_empty H2.
Qed.

(** [ASub] is reflexive *)
Lemma ASub_refl : forall A,
    exists c, ASub nil A A c.
Proof.
  intros.
  apply set2Sub.
  apply setRefl.
Qed.

Lemma arrSub : forall fs A1 A2 B1 B2 c1 c2,
    ASub fs B1 B2 c2 ->
    ASub nil A2 A1 c1 ->
    exists c, ASub ([st_ty A2] ++ fs) (styp_arrow A1 B1) B2 c.
Proof.
  introv H.
  gen A1 A2 c1.
  induction H; intros.

  - Case "A-nat".
    exists (co_arr c1 co_id).
    constructor~.

  - Case "A-rcdNat".
    forwards HH : IHASub H0.
    destruct HH as (cc & HH).
    inverts HH.
    exists~ (co_arr c1 (co_rcd l c2)).
    constructor~.

  - Case "A-rcd".
    forwards HH : IHASub H0.
    destruct HH as (cc & HH).
    exists~ cc.

  - Case "A-top".
    exists~ (co_trans (calTop ([st_ty A2] ++ fs)) co_top).

  - Case "A-and".
    forwards * (cc1 & HH1): IHASub1 H1.
    forwards * (cc2 & HH2): IHASub2 H1.

  - Case "A-arr".
    forwards * (cc & HH): IHASub H0.

  - Case "A-andNat1".

    forwards * (cc & HH): IHASub A0 A3 c1.
    inverts HH.
    exists (co_arr c0 (co_trans c2 co_proj1)).
    constructor~.

  - Case "A-andNat2".

    forwards * (cc & HH): IHASub A0 A3 c1.
    inverts HH.
    exists (co_arr c0 (co_trans c2 co_proj2)).
    constructor~.

  - Case "A-arrNat".

    forwards * (cc & HH): IHASub2 A1 A c1.
    exists (co_arr c0 cc).
    constructor~.

Qed.

Lemma rcdSub : forall fs A B c1 l,
    ASub fs A B c1 ->
    exists c2, ASub ([st_la l] ++ fs) (styp_rcd l A) B c2.
Proof.
  introv H.
  induction* H; simpls; try solve [destruct IHASub as (c' & IHASub); auto_star].

  - Case "A-nat".
    exists~ (co_rcd l co_id).

  - Case "A-and".
    destruct IHASub1 as (cc1 & IHASub1).
    destruct IHASub2 as (cc2 & IHASub2); auto_star.

  - Case "A-nat".
    destruct IHASub1 as (cc1 & IHASub1).
    destruct IHASub2 as (cc2 & IHASub2); auto_star.
Qed.

(** *Completeness *)

Theorem sub2ASub : forall A B c,
    sub A B c -> exists c', ASub nil A B c'.
Proof.
  introv H.
  induction* H.

  - Case "refl".
    apply ASub_refl.

  - Case "trans".
    destruct IHsub1 as (c1' & IHsub1).
    destruct IHsub2 as (c2' & IHsub2).
    eapply ASub_trans; eauto.

  - Case "arrow".
    destruct IHsub1 as (c1' & IHsub1).
    destruct IHsub2 as (c2' & IHsub2).

    (** Note: Pierce's proof is wrong in this case, we need [arrSub] *)
    lets* (cc & HH): arrSub IHsub2 IHsub1.

  - Case "and".
    destruct IHsub1 as (c1' & IHsub1).
    destruct IHsub2 as (c2' & IHsub2).
    exists* (co_trans (calAnd nil)(co_pair c1' c2')).

  - Case "and1".
    apply~ set2Sub.
    constructor; branch 1; apply setRefl.

  - Case "and2".
    apply~ set2Sub.
    constructor; branch 2; apply setRefl.

  - Case "arrAnd".
    set (T := styp_and (styp_arrow A1 A2) (styp_arrow A1 A3)).
    assert ((styp_arrow A1 A2) ∈R (styp_arrow A1 A2)) by apply setRefl.
    assert ((styp_arrow A1 A3) ∈R (styp_arrow A1 A3)) by apply setRefl.
    assert ((styp_arrow A1 A2) ∈R T). constructor; branch~ 1.
    assert ((styp_arrow A1 A3) ∈R T). constructor; branch~ 2.
    change (styp_arrow A1 A2) with (applyfs ([st_ty A1]) A2) in H1.
    change (styp_arrow A1 A3) with (applyfs ([st_ty A1]) A3) in H2.
    apply set2Sub in H1.
    apply set2Sub in H2.
    destruct H1 as [c1 H1].
    destruct H2 as [c2 H2].
    lets : A_and H1 H2.
    exists~ (co_trans (calAnd [st_ty A1]) (co_pair c1 c2)).

  - Case "recd1".
    destruct IHsub as (cc & ?).

    lets * (cc' & ?): rcdSub l H0.

  - Case "recd2".
    set (T := styp_and (styp_rcd l A) (styp_rcd l B)).
    assert ((styp_rcd l A) ∈R (styp_rcd l A)) by apply setRefl.
    assert ((styp_rcd l B) ∈R (styp_rcd l B)) by apply setRefl.
    assert ((styp_rcd l A) ∈R T). constructor; branch~ 1.
    assert ((styp_rcd l B) ∈R T). constructor; branch~ 2.
    change (styp_rcd l A) with (applyfs ([st_la l]) A) in H1.
    change (styp_rcd l B) with (applyfs ([st_la l]) B) in H2.
    apply set2Sub in H1.
    apply set2Sub in H2.
    destruct H1 as [c1 H1].
    destruct H2 as [c2 H2].
    lets : A_and H1 H2.
    exists~ (co_trans (calAnd [st_la l]) (co_pair c1 c2)).

Qed.


(*|
###############################################################################
Why does use of Coq's ``setoid_replace ... by`` clause need an extra ``idtac``?
###############################################################################

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

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

I encountered a strange situation using ``setoid_replace`` where a
proof step of the form:

.. coq:: none
|*)

Require Import QArith.
Open Scope Q.

Lemma rearrange_eq_r a b c d :
  a == b -> b + d == a + c -> c == d.
Proof.
  intro a_eq_b. rewrite a_eq_b. symmetry. now apply Qplus_inj_l with (z := b).
Qed.

Ltac rearrange :=
  match goal with
  | [ H : _ == _ |- _ == _ ] => apply rearrange_eq_r with (1 := H); ring
  end.

Lemma test_rearrange a b c d e (H0 : e < b) (H1 : b + c == a + d) :
  e < a - c + d.
Proof.

(*||*)

  Fail setoid_replace (a - c + d) with b by rearrange. (* .unfold .in .messages *)

(*| but after appending an extra ``idtac`` to the tactic: |*)

  setoid_replace (a - c + d) with b by (rearrange; idtac).

(*|
the proof succeeds. My understanding of ``idtac`` was that it was
essentially a no-op. Why does the presence of ``idtac`` make a
difference here?

Here's the full code. I'm using Coq 8.4pl6 through Proof General.
|*)

Reset Initial. (* .none *)
Require Import QArith.
Open Scope Q.

Lemma rearrange_eq_r a b c d :
  a == b -> b + d == a + c -> c == d.
Proof.
  intro a_eq_b. rewrite a_eq_b. symmetry. now apply Qplus_inj_l with (z := b).
Qed.

Ltac rearrange :=
  match goal with
  | [ H : _ == _ |- _ == _ ] => apply rearrange_eq_r with (1 := H); ring
  end.

Lemma test_rearrange a b c d e (H0 : e < b) (H1 : b + c == a + d) :
  e < a - c + d.
Proof.
  (* Why is the extra 'idtac' required in the line below? *)
  setoid_replace (a - c + d) with b by (rearrange; idtac).
  assumption.
Qed.

(*|
Note: as Matt observes, ``idtac`` doesn't seem to be special here: it
seems that any tactic (including ``fail``!) can be used in place of
``idtac`` to make the proof succeed.

----

**A (Matt):** Strangely enough sequencing ``rearrange`` with anything
seems to work. For example, I get the same result when I do
``setoid_replace (a - c + d) with b by (rearrange; fail).`` or
``setoid_replace (a - c + d) with b by (rearrange; exfalso).`` or
``setoid_replace (a - c + d) with b by (rearrange; auto).`` Very
odd...
|*)

(*|
Answer
******

Thanks to Jason Gross on the Coq bug tracker for explaining this. This
has to do with order of evaluation in the Ltac tactic language. In the
failing case, the match in ``rearrange`` is being applied to the
inequality in the immediate goal rather than to the equality generated
by ``setoid_replace``. Here's Jason's response on the bug report:

    This is because the ``match`` is evaluated before the
    ``setoid_replace`` is run. It is one of the unfortunate trip-ups
    of Ltac that things like ``match`` and ``let ... in ...`` are
    evaluated eagerly until a statement with semicolons, or other
    non-match non-let-in statement is reached. If you add ``idtac;``
    before the ``match`` in ``rearrange``, your problem will go away.
|*)


Require Import Helix.Util.OptionSetoid.

Require Import Helix.MSigmaHCOL.Memory.
Require Import Helix.MSigmaHCOL.CType.

Require Import Coq.Classes.RelationClasses.
Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.misc.decision.
Require Import MathClasses.misc.util.

Require Import Helix.Tactics.HelixTactics.

Module Type MMemSetoid (CT : CType).

  Include Memory.MBasic CT.

  (* Custom equality of memory blocks using (@equiv t) on members *)
  Instance mem_block_Equiv: Equiv (mem_block) :=
    fun m m' => forall k : NM.key, NM.find k m = NM.find k m'.

  Instance mem_block_Equiv_Reflexive:
    Reflexive (mem_block_Equiv).
  Proof.
    unfold mem_block_Equiv.
    unfold Reflexive.
    reflexivity.
  Qed.

  Instance mem_block_Equiv_Symmetric:
    Symmetric (mem_block_Equiv).
  Proof.
    unfold mem_block_Equiv.
    unfold Symmetric.
    intros x y H k.
    specialize (H k).
    auto.
  Qed.

  Instance mem_block_Equiv_Transitive:
    Transitive (mem_block_Equiv).
  Proof.
    unfold mem_block_Equiv.
    unfold Transitive.
    intros x y z H0 H1 k.
    specialize (H0 k).
    specialize (H1 k).
    auto.
  Qed.

  Instance mem_block_Equiv_Equivalence:
    Equivalence (mem_block_Equiv).
  Proof.
    split; typeclasses eauto.
  Qed.

  Ltac mem_index_equiv k :=
    unfold equiv, mem_block_Equiv;
    intros k.

  Instance mem_lookup_proper:
    Proper ((eq) ==> (=) ==> (=)) (mem_lookup).
  Proof.
    simpl_relation.
    apply H0.
  Qed.

  Lemma MapsTo_In (k:nat) {A:Type} (e:A) (m:NatMap A):
    NM.MapsTo k e m -> NM.In k m.
  Proof.
    intros H.
    apply NP.F.in_find_iff.
    apply NM.find_1 in H.
    congruence.
  Qed.

  Lemma In_MapsTo (k:nat) {A:Type} (m:NatMap A):
    NM.In k m -> exists e, NM.MapsTo k e m.
  Proof.
    intros H.
    apply NP.F.in_find_iff in H.
    destruct (NM.find k m) as [e |] eqn:D.
    -
      eexists e.
      apply NM.find_2.
      apply D.
    -
      congruence.
  Qed.

  Lemma not_maps_to_find {A:Type}  {k v m}:
    ¬ (NM.MapsTo k v m) -> NM.find (elt:=A) k m <> Some v.
  Proof.
    intros H.
    destruct (is_Some_dec (NM.find (elt:=A) k m)) as [S | N].
    -
      intros F.
      apply NM.find_2 in F.
      congruence.
    -
      unfold is_Some, not in N.
      break_match_hyp ; try some_none.
      tauto.
  Qed.

  Instance mem_in_proper:
    Proper ((eq) ==> (=) ==> iff) (mem_in).
  Proof.
    simpl_relation.
    unfold mem_in.
    split.
    -
      intros H.
      apply NP.F.in_find_iff in H.
      apply NP.F.in_find_iff.
      apply None_nequiv_neq in H.
      apply None_nequiv_neq.
      rewrite <- H0.
      auto.
    -
      intros H.
      apply NP.F.in_find_iff in H.
      apply NP.F.in_find_iff.
      apply None_nequiv_neq.
      rewrite H0.
      apply None_nequiv_neq in H.
      auto.
  Qed.

  Instance mem_add_proper:
    Proper ((eq) ==> (equiv) ==> (equiv) ==> (equiv)) (mem_add).
  Proof.
    simpl_relation.
    rename y into k'.
    unfold mem_add.
    unfold equiv, mem_block_Equiv in H1.
    specialize (H1 k).
    destruct_opt_r_equiv.
    -
      apply Some_inj_equiv.
      rewrite <- Ha, <- Hb; clear Ha Hb.
      destruct (PeanoNat.Nat.eq_dec k k').
      +
        rewrite 2!NP.F.add_eq_o by auto.
        f_equiv.
        apply H0.
      +
        rewrite 2!NP.F.add_neq_o by auto.
        apply H1.
    -
      destruct (PeanoNat.Nat.eq_dec k k').
      +
        rewrite NP.F.add_eq_o in Hb by auto.
        some_none.
      +
        rewrite NP.F.add_neq_o in Ha by auto.
        rewrite NP.F.add_neq_o in Hb by auto.
        rewrite Ha in H1.
        rewrite Hb in H1.
        some_none.
    -
      destruct (PeanoNat.Nat.eq_dec k k').
      +
        rewrite NP.F.add_eq_o in Ha by auto.
        some_none.
      +
        rewrite NP.F.add_neq_o in Ha by auto.
        rewrite NP.F.add_neq_o in Hb by auto.
        rewrite Ha in H1.
        rewrite Hb in H1.
        some_none.
  Qed.

  (* Equality of memory states *)
  Instance memory_Equiv: Equiv (memory) :=
    fun m m' => forall k : NM.key, NM.find k m = NM.find k m'.

  Instance memorey_Equiv_Reflexive:
    Reflexive (memory_Equiv).
  Proof.
    unfold memory_Equiv.
    unfold Reflexive.
    reflexivity.
  Qed.

  Instance memory_Equiv_Symmetric:
    Symmetric (memory_Equiv).
  Proof.
    unfold memory_Equiv.
    unfold Symmetric.
    intros x y H k.
    specialize (H k).
    auto.
  Qed.

  Instance memory_Equiv_Transitive:
    Transitive (memory_Equiv).
  Proof.
    unfold memory_Equiv.
    unfold Transitive.
    intros x y z H0 H1 k.
    specialize (H0 k).
    specialize (H1 k).
    auto.
  Qed.

  Instance memory_Equiv_Equivalence:
    Equivalence (memory_Equiv).
  Proof.
    split; typeclasses eauto.
  Qed.

  Instance memory_lookup_proper:
    Proper ((=) ==> (eq) ==> (=)) (memory_lookup).
  Proof.
    simpl_relation.
    apply H.
  Qed.

  Instance mem_block_exists_proper:
    Proper ((eq) ==> (=) ==> iff) (mem_block_exists).
  Proof.
    simpl_relation.
    unfold mem_block_exists, memory, mem_block in *.
    split.
    -
      intros H.
      apply NP.F.in_find_iff in H.
      apply NP.F.in_find_iff.
      apply None_nequiv_neq.
      apply None_nequiv_neq in H.
      unfold equiv, memory_Equiv in H0.
      rewrite <- H0.
      apply H.
    -
      intros H.
      apply NP.F.in_find_iff in H.
      apply NP.F.in_find_iff.
      apply None_nequiv_neq.
      unfold equiv, memory_Equiv in H0.
      rewrite H0.
      apply None_nequiv_neq in H.
      auto.
  Qed.

  Lemma mem_block_exists_exists_equiv (m:memory) (k:nat):
    mem_block_exists k m <-> exists y : mem_block, memory_lookup m k = Some y.
  Proof.
    split; intros H.
    -
      apply NP.F.in_find_iff, is_Some_ne_None, is_Some_equiv_def in H.
      eauto.
    -
      apply NP.F.in_find_iff, is_Some_ne_None, is_Some_equiv_def.
      eauto.
  Qed.

  Lemma mem_union_mem_empty : forall x, mem_union mem_empty x = x.
  Proof.
    intros x.
    unfold equiv, mem_block_Equiv.
    intros k.
    unfold mem_empty, mem_union.
    rewrite NP.F.map2_1bis; [|reflexivity].
    rewrite NP.F.empty_o.
    reflexivity.
  Qed.

  Lemma mem_union_mem_add_commut :
    forall i value x,
      mem_union (mem_add i value (mem_const_block i value)) x =
      mem_add i value (mem_union (mem_const_block i value) x).
  Proof.
    intros i value x.
    unfold equiv, mem_block_Equiv.
    intros k.
    unfold mem_add, mem_union.
    destruct (PeanoNat.Nat.eq_dec i k).
    -
      subst.
      rewrite NP.F.add_eq_o; [|reflexivity].
      rewrite NP.F.map2_1bis; [|reflexivity].
      rewrite NP.F.add_eq_o; [|reflexivity].
      reflexivity.
    -
      rewrite NP.F.add_neq_o; [|assumption].
      repeat (rewrite NP.F.map2_1bis; [|reflexivity]).
      rewrite NP.F.add_neq_o; [|assumption].
      reflexivity.
  Qed.

End MMemSetoid.