Add LoadPath "../utils".
Require Import refocusing_environments.

Module CallByValue <: RED_LANG.

  Inductive term' : Set :=
  | var : nat -> term'
  | lam : term' -> term'
  | app : term' -> term' -> term'.
  Definition term := term'.

  Inductive closure' : Set :=
  | pair' : term -> list closure' -> closure'
  | comp  : closure' ->  closure' -> closure'.
  Definition closure := closure'.
  Definition env := list closure.
  Definition pair := pair'.

  Inductive value' : Set :=
  | v_lam : term -> env -> value'.
  Definition value := value'.

  Inductive redex' : Set :=
  | r_beta : value -> value -> redex'
  | r_get  : nat -> env -> redex'
  | r_app  : term -> term -> env -> redex'.
  Definition redex := redex'.

  Inductive frame' : Set :=
  | ap_r : closure -> frame'
  | ap_l : value -> frame'.
  Definition frame := frame'.
  Definition context := list frame.
  Definition empty : context := nil.

  Inductive closureC' : Set :=
  | pairC' : term -> list closureC' -> closureC'.
  Definition closureC := closureC'.
  Definition pairC := pairC'.
  Definition envC := list closureC.

  Inductive valueC' : Set :=
  | v_lamC : term -> envC -> valueC'.
  Definition valueC := valueC'.

  Inductive frameC' : Set :=
  | ap_rC : closureC -> frameC'
  | ap_lC : valueC -> frameC'.
  Definition frameC := frameC'.
  Definition contextC := list frameC'.
  Definition emptyC : contextC := nil.

  Definition value_to_closure (v : value) : closure :=
  match v with v_lam t s => pair (lam t) s end.
  Coercion value_to_closure : value >-> closure.
  Definition redex_to_closure (r : redex) : closure :=
  match r with
  | r_beta v v' => comp (v:closure) (v':closure)
  | r_get n s   => pair (var n) s
  | r_app t1 t2 s => pair (app t1 t2) s
  end.
  Coercion redex_to_closure : redex >-> closure.

  Definition atom_plug (c : closure) (f : frame) :=
    match f with
    | ap_r c0 => comp c c0
    | ap_l v => comp (v : closure) c
    end.

  Definition plug (c : closure) (E : context) : closure := fold_left atom_plug E c.
  Definition compose (E E0 : context) : context := E ++ E0.
  Definition composeC (E E0 : contextC) : contextC := E ++ E0.

  Definition valueC_to_closureC (v : valueC) : closureC :=
  match v with v_lamC t s => pairC (lam t) s end.
  Coercion valueC_to_closureC : valueC >-> closureC.

  Fixpoint closureC_to_closure (cl : closureC) : closure :=
  match cl with pairC t s => pair t (map closureC_to_closure s) end.
  Coercion closureC_to_closure : closureC >-> closure.
  Definition envC_to_env : envC -> env := map closureC_to_closure.

  Definition valueC_to_value (v : valueC) : value :=
  match v with v_lamC t s => v_lam t (envC_to_env s) end.

  Definition frameC_to_frame (fC : frameC) : frame :=
  match fC with
  | ap_rC cC => ap_r cC
  | ap_lC vC => ap_l (valueC_to_value vC)
  end.
  Coercion frameC_to_frame : frameC >-> frame.
  Definition contextC_to_context : contextC -> context := map frameC_to_frame.
  Coercion contextC_to_context : contextC >-> context.

  Lemma closureC_ind : forall P : closureC' -> Prop,
  (forall (t : term) (l : list closureC'), (forall t0, In t0 l -> P t0) -> P (pairC' t l)) ->
  forall c : closureC', P c.
  Proof with auto.
    intros P h; refine (fix IH (c : closureC') : P c := _);
    destruct c; apply h; induction l; intros; destruct H; [rewrite <- H | apply IHl]...
  Qed.

  Lemma closureC_to_closure_injective : forall (cl cl0 : closureC), closureC_to_closure cl = closureC_to_closure cl0 -> cl = cl0.
  Proof with isda.
    induction cl using closureC_ind; destruct cl0; intro H_eq; inversion H_eq; f_equal; subst; clear H_eq.
    generalize dependent l0; induction l; destruct l0...
    inversion H2; f_equal...
  Qed.
  Hint Resolve closureC_to_closure_injective : ref.

  Definition envC_to_env_injective : forall sC sC0, envC_to_env sC = envC_to_env sC0 -> sC = sC0 :=
    map_injective closureC_to_closure closureC_to_closure_injective.
  Hint Resolve envC_to_env_injective : ref.

  Lemma valueC_to_value_injective : forall (v v0 : valueC), valueC_to_value v = valueC_to_value v0 -> v = v0.
  Proof with auto with ref.
    destruct v; destruct v0; intro H; inversion H; f_equal...
  Qed.
  Hint Resolve valueC_to_value_injective : ref.

  Lemma frameC_to_frame_injective : forall fC fC0, frameC_to_frame fC = frameC_to_frame fC0 -> fC = fC0.
  Proof with auto with ref.
    destruct fC; destruct fC0; intro H; inversion H; f_equal...
  Qed.
  Hint Resolve frameC_to_frame_injective : ref.

  Definition contextC_to_context_injective : forall E E0, contextC_to_context E = contextC_to_context E0 -> E = E0 :=
    map_injective frameC_to_frame frameC_to_frame_injective.
  Hint Resolve contextC_to_context_injective : ref.

  Lemma valueC_to_closureC_injective : forall (v v0 : valueC), valueC_to_closureC v = valueC_to_closureC v0 -> v = v0.
  Proof with auto.
    destruct v; destruct v0; intro H; inversion H; f_equal...
  Qed.
  Hint Resolve valueC_to_closureC : ref.

  Lemma value_to_closure_injective : forall v v0, value_to_closure v = value_to_closure v0 -> v = v0.
  Proof.
    destruct v; destruct v0; intro H; inversion H; f_equal...
  Qed.
  Hint Resolve value_to_closure_injective : ref.
  Lemma redex_to_closure_injective : forall r r0, redex_to_closure r = redex_to_closure r0 -> r = r0.
  Proof.
    destruct r; destruct r0; intro H; inversion H; f_equal; auto with ref.
  Qed.

  Lemma pairC_pair : forall t sC, closureC_to_closure (pairC t sC) = pair t (map closureC_to_closure sC).
  Proof. auto. Qed.
  Lemma pairC_injective : forall t t0 sC sC0, pairC t sC = pairC t0 sC0 -> t = t0 /\ sC = sC0.
  Proof.
    intros t t0 sC sC0 PS; inversion PS; auto.
  Qed.
  Lemma valueC_to_closure_commutes : forall v, value_to_closure (valueC_to_value v) = closureC_to_closure (valueC_to_closureC v).
  Proof. destruct v; isda. Qed.

  Fixpoint nth_option (s : env) (n : nat) {struct s} : option closure :=
  match s, n with
  | nil, _ => None
  | h::t, O => Some h
  | h::t, S m => nth_option t m
  end.

  Definition contract (r : redex) : option closure :=
  match r with
  | r_beta (v_lam t s) cl => Some (pair t (value_to_closure cl :: s))
  | r_get x s => nth_option s x
  | r_app t s cl => Some (comp (pair t cl) (pair s cl))
  end.

  Definition only_empty (c : closure) : Prop := forall c0 E, plug c0 E = c -> E = empty.
  Definition only_trivial (c : closure) : Prop := forall c0 E, plug c0 E = c -> E = empty \/ exists v, c0 = value_to_closure v.

  Lemma closureC_only_empty : forall cC, only_empty (closureC_to_closure cC).
  Proof with isda.
    intros cC c E; generalize dependent c; induction E...
    assert (T := IHE _ H); subst; destruct cC; destruct a; discriminate.
  Qed.
  Lemma value_trivial : forall v : value, only_trivial (value_to_closure v).
  Proof with isda.
    intros v c E; generalize dependent c; induction E...
    destruct (IHE _ H) as [H0 | [v0 H0]]; subst; simpl in *;
    match goal with [Hdisc : atom_plug ?t ?a = _ ?v |- _ ] => destruct a; destruct v; discriminate Hdisc end.
  Qed.
  Lemma redex_trivial : forall r : redex, only_trivial (redex_to_closure r).
  Proof with isda; eauto.
    intros r c E; generalize dependent c; induction E...
    right; destruct (IHE _ H) as [H0 | [v0 H0]]; subst; simpl in *;
    match goal with [Hinv : atom_plug ?c ?a = _ ?rv |- _ ] => destruct a; destruct rv; inversion Hinv end...
  Qed.
  Lemma value_redex : forall (v : value) (r : redex), value_to_closure v <> redex_to_closure r.
  Proof.
    destruct v; destruct r; isda.
  Qed.

  Lemma ot_subt : forall c c0 f, only_trivial c -> atom_plug c0 f = c -> exists v, c0 = value_to_closure v.
  Proof with isda; eauto.
    intros; destruct (H c0 (f :: nil)) as [H1 | [v H1]]...
  Qed.

  Ltac ot_v c f :=
  match goal with
  | [Hot : (only_trivial ?H1) |- _] => destruct (ot_subt _ c f Hot) as [?v HV]; [auto | subst c]
  end.

  Ltac mlr rv :=
  match goal with
  | [ |- (exists v, ?H1 = value_to_closure v) \/ (exists r, ?H1 = redex_to_closure r)] =>
    match rv with
    | (?v : value) => left; exists v
    | (?r : redex) => right; exists r
    end; simpl; auto
  end.

  Lemma trivial_val_red : forall c : closure, only_trivial c ->
    (exists v : value, c = value_to_closure v) \/ (exists r : redex, c = redex_to_closure r).
  Proof.
    destruct c; intros.
    destruct t.
    mlr (r_get n l).
    mlr (v_lam t l).
    mlr (r_app t1 t2 l).
    ot_v c1 (ap_r c2); ot_v c2 (ap_l v); mlr (r_beta v v0).
  Qed.

  (** Datatype of decompositions -- either a value or a redex in a context (analogous to the decompose lemma) *)
  Inductive decomp : Set :=
  | d_val : value -> decomp
  | d_red : redex -> context -> decomp.

  Inductive interm_dec : Set :=
  | in_red : redex -> interm_dec
  | in_val : value -> interm_dec
  | in_clo : closure -> frame -> interm_dec.

  Definition decomp_to_closure (d : decomp) : closure :=
  match d with
    | d_val v => value_to_closure v
    | d_red r c0 => plug (redex_to_closure r) c0
  end.

  Definition closureC_dec : forall cC : closureC,
    {p : term * envC + valueC | match p with
	| inl (t, sC) => cC = pairC t sC
	| inr vC => cC = valueC_to_closureC vC
    end}.
  Proof with auto.
    destruct cC as [t sC]; exists (inl _ (t, sC))...
  Defined.
  Lemma dec_pairC : forall t sC, proj1_sig (closureC_dec (pairC t sC)) = inl _ (t, sC).
  Proof with auto.
    intros; simpl in *...
  Qed.

End CallByValue.

Module CBV_Prop <: LANG_PROP CallByValue := Lang_Prop CallByValue.

Module CallByValue_Eval <: RED_SEM CallByValue.
  Import CallByValue.
  Module P := CBV_Prop.
  Import P.
  Open Scope red_scope.

  Inductive dec' : closure -> context -> decomp -> Prop :=
  | d_var  : forall n s E,
               dec' (pair (var n) s) E (d_red (r_get n s) E)
  | d_v    : forall v E d
               (DEC_E : decctx E v d),
               dec' (v : closure) E d
  | d_app  : forall t0 t1 s E,
               dec' (pair (app t0 t1) s) E (d_red (r_app t0 t1 s) E)
  | d_cmp  : forall c0 c1 E d
               (DEC_C : dec' c0 (ap_r c1 :: E) d),
               dec' (comp c0 c1) E d
  with decctx : context -> value -> decomp -> Prop :=
  | dc_emp : forall v, decctx empty v (d_val v)
  | dc_apR : forall cl E v d
               (DEC_C : dec' cl (ap_l v :: E) d),
               decctx (ap_r cl :: E) v d
  | dc_apL : forall v v0 E,
               decctx (ap_l v :: E) v0 (d_red (r_beta v v0) E).

  Definition dec := dec'.
  Scheme dec_Ind := Induction for dec' Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop.

  Inductive decempty : closure -> decomp -> Prop :=
  | d_intro : forall (c : closure) (d : decomp) (DEC : dec c empty d), decempty c d.

  Inductive iter : decomp -> value -> Prop :=
  | i_val : forall (v : value), iter (d_val v) v
  | i_red : forall (r : redex) (c : closure) (E : context) (d : decomp) (v : value)
              (CONTR : contract r = Some c)
              (D_EM  : decempty (E [c]) d)
              (R_IT  : iter d v),
              iter (d_red r E) v.

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall (t : term) (d : decomp) (v : value)
                (D_EM : decempty (pair t nil) d)
                (ITER : iter d v),
                eval t v.

  Hint Constructors dec' decctx decempty iter eval.
  Hint Unfold dec.

  (** A redex in context will only ever be reduced to itself *)
  Lemma dec_redex_self : forall (r : redex) (c : context), dec (redex_to_closure r) c (d_red r c).
  Proof. destruct r; repeat constructor. Qed.

  Lemma decompose : forall c : closure, (exists v : value, c = v) \/
      (exists r : redex, exists E :context, c = E [ r ]).
  Proof with isda.
    induction c; try destruct t...
    right; exists (r_get n l); exists empty...
    left;  exists (v_lam t l)...
    right; exists (r_app t1 t2 l); exists empty...
    destruct IHc1 as [[v Hv] | [r [E HrE]]]; subst.
    destruct IHc2 as [[v0 Hv0] | [r [E HrE]]]; subst.
    right; exists (r_beta v v0); exists empty...
    right; exists r; exists (E · (ap_l v :: nil)); rewrite plug_compose...
    right; exists r; exists (E · (ap_r c2 :: nil)); rewrite plug_compose...
  Qed.

  (** dec is left inverse of plug *)
  Lemma dec_correct : forall c E d, dec c E d -> decomp_to_closure d = E [c].
  Proof with isda.
    induction 1 using dec_Ind with
    (P := fun c E d (DEC : dec c E d) => decomp_to_closure d = E [c])
    (P0:= fun E v d (DECX : decctx E v d) => decomp_to_closure d = E [v])...
  Qed.

  Lemma dec_plug : forall E E0 c d, dec (E [c]) E0 d -> dec c (E · E0) d.
  Proof with isda.
    induction E...
    apply IHE in H; destruct a...
    inversion H; subst; try destruct v...
    inversion H; subst; try destruct v0...
    inversion DEC_C; try destruct v; subst...
    inversion DEC_E; destruct v0; inversion H1; subst...
  Qed.

  Lemma dec_plug_rev : forall E E0 c d, dec c (E · E0) d -> dec (E [c]) E0 d.
  Proof with isda; auto 6.
    induction E; try destruct a...
  Qed.

End CallByValue_Eval.

Module CallByValue_Ref <: RED_REF_LANG.

  Module Lang := CallByValue.
  Import Lang.

  Definition dec_closure (cl : closure) : interm_dec :=
  match cl with
  | pair (lam t) s => in_val (v_lam t s)
  | pair (var n) s => in_red (r_get n s)
  | pair (app t t0) s => in_red (r_app t t0 s)
  | comp cl0 cl1 => in_clo cl0 (ap_r cl1)
  end.

  Definition dec_context (f : frame) (v : value) : interm_dec :=
  match f with
  | ap_r cl => in_clo cl (ap_l v)
  | ap_l v0 => in_red (r_beta v0 v)
  end.

  Inductive subclosure_one_step : closure -> closure -> Prop :=
  | scl : forall cl cl0 f (AP : cl = atom_plug cl0 f), subclosure_one_step cl0 cl.
  Lemma subclosure_one_step_wf : well_founded subclosure_one_step.
  Proof. prove_st_wf. Qed.

  Definition closure_order : closure -> closure -> Prop := clos_trans_n1 _ subclosure_one_step.
  Notation " cl <| cl0 " := (closure_order cl cl0) (at level 40) : red_scope.
  Definition closure_order_wf : well_founded closure_order := wf_clos_trans_r _ _ subclosure_one_step_wf.

  Definition frame_order (f f0 : frame) : Prop :=
  match f, f0 with
  | ap_l _, ap_r _ => True
  | _, _ => False
  end.
  Notation " f <: f0 " := (frame_order f f0) (at level 40) : red_scope.
  Lemma frame_order_wf : well_founded frame_order.
  Proof. prove_ec_wf. Qed.

  Open Scope red_scope.

  Lemma dec_closure_red_empty  : forall c r, dec_closure c = in_red r -> only_empty c.
  Proof with isda.
    destruct c; intros r H; try discriminate; destruct t; inversion H; subst; clear H; intros c E H;
    generalize dependent c; induction E; isda; assert (ht := IHE _ H); subst; destruct a...
  Qed.
  Lemma dec_closure_val_empty  : forall c v, dec_closure c = in_val v -> only_empty c.
  Proof with isda.
    destruct c; intros r H; try discriminate; destruct t; inversion H; subst; clear H; intros c E H;
    generalize dependent c; induction E...
    assert (ht := IHE _ H); subst; destruct a...
  Qed.
  Lemma dec_closure_clo_top    : forall c c0 f, dec_closure c = in_clo c0 f -> forall f0, ~f <: f0.
  Proof.
    destruct c; try destruct t; intros; inversion H; subst; isda.
  Qed.
  Lemma dec_context_red_bot    : forall f v r, dec_context f v = in_red r -> forall f0, ~ f0 <: f.
  Proof.
    destruct f; intros; inversion H; subst; destruct f0; isda.
  Qed.
  Lemma dec_context_val_bot    : forall f v v0, dec_context f v = in_val v0 -> forall f0, ~ f0 <: f.
  Proof. destruct f; isda. Qed.
  Lemma dec_context_clo_next   : forall f f0 v c, dec_context f v = in_clo c f0 -> f0 <: f /\ forall f1, f1 <: f -> ~ f0 <: f1.
  Proof.
    destruct f; intros; inversion H; subst; intuition isda; destruct f1; isda.
  Qed.

  Lemma dec_closure_correct : forall c, match dec_closure c with
    | in_red r => redex_to_closure r = c
    | in_val v => value_to_closure v = c
    | in_clo c0 f =>  atom_plug c0 f = c
    end.
  Proof with isda.
    destruct c; try destruct t...
  Qed.
  Lemma dec_context_correct : forall f v, match dec_context f v with
    | in_red r  => redex_to_closure r  = atom_plug (value_to_closure v) f
    | in_val v0 => value_to_closure v0 = atom_plug (value_to_closure v) f
    | in_clo c f0 => atom_plug c f0 = atom_plug (value_to_closure v) f
    end.
  Proof.
    destruct f; isda.
  Qed.

  Lemma frame_order_antisym : forall f f0, f <: f0 -> ~ f0 <: f.
  Proof.
    destruct f; destruct f0; isda.
  Qed.
  Lemma dec_frame_ord : forall c c0 f f0, atom_plug c f = atom_plug c0 f0 -> f <: f0 \/ f0 <: f \/ (c = c0 /\ f = f0).
  Proof.
    destruct f; destruct f0; intros; inversion H; isda; apply value_to_closure_injective in H1; subst; isda.
  Qed.
  Lemma frame_det : forall c c0 f f0, f <: f0 -> atom_plug c f = atom_plug c0 f0 -> exists v, c0 = value_to_closure v.
  Proof.
    destruct f; destruct f0; intros; inversion H; inversion H0; subst; eauto.
  Qed.

  Lemma getC : forall l i r, nth_option (map closureC_to_closure l) i = Some r ->
    {c:closureC | r = closureC_to_closure c}.
  Proof.
    induction l; induction i; simpl; intros; try discriminate.
    split with a; congruence.
    eapply IHl; eapply H.
  Qed.

  Definition dcl c cC ofC : Prop :=
  match ofC with
  | None => c = closureC_to_closure cC
  | Some fC => dec_closure c = in_clo (closureC_to_closure cC) (frameC_to_frame fC)
  end.

  Definition closure_red : forall cC r cl (DCL : dec_closure (closureC_to_closure cC) = in_red r) (CTR : contract r = Some cl),
    {p : closureC * option frameC | match p with (cC, ofC) => dcl cl cC ofC end }.
  Proof with isda.
    destruct cC; destruct t; intros; inversion DCL; subst; inversion CTR; subst.
    destruct (getC _ _ _ H0) as [cC EQCC]; subst; exists (cC, None)...
    exists (pairC t1 l, Some (ap_rC (pairC t2 l)))...
  Defined.
  Definition context_red : forall fC vC r cl (DCT : dec_context (frameC_to_frame fC) (valueC_to_value vC) = in_red r) (CTR : contract r = Some cl),
    {p : closureC * option frameC | match p with (cC, ofC) => dcl cl cC ofC end}.
  Proof with isda.
    destruct fC; intros; inversion DCT; subst; destruct v; inversion CTR; subst.
    exists (pairC t ((valueC_to_closureC vC) :: e), None); simpl; repeat f_equal.
    rewrite valueC_to_closure_commutes...
  Defined.
  Definition closure_val : forall cC v (DCL : dec_closure (closureC_to_closure cC) = in_val v), { vC : valueC | v = valueC_to_value vC}.
  Proof with isda.
    destruct cC as [t sC]; destruct t; intros; inversion DCL; subst; exists (v_lamC t sC)...
  Defined.
  Definition context_val : forall fC vC v (DCT : dec_context (frameC_to_frame fC) (valueC_to_value vC) = in_val v),
    {vC0 : valueC | v = valueC_to_value vC0}.
  Proof with isda.
    destruct fC...
  Defined.
  Definition context_clo : forall fC vC cl f (DCT : dec_context (frameC_to_frame fC) (valueC_to_value vC) = in_clo cl f),
    { p : closureC * frameC | match p with
      (cC, fC) => cl = closureC_to_closure (cC) /\ f = frameC_to_frame fC
    end}.
  Proof with isda.
    destruct fC; intros; inversion DCT; subst; exists (c, ap_lC vC)...
  Defined.

  (*Definition closure_red : forall cC r cl (DCL : dec_closure (closureC_to_closure cC) = in_red r) (CTR : contract r = Some cl),
    {p : term * envC * option frameC | match p with (t, sC, ofC) => dcl cl t sC ofC end }.
  Proof with isda.
    destruct cC; destruct t; intros; inversion DCL; subst; inversion CTR; subst.
    destruct (getC _ _ _ H0) as [cC EQCC]; subst; destruct cC.
    exists (t, l0, None)...
    exists (t1, l, Some (ap_rC (pairC t2 l)))...
  Defined.
  Lemma context_red : forall fC vC r cl (DCT : dec_context (frameC_to_frame fC) (valueC_to_value vC) = in_red r) (CTR : contract r = Some cl),
    {p : term * envC * option frameC | match p with (t, sC, ofC) => dcl cl t sC ofC end}.
  Proof with isda.
    destruct fC; intros; inversion DCT; subst; destruct vC; destruct v; inversion CTR; subst.
    exists (t0, (pairC (lam t) e)  :: e0, None)...
  Defined.
  Lemma closure_val : forall cC v (DCL : dec_closure (closureC_to_closure cC) = in_val v), { vC : valueC | v = valueC_to_value vC}.
  Proof with isda.
    destruct cC; destruct t; intros; inversion DCL; subst; exists (v_lamC t l)...
  Defined.
  Lemma context_val : forall fC vC v (DCT : dec_context (frameC_to_frame fC) (valueC_to_value vC) = in_val v),
    {vC0 : valueC | v = valueC_to_value vC0}.
  Proof.
    destruct fC; isda.
  Defined.
  Lemma context_clo : forall fC vC cl f (DCT : dec_context (frameC_to_frame fC) (valueC_to_value vC) = in_clo cl f),
    { p : term * envC * frameC | match p with
      (t, sC, fC) => cl = closureC_to_closure (pairC t sC) /\ f = frameC_to_frame fC
    end}.
  Proof.
    destruct fC; intros; inversion DCT; destruct c; subst.
    exists (t, l, ap_lC vC); isda.
  Defined.*)

  Close Scope red_scope.

End CallByValue_Ref.

Module CBV_RS <: RED_REF_SEM CallByValue := RedRefSem CallByValue_Ref.

Section Equivalence.

  Import CallByValue.

  Lemma dec_equiv : forall c E d, CallByValue_Eval.dec c E d <-> CBV_RS.dec c E d.
  Proof with isda.
    split...
    induction H using CallByValue_Eval.dec_Ind with
    (P := fun c E d (DEC : CallByValue_Eval.dec c E d) => CBV_RS.dec c E d)
    (P0:= fun E v d (DECX : CallByValue_Eval.decctx E v d) => CBV_RS.decctx E v d)...
    destruct v; econstructor...
    econstructor 3...
    econstructor 4...
    induction H using CBV_RS.dec_Ind with
    (P := fun c E d (DEC : CBV_RS.dec c E d) => CallByValue_Eval.dec c E d)
    (P0:= fun E v d (DECX : CBV_RS.decctx E v d) => CallByValue_Eval.decctx E v d);
    match goal with
    | [ DCL : CBV_RS.dec_closure ?c = ?int |- _ ] => destruct c; try destruct t; inversion DCL; subst
    | [ DCT : CBV_RS.dec_context ?f ?v = ?int |- _ ] => destruct f; inversion DCT; subst
    | [ |- _ ] => idtac
    end...
    cutrewrite ((pair' (lam t) l : closure) = (v_lam t l : value)); auto.
  Qed.

  Lemma iter_equiv : forall d v, CallByValue_Eval.iter d v <-> CBV_RS.RS.iter d v.
  Proof with isda.
    split; intro H; induction H; econstructor; eauto; constructor; inversion_clear D_EM;
    [rewrite <- dec_equiv | rewrite dec_equiv]...
  Qed.

  Lemma eval_equiv : forall t v, CallByValue_Eval.eval t v <-> CBV_RS.RS.eval t v.
  Proof with isda.
    split; intro H; inversion_clear H; inversion_clear D_EM; constructor 1 with d;
      [constructor; rewrite <- dec_equiv | rewrite <- iter_equiv
      | constructor; rewrite dec_equiv | rewrite iter_equiv]...
  Qed.

End Equivalence.

Module CBV_EAM <: PROPER_EA_MACHINE CallByValue := ProperEAMachine CallByValue CBV_RS.

Module CEKMachine <: ABSTRACT_MACHINE.

  Import CallByValue.
  Module P := CBV_Prop.
  Import P.
  Import CBV_EAM.
  Open Scope red_scope.
  Open Scope eam_scope.

  Definition term := term.
  Definition value := valueC.
  Definition configuration := configuration.
  Definition c_init := c_init.
  Definition c_final := c_final.

  Reserved Notation " c |> c0 " (at level 70, no associativity).

  Inductive transition' : configuration -> configuration -> Prop :=
  | t_init : forall t,
      <<i t >> |> << t, nil, emptyC >>
  | t_lam  : forall t sC EC,
      << lam t, sC, EC >> |> << EC, v_lamC t sC >>
  | t_var  : forall n sC sC0 t0 EC
      (GET : nth_option (envC_to_env sC) n = Some (closureC_to_closure (pairC t0 sC0))),
      << var n, sC, EC >> |> << t0, sC0, EC >>
  | t_app  : forall t0 t1 sC EC,
      << app t0 t1, sC, EC >> |> << t0, sC, ap_rC (pairC t1 sC) :: EC >>
  | t_val  : forall v,
      << emptyC, v >> |> <<f v >>
  | t_apR  : forall t sC EC vC,
      << ap_rC (pairC t sC) :: EC, vC >> |> << t, sC, ap_lC vC :: EC >>
  | t_apL  : forall t sC EC vC,
      << ap_lC (v_lamC t sC) :: EC, vC >> |> << t, (vC : closureC) :: sC, EC >>

  where " c |> c0 " := (transition' c c0).

  Definition transition := transition'.

  Inductive trans_close : configuration -> configuration -> Prop :=
  | one_step   : forall (c0 c1 : configuration), transition c0 c1 -> trans_close c0 c1
  | multi_step : forall (c0 c1 c2 : configuration), transition c0 c1 -> trans_close c1 c2 -> trans_close c0 c2.

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall (t : term) (v : value), trans_close (c_init t) (c_final v) -> eval t v.

  Hint Constructors transition' trans_close eval.
  Hint Unfold transition.
  Notation " c |>+ c0 " := (trans_close c c0) (at level 70, no associativity).

  Lemma trans_eam_cek : forall c c0, c → c0 -> c |> c0.
  Proof with isda.
    intros; inversion H; auto; try unfold dec_closure in DCL; try unfold dec_context in DCT.
    (* red *)
    remember (closure_red _ _ _ DCL CONTR) as UNF; clear HeqUNF; destruct UNF as [[cc [ff |]] HUNF];
    destruct t; inversion DCL; inversion TO_C; isda; subst...
      (* var *)
    destruct (CallByValue_Ref.getC _ _ _ CONTR) as [ccC HcC]; destruct ccC; destruct t; subst...
      (* app *)
    inversion CONTR; subst; inversion HUNF; destruct cC; inversion UNFOLD; subst...
    replace (ap_r (pair t2 (map closureC_to_closure sC))) with (frameC_to_frame (ap_rC (pairC t2 sC))) in H2; auto;
    inversion H1; apply envC_to_env_injective in H4; apply frameC_to_frame_injective in H2; subst...
      (* var *)
      destruct cC; inversion UNFOLD; subst...
      destruct cC; inversion CONTR.
    destruct cC; inversion UNFOLD.
    (* val *)
    remember (closure_val _ _ DCL) as UNF; clear HeqUNF; destruct UNF as [vC0 HUNF];
    destruct t; inversion DCL; isda; subst...
    replace (v_lam t (map closureC_to_closure sC)) with (valueC_to_value (v_lamC t sC)) in H3; auto;
    apply valueC_to_value_injective in H3; subst...
    (* beta *)
    remember (context_red _ _ _ _ DCT CONTR) as UNF; clear HeqUNF; destruct UNF as [[ccC [ff |]] HUNF];
      destruct f; inversion DCT; inversion TO_C; destruct v0; isda; subst; inversion CONTR; destruct cC;
        inversion UNFOLD; subst...
    destruct t0...
    inversion H1; destruct sC; inversion H3; subst.
    apply envC_to_env_injective in H5; rewrite valueC_to_closure_commutes in H4;
      apply closureC_to_closure_injective in H4; subst...
    destruct cC; inversion UNFOLD.
    (* c-val (False) *)
    destruct fC; inversion DCT.
    (* ap_r *)
    remember (context_clo _ _ _ _ DCT) as UNF; clear HeqUNF; destruct UNF as [[ccC ff] [H_cl H_f]];
    destruct fC; inversion DCT; inversion TO_C; destruct cC; inversion UNFOLD; isda; subst.
    replace (ap_l (valueC_to_value vC)) with (frameC_to_frame (ap_lC vC)) in H_f; auto;
    apply frameC_to_frame_injective in H_f; apply closureC_to_closure_injective in H_cl; subst...
    destruct cC; inversion UNFOLD.
  Qed.

  Lemma trans_cek_eam : forall c c0, c |> c0 -> c → c0.
  Proof with isda.
    intros; inversion H; auto.
    (* lam *)
    assert (DCL : CBV_RS.dec_closure (closureC_to_closure (pairC (lam t) sC)) = in_val (valueC_to_value (v_lamC t sC))); auto.
    constructor 4 with _ DCL.
    remember (closure_val _ _ DCL) as UNF; clear HeqUNF; destruct UNF as [vC HUNF]; simpl; apply valueC_to_value_injective in HUNF...
    (* var *)
    assert (DCL : CBV_RS.dec_closure (closureC_to_closure (pairC (var n) sC)) = in_red (r_get n (envC_to_env sC))); auto.
    assert (CONTR : contract (r_get n (envC_to_env sC)) = Some (closureC_to_closure (pairC t0 sC0))); auto.
    replace EC with (opt_to_list None × EC); auto.
    constructor 2 with _ _ (pairC t0 sC0) DCL CONTR; auto.
    remember (closure_red _ _ _ DCL CONTR) as UNF; clear HeqUNF; destruct UNF as [[ccC [ff |]] HUNF]...
    destruct t0...
    destruct ccC; inversion HUNF; subst; unfold pairC; repeat f_equal; apply envC_to_env_injective...
    (* app *)
    assert (DCL : CBV_RS.dec_closure (closureC_to_closure (pairC (app t0 t1) sC)) = in_red (r_app t0 t1 (envC_to_env sC))); auto.
    assert (CONTR : contract (r_app t0 t1 (envC_to_env sC)) = Some (comp (closureC_to_closure (pairC t0 sC)) (closureC_to_closure (pairC t1 sC)))); auto.
    replace (ap_rC (pairC t1 sC) :: EC) with (opt_to_list (Some (ap_rC (pairC t1 sC))) × EC); auto.
    constructor 2 with _ _ (pairC t0 sC) DCL CONTR; auto.
    remember (closure_red _ _ _ DCL CONTR) as UNF; clear HeqUNF; destruct UNF as [[ccC [ff |]] HUNF];
      isda; destruct ccC; inversion HUNF; subst; unfold pairC; repeat f_equal;
        [apply envC_to_env_injective | apply frameC_to_frame_injective]...
    (* ap_r *)
    assert (DCT : CBV_RS.dec_context (frameC_to_frame (ap_rC (pairC t sC))) (valueC_to_value vC) = in_clo (closureC_to_closure (pairC t sC)) (frameC_to_frame (ap_lC vC))); auto.
    constructor 9 with _ _ (pairC t sC) DCT; auto.
    remember (context_clo _ _ _ _ DCT) as UNF; clear HeqUNF; destruct UNF as [[ccC ff] [H_cl H_f]];
      isda; destruct ccC; inversion H_cl; unfold pairC; repeat f_equal;
        [apply envC_to_env_injective | apply frameC_to_frame_injective]...
    (* ap_l *)
    assert (DCT : CBV_RS.dec_context (frameC_to_frame (ap_lC (v_lamC t sC))) (valueC_to_value vC) = in_red (r_beta (valueC_to_value (v_lamC t sC)) (valueC_to_value vC))); auto.
    assert (CONTR : contract (r_beta (valueC_to_value (v_lamC t sC)) (valueC_to_value vC)) = Some (closureC_to_closure (pairC t ((vC : closureC) :: sC)))).
    simpl; rewrite valueC_to_closure_commutes; auto.
    replace EC with (opt_to_list None × EC); auto.
    constructor 6 with _ _ (pairC t ((vC:closureC) :: sC)) DCT CONTR; auto.
    remember (context_red _ _ _ _ DCT CONTR) as UNF; clear HeqUNF;
      destruct UNF as [[ccC [ff |]] HUNF]...
    destruct t...
    destruct ccC; inversion HUNF; unfold pairC; repeat f_equal; apply envC_to_env_injective...
  Qed.

  Lemma tcl_eam_cek : forall c c0, c →+ c0 -> c |>+ c0.
  Proof.
    induction 1; eauto using trans_eam_cek.
  Qed.

  Lemma tcl_cek_eam : forall c c0, c |>+ c0 -> c →+ c0.
  Proof.
    induction 1; eauto using trans_cek_eam.
  Qed.

  Lemma eval_cek : forall t v, AM.eval t v <-> eval t v.
  Proof.
    split; intro H; inversion_clear H; auto using tcl_cek_eam, tcl_eam_cek.
  Qed.

  Theorem CEKMachineCorrect : forall t (v : CallByValue.valueC), CallByValue_Eval.eval t (CallByValue.valueC_to_value v) <-> eval t v.
  Proof with auto.
    intros; rewrite eval_equiv; rewrite eval_apply_correct; apply eval_cek.
  Qed.

End CEKMachine.


Set Warnings "-notation-overridden".

From Coq Require Extraction Setoid ZArith.

Module Classes.

Export Setoid Morphisms.

(* Definition relation (A : Type) : Type :=
  A -> A -> Prop.

Definition respectful {A B : Type}
  (R : relation A) (S : relation B) (f g : A -> B) : Prop :=
  forall x y : A, R x y -> S (f x) (g y).

Definition Proper {A : Type} (R : relation A) (x : A) : Prop :=
  R x x.

Reserved Notation "R '==>' S" (at level 55, right associativity).
Notation "R '==>' S" := (respectful R S). *)
Reserved Notation "x '::>' R" (at level 60, right associativity).
Notation "x '::>' R" := (Proper R x).

Class Eqv (A : Type) : Type := eqv : A -> A -> Prop.
Class Opr (A : Type) : Type := opr : A -> A -> A.
Class Idn (A : Type) : Type := idn : A.
Class Inv (A : Type) : Type := inv : A -> A.

Reserved Notation "x '==' y" (at level 70, no associativity).
Notation "x '==' y" := (eqv x y).
Notation "x '+' y" := (opr x y).
Notation "'0'" := idn.
Notation "'-' x" := (inv x).
Notation "x '-' y" := (x + (- y)).

Class Setoid (A : Type) {eqv : Eqv A} : Prop := {
  ref : forall x : A, x == x;
  sym : forall x y : A, x == y -> y == x;
  tra : forall x y z : A, x == y -> y == z -> x == z;
}.

Class Semigroup (A : Type) {eqv : Eqv A} {opr : Opr A} : Prop := {
  setoid :> Setoid A;
  opr_pro : opr ::> eqv ==> eqv ==> eqv;
  ass : forall x y z : A, (x + y) + z == x + (y + z);
}.

Class Monoid (A : Type) {eqv : Eqv A} {opr : Opr A} {idn : Idn A} : Prop := {
  semigroup :> Semigroup A;
  idn_l : forall x : A, 0 + x == x;
  idn_r : forall x : A, x + 0 == x;
}.

Class Group (A : Type) {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} : Prop := {
  monoid :> Monoid A;
  inv_pro : inv ::> eqv ==> eqv;
  inv_l : forall x : A, (- x) + x == 0;
  inv_r : forall x : A, x + (- x) == 0;
}.

Add Parametric Relation {A : Type} {eqv' : Eqv A}
  {std' : Setoid A} : A eqv
  reflexivity proved by ref
  symmetry proved by sym
  transitivity proved by tra
  as eqv_relation.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {opr' : Opr A} {sgr' : Semigroup A} : opr
  with signature eqv ==> eqv ==> eqv
  as eqv_opr_morphism.
Proof.
  intros x y p z w q.
  destruct sgr' as [_ opr_pro _].
  cbv in opr_pro. apply opr_pro.
  - apply p.
  - apply q. Qed.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {opr' : Opr A} {idn' : Idn A} {inv' : Inv A} {grp' : Group A} : inv
  with signature eqv ==> eqv
  as eqv_inv_morphism.
Proof.
  intros x y p.
  destruct grp' as [_ inv_pro _ _].
  cbv in inv_pro. apply inv_pro. apply p. Qed.

End Classes.

Module Properties.

Import Classes.

Theorem ivl : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x : A, - (- x) == x.
Proof.
  intros A eqv opr idn inv grp x.
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite <- (pnr (- (- x))). rewrite <- (pvl x).
  rewrite <- (pa (- (- x)) (- x) x). rewrite (pvl (- x)). rewrite (pnl x).
  reflexivity. Qed.

Lemma inj_l : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y z : A, z + x == z + y -> x == y.
Proof.
  intros A eqv opr idn inv grp x y z p.
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite <- (pnl x). rewrite <- (pvl z). rewrite (pa (- z) z x).
  rewrite p. rewrite <- (pa (- z) z y). rewrite (pvl z). rewrite (pnl y).
  reflexivity. Qed.

Lemma inj_r : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y z : A, x + z == y + z -> x == y.
Proof.
  intros A eqv opr idn inv grp x y z p.
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite <- (pnr x). rewrite <- (pvr z). rewrite <- (pa x z (- z)).
  rewrite p. rewrite (pa y z (- z)). rewrite (pvr z). rewrite (pnr y).
  reflexivity. Qed.

Theorem dis : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y : A, - (y + x) == (- x) + (- y).
Proof.
  intros A eqv opr idn inv grp x y.
  apply (inj_l (- (y + x)) ((- x) + (- y)) (y + x)).
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite (pvr (y + x)). rewrite <- (pa (y + x) (- x) (- y)).
  rewrite (pa y x (- x)). rewrite (pvr x). rewrite (pnr y). rewrite (pvr y).
  reflexivity. Qed.

End Properties.

Module Instances.

Import ZArith Z Classes.

Open Scope Z_scope.

Instance Z_Eqv : Eqv Z := fun x y : Z => x = y.

Instance Z_Setoid : Setoid Z := {
  ref := _;
  sym := _;
  tra := _;
}.
Proof.
  all: cbv [eqv].
  all: cbv [Z_Eqv].
  - apply eq_refl.
  - apply eq_sym.
  - apply eq_trans. Qed.

Instance Z_Opr : Opr Z := fun x y : Z => x + y.

Instance Z_Semigroup : Semigroup Z := {
  opr_pro := _;
  ass := _;
}.
Proof.
  all: cbv [eqv opr].
  all: cbv [Z_Eqv Z_Opr].
  - apply add_wd.
  - intros x y z. rewrite add_assoc. reflexivity. Qed.

Instance Z_Idn : Idn Z := 0.

Instance Z_Monoid : Monoid Z := {
  idn_l := _; idn_r := _;
}.
Proof.
  all: cbv [eqv opr idn].
  all: cbv [Z_Eqv Z_Opr Z_Idn].
  - intros x. rewrite add_0_l. reflexivity.
  - intros x. rewrite add_0_r. reflexivity. Qed.

Instance Z_Inv : Inv Z := fun x => - x.

Instance Z_Group : Group Z := {
  inv_pro := _;
  inv_l := _; inv_r := _;
}.
Proof.
  all: cbv [eqv opr idn inv].
  all: cbv [Z_Eqv Z_Opr Z_Idn Z_Inv].
  - apply opp_wd.
  - intros x. rewrite add_opp_diag_l. reflexivity.
  - intros x. rewrite add_opp_diag_r. reflexivity. Qed.

End Instances.

Module Computations.

Section Input.

Import ZArith Z.

Open Scope Z_scope.

Definition meaning := 42.
Definition luck := 13.

End Input.

Section Output.

Import Classes.

Example fate := meaning - luck.

End Output.

Section Test.

Import ZArith Z.

Open Scope Z_scope.

Compute if eq_dec fate 29 then true else false.

End Test.

End Computations.

Extraction "example.ml" Classes Properties Instances Computations.


Set Implicit Arguments.

Require Import
        List
        ListDec
        Tactics.Tactics.

Import ListNotations.

Fixpoint zipWith
         {A B C : Type}
         (f : A -> B -> C)
         (ls : list A)
         (ls' : list B) : list C :=
  match ls, ls' with
  | [] , _ => []
  | _  , [] => []
  | (x :: xs), (y :: ys) => f x y :: zipWith f xs ys
  end.

Fixpoint replicate {A : Type}(n : nat)(xs : list A) : list A :=
  match n with
  | O => []
  | S n' => xs ++ replicate n' xs
  end.

Lemma replicate_nil {A : Type} :
  forall n, replicate n (@nil A) = (@nil A).
Proof.
  induction n ; crush.
Qed.

Lemma Forall_app {A : Type}
  : forall (P : A -> Prop)
      (xs ys : list A), (Forall P xs /\ Forall P ys) <-> (Forall P (xs ++ ys)).
Proof.
  induction xs ; destruct ys ; splits ; intros H ; crush.
  +
    rewrite <- app_nil_end ; auto.
  +
    rewrite <- app_nil_end in H ; auto.
  +
    inverts* H0.
    constructor ; auto.
    destruct (IHxs (a0 :: ys)).
    apply H.
    splits*.
  +
    destruct (IHxs (a0 :: ys)).
    inverts* H.
    lets* J : H1 H5.
  +
    constructor.
    inverts* H.
    destruct (IHxs (a0 :: ys)).
    lets* J : H0 H3.
    destruct* J.
    inverts* H4.
    inverts* H.
    destruct (IHxs (a0 :: ys)).
    lets* J : H0 H3.
    destruct* J.
    inverts* H4.
Qed.

Lemma replicate_cons {A : Type}
  : forall n x (xs : list A), replicate (S n) (x :: xs) = (x :: xs) ++ replicate n (x :: xs).
Proof.
  induction n ; crush.
Qed.

Lemma replicate_forall
      {A : Type}{P : A -> Prop} :
  forall xs, Forall P xs -> forall n, Forall P (replicate n xs).
Proof.
  induction xs ; intros H n ; destruct* n ; crush.
  +
    rewrite replicate_nil ; auto.
  +
    inverts* H.
    constructor ; eauto.
    apply Forall_app ; splits*.
    destruct n ; simpl in * ; eauto.
    constructor ; auto.
    apply Forall_app ; splits*.
    induction n ; crush.
    -
      constructor ; auto.
      apply Forall_app ; crush.
Qed.

Lemma count_occ_app {A : Type}
      (eqA : forall (x y : A), {x = y} + {x <> y})
  : forall (xs ys : list A) x, count_occ eqA (xs ++ ys) x = count_occ eqA xs x + count_occ eqA ys x.
Proof.
  induction xs ; crush.
  destruct* (eqA a x) ; crush.
Qed.

Lemma replicate_count_occ_not_in
      {A : Type}(eqA : forall (x y : A), {x = y} + {x <> y})
  : forall (xs : list A) x, ~ In x xs -> forall n, count_occ eqA (replicate n xs) x = 0.
Proof.
  induction xs ; intros ; crush.
  +
    rewrite replicate_nil ; crush.
  +
    lets J : IHxs H1.
    induction n ; crush.
    destruct* (eqA a x) ; crush.
    eapply (count_occ_not_In eqA) in H1.
    rewrite count_occ_app.
    crush.
Qed.

Lemma replicate_count_occ {A : Type}
      (eqA : forall (x y : A), {x = y} + {x <> y})
  : forall (xs : list A), NoDup xs -> (forall x, In x xs ->
                                      forall n, count_occ eqA (replicate n xs) x = n).
Proof.
  Hint Constructors NoDup.
  induction xs ; crush.
  +
    inverts* H.
    eapply (replicate_count_occ_not_in eqA) with (n := n) in H2.
    induction n ; crush.
    destruct (eqA x x) ; crush.
    rewrite count_occ_app in *.
    assert (Lem : forall (n m : nat), n + m = 0 -> n = 0 /\ m = 0) by (induction n ; crush).
    apply Lem in H2.
    destruct* H2. rewrite H1 in *.
    crush.
  +
    inverts* H.
    induction n ; crush.
    destruct (eqA a x) ; crush.
    rewrite count_occ_app.
    apply (count_occ_In eqA) in  H1.
    eapply (NoDup_count_occ eqA) with (x := x) in H4.
    crush.
Qed.

Lemma flat_map_In {A B : Type} :
  forall (f : A -> list B)(xs : list A) x y,
    In y (f x) ->
    In x xs    ->
    In y (flat_map f xs).
Proof.
  inductions xs ; crush ;
  apply in_app_iff ; right*.
Qed.


(* Unary and binary primitives are pure *)
Inductive binary_primitives : Set :=
| Add | Sub | Mul | Div | Mod
| Lt | Le | Eq
| Or | And
| Tup.

Inductive unary_primitives : Set :=
| Neg | Not | Fst | Snd | Left | Right | Id.


(****************************************************************
 Comma objects in bicategories

 In this file we define the notion of comma squares in arbitrary
 bicategories. This definition is expressed using universal
 properties.

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.

Local Open Scope cat.

Section CommaObject.
  Context {B : bicat}
          {b₁ b₂ b₃ : B}
          {f : b₁ --> b₃}
          {g : b₂ --> b₃}.

  (**
    1. Cones
   *)
  Definition comma_cone
    : UU
    := ∑ (p : B)
         (π₁ : p --> b₁)
         (π₂ : p --> b₂),
       π₁ · f ==> π₂ · g.

  Coercion comma_cone_obj
           (p : comma_cone)
    : B
    := pr1 p.

  Definition comma_cone_pr1
             (p : comma_cone)
    : p --> b₁
    := pr12 p.

  Definition comma_cone_pr2
             (p : comma_cone)
    : p --> b₂
    := pr122 p.

  Definition comma_cone_cell
             (p : comma_cone)
    : comma_cone_pr1 p · f ==> comma_cone_pr2 p · g
    := pr222 p.

  Definition make_comma_cone
             (p : B)
             (π₁ : p --> b₁)
             (π₂ : p --> b₂)
             (η : π₁ · f ==> π₂ · g)
    : comma_cone
    := (p ,, π₁ ,, π₂ ,, η).

  (**
   2. 1-cells and 2-cells of cones
   *)
  Definition comma_1cell
             (p q : comma_cone)
    : UU
    := ∑ (φ : p --> q)
         (τ : invertible_2cell
                (φ · comma_cone_pr1 q)
                (comma_cone_pr1 p))
         (θ : invertible_2cell
                (φ · comma_cone_pr2 q)
                (comma_cone_pr2 p)),
       φ ◃ comma_cone_cell q
       =
       lassociator _ _ _
       • (τ ▹ f)
       • comma_cone_cell p
       • (θ^-1 ▹ g)
       • rassociator _ _ _.

  Coercion comma_1cell_1cell
           {p q : comma_cone}
           (φ : comma_1cell p q)
    : p --> q
    := pr1 φ.

  Definition comma_1cell_pr1
             {p q : comma_cone}
             (φ : comma_1cell p q)
    : invertible_2cell
        (φ · comma_cone_pr1 q)
        (comma_cone_pr1 p)
    := pr12 φ.

  Definition comma_1cell_pr2
             {p q : comma_cone}
             (φ : comma_1cell p q)
    : invertible_2cell
        (φ · comma_cone_pr2 q)
        (comma_cone_pr2 p)
    := pr122 φ.

  Definition comma_1cell_eq
             {p q : comma_cone}
             (φ : comma_1cell p q)
    : φ ◃ comma_cone_cell q
      =
      lassociator _ _ _
      • (comma_1cell_pr1 φ ▹ f)
      • comma_cone_cell p
      • ((comma_1cell_pr2 φ)^-1 ▹ g)
      • rassociator _ _ _
    := pr222 φ.

  Definition make_comma_1cell
             {p q : comma_cone}
             (φ : p --> q)
             (τ : invertible_2cell
                    (φ · comma_cone_pr1 q)
                    (comma_cone_pr1 p))
             (θ : invertible_2cell
                    (φ · comma_cone_pr2 q)
                    (comma_cone_pr2 p))
             (H : φ ◃ comma_cone_cell q
                  =
                  lassociator _ _ _
                  • (τ ▹ f)
                  • comma_cone_cell p
                  • (θ^-1 ▹ g)
                  • rassociator _ _ _)
    : comma_1cell p q
    := (φ ,, τ ,, θ ,, H).

  Definition eq_comma_1cell
             {p q : comma_cone}
             (φ ψ : comma_1cell p q)
             (r₁ : pr1 φ = pr1 ψ)
             (r₂ : pr1 (comma_1cell_pr1 φ)
                   =
                   (idtoiso_2_1 _ _ r₁ ▹ comma_cone_pr1 q) • pr1 (comma_1cell_pr1 ψ))
             (r₃ : pr1 (comma_1cell_pr2 φ)
                   =
                   (idtoiso_2_1 _ _ r₁ ▹ comma_cone_pr2 q) • pr1 (comma_1cell_pr2 ψ))
    : φ = ψ.
  Proof.
    induction φ as [ φ₁ [ φ₂ [ φ₃ φ₄ ]]].
    induction ψ as [ ψ₁ [ ψ₂ [ ψ₃ ψ₄ ]]].
    cbn in r₁.
    induction r₁ ; cbn in r₂.
    apply maponpaths.
    assert (φ₂ = ψ₂) as r'.
    {
      use subtypePath.
      {
        intro ; apply isaprop_is_invertible_2cell.
      }
      rewrite id2_rwhisker, id2_left in r₂.
      exact r₂.
    }
    induction r'.
    apply maponpaths.
    use subtypePath.
    {
      intro ; apply cellset_property.
    }
    cbn.
    cbn in r₃.
    rewrite id2_rwhisker, id2_left in r₃.
    use subtypePath.
    {
      intro ; apply isaprop_is_invertible_2cell.
    }
    exact r₃.
  Qed.

  (**
   3. Statements of universal mapping properties of pullbacks
   *)
  Section UniversalMappingPropertyStatements.
    Variable (p : comma_cone).

    Definition comma_ump_1
      : UU
      := ∏ (q : comma_cone), comma_1cell q p.

    Definition comma_ump_2
      : UU
      := ∏ (q : B)
           (φ ψ : q --> p)
           (α : φ · comma_cone_pr1 p ==> ψ · comma_cone_pr1 p)
           (β : φ · comma_cone_pr2 p ==> ψ · comma_cone_pr2 p)
           (r : (φ ◃ comma_cone_cell p)
                • lassociator _ _ _
                • (β ▹ g)
                • rassociator _ _ _
                =
                lassociator _ _ _
                • (α ▹ f)
                • rassociator _ _ _
                • (ψ ◃ comma_cone_cell p)),
         ∃! (γ : φ ==> ψ),
         (γ ▹ comma_cone_pr1 p = α)
         ×
         (γ ▹ comma_cone_pr2 p = β).

    Definition has_comma_ump
      : UU
      := comma_ump_1 × comma_ump_2.
  End UniversalMappingPropertyStatements.

  Definition has_comma_ump_1
             {p : comma_cone}
             (H : has_comma_ump p)
    : comma_ump_1 p
    := pr1 H.

  Definition has_comma_ump_2
             {p : comma_cone}
             (H : has_comma_ump p)
    : comma_ump_2 p
    := pr2 H.

  Section Projections.
    Context {p : comma_cone}
            (Hp : has_comma_ump p).

    Definition comma_ump_mor
               (q : comma_cone)
      : q --> p
      := pr1 Hp q.

    Definition comma_ump_mor_pr1
               (q : comma_cone)
      : invertible_2cell
          (comma_ump_mor q · comma_cone_pr1 p)
          (comma_cone_pr1 q)
      := comma_1cell_pr1 (pr1 Hp q).

    Definition comma_ump_mor_pr2
               (q : comma_cone)
      : invertible_2cell
          (comma_ump_mor q · comma_cone_pr2 p)
          (comma_cone_pr2 q)
      := comma_1cell_pr2 (pr1 Hp q).

    Definition comma_ump_mor_cell
               (q : comma_cone)
      : pr1 Hp q ◃ comma_cone_cell p
        =
        lassociator (pr1 Hp q) (comma_cone_pr1 p) f
        • (comma_1cell_pr1 (pr1 Hp q) ▹ f)
        • comma_cone_cell q
        • ((comma_1cell_pr2 (pr1 Hp q)) ^-1 ▹ g)
        • rassociator (pr1 Hp q) (comma_cone_pr2 p) g
      := comma_1cell_eq (pr1 Hp q).

    Section CellProperty.
      Context {q : B}
              (φ ψ : q --> p)
              (α : φ · comma_cone_pr1 p ==> ψ · comma_cone_pr1 p)
              (β : φ · comma_cone_pr2 p ==> ψ · comma_cone_pr2 p)
              (r : (φ ◃ comma_cone_cell p)
                   • lassociator _ _ _
                   • (β ▹ g)
                   • rassociator _ _ _
                   =
                   lassociator _ _ _
                   • (α ▹ f)
                   • rassociator _ _ _
                   • (ψ ◃ comma_cone_cell p)).

      Definition comma_ump_cell
        : φ ==> ψ
        := pr11 (pr2 Hp q φ ψ α β r).

      Definition comma_ump_cell_pr1
        : comma_ump_cell ▹ comma_cone_pr1 p = α
        := pr121 (pr2 Hp q φ ψ α β r).

      Definition comma_ump_cell_pr2
        : comma_ump_cell ▹ comma_cone_pr2 p = β
        := pr221 (pr2 Hp q φ ψ α β r).

      Definition comma_ump_eq
                 (τ₁ τ₂ : φ ==> ψ)
                 (τ₁_pr1 : τ₁ ▹ comma_cone_pr1 p = α)
                 (τ₁_pr2 : τ₁ ▹ comma_cone_pr2 p = β)
                 (τ₂_pr1 : τ₂ ▹ comma_cone_pr1 p = α)
                 (τ₂_pr2 : τ₂ ▹ comma_cone_pr2 p = β)
        : τ₁ = τ₂
        := maponpaths
             pr1
             (proofirrelevance
                _
                (isapropifcontr (pr2 Hp q φ ψ α β r))
                (τ₁ ,, τ₁_pr1 ,, τ₁_pr2)
                (τ₂ ,, τ₂_pr1 ,, τ₂_pr2)).
      End CellProperty.
  End Projections.

  Section InvertibleCommaUmpCell.
    Context {p : comma_cone}
            (Hp : has_comma_ump p)
            {q : B}
            {φ ψ : q --> p}
            {α : φ · comma_cone_pr1 p ==> ψ · comma_cone_pr1 p}
            {β : φ · comma_cone_pr2 p ==> ψ · comma_cone_pr2 p}
            (r : (φ ◃ comma_cone_cell p)
                   • lassociator _ _ _
                   • (β ▹ g)
                   • rassociator _ _ _
                 =
                 lassociator _ _ _
                             • (α ▹ f)
                             • rassociator _ _ _
                             • (ψ ◃ comma_cone_cell p))
            (Hα : is_invertible_2cell α)
            (Hβ : is_invertible_2cell β).

    Definition is_invertible_2cell_comma_ump_cell_inv : ψ ==> φ.
    Proof.
      use (comma_ump_cell Hp _ _ (Hα^-1) (Hβ^-1)).
      abstract
        (do 3 (use vcomp_move_R_Mp ; [ is_iso | ]) ;
         rewrite !vassocl ;
         do 3 (use vcomp_move_L_pM ; [ is_iso | ]) ;
         cbn ;
         rewrite !vassocr ;
         exact (!r)).
    Defined.

    Lemma is_invertible_2cell_comma_ump_cell_left
      : comma_ump_cell Hp φ ψ α β r • is_invertible_2cell_comma_ump_cell_inv
        =
        id₂ φ.
    Proof.
      use (comma_ump_eq Hp).
      - apply id2.
      - apply id2.
      - rewrite !id2_rwhisker, !id2_right.
        rewrite lassociator_rassociator, id2_left.
        rewrite vassocl.
        rewrite lassociator_rassociator.
        apply id2_right.
      - unfold is_invertible_2cell_comma_ump_cell_inv.
        rewrite <- rwhisker_vcomp.
        rewrite !comma_ump_cell_pr1.
        apply vcomp_rinv.
      - unfold is_invertible_2cell_comma_ump_cell_inv.
        rewrite <- rwhisker_vcomp.
        rewrite !comma_ump_cell_pr2.
        apply vcomp_rinv.
      - apply id2_rwhisker.
      - apply id2_rwhisker.
    Qed.

    Lemma is_invertible_2cell_comma_ump_cell_right
      : is_invertible_2cell_comma_ump_cell_inv • comma_ump_cell Hp φ ψ α β r
        =
        id₂ _.
    Proof.
      use (comma_ump_eq Hp).
      - apply id2.
      - apply id2.
      - rewrite !id2_rwhisker, !id2_right.
        rewrite lassociator_rassociator, id2_left.
        rewrite vassocl.
        rewrite lassociator_rassociator.
        apply id2_right.
      - unfold is_invertible_2cell_comma_ump_cell_inv.
        rewrite <- rwhisker_vcomp.
        rewrite !comma_ump_cell_pr1.
        apply vcomp_linv.
      - unfold is_invertible_2cell_comma_ump_cell_inv.
        rewrite <- rwhisker_vcomp.
        rewrite !comma_ump_cell_pr2.
        apply vcomp_linv.
      - apply id2_rwhisker.
      - apply id2_rwhisker.
    Qed.

    Definition is_invertible_2cell_comma_ump_cell
      : is_invertible_2cell (comma_ump_cell Hp φ ψ α β r).
    Proof.
      use make_is_invertible_2cell.
      - exact is_invertible_2cell_comma_ump_cell_inv.
      - exact is_invertible_2cell_comma_ump_cell_left.
      - exact is_invertible_2cell_comma_ump_cell_right.
    Defined.
  End InvertibleCommaUmpCell.

  (**
   4. Being a pullback is a property (requires local univalence)
   *)
  Definition isaprop_has_comma_ump
             (HB_2_1 : is_univalent_2_1 B)
             (p : comma_cone)
    : isaprop (has_comma_ump p).
  Proof.
    use invproofirrelevance.
    intros χ₁ χ₂.
    use subtypePath.
    {
      intro.
      do 6 (use impred ; intro).
      apply isapropiscontr.
    }
    use funextsec ; intro q.
    use eq_comma_1cell ; cbn.
    - use (isotoid_2_1 HB_2_1).
      use make_invertible_2cell.
      + use (comma_ump_cell χ₁).
        * exact (comma_ump_mor_pr1 χ₁ q • (comma_ump_mor_pr1 χ₂ q)^-1).
        * exact (comma_ump_mor_pr2 χ₁ q • (comma_ump_mor_pr2 χ₂ q)^-1).
        * abstract
            (refine (!_) ;
             refine (maponpaths (λ z, _ • z) (comma_ump_mor_cell χ₂ q) @ _) ;
             rewrite !vassocl ;
             refine (!_) ;
             refine (maponpaths (λ z, z • _) (comma_ump_mor_cell χ₁ q) @ _) ;
             rewrite <- !rwhisker_vcomp ;
             rewrite !vassocl ;
             do 2 apply maponpaths ;
             rewrite !vassocr ;
             do 2 apply maponpaths_2 ;
             rewrite !vassocl ;
             rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ;
             rewrite rassociator_lassociator ;
             rewrite id2_left ;
             rewrite rwhisker_vcomp ;
             rewrite vcomp_linv ;
             rewrite id2_rwhisker ;
             rewrite id2_right ;
             rewrite !vassocl ;
             rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
             rewrite rassociator_lassociator ;
             rewrite id2_left ;
             rewrite !vassocr ;
             rewrite rwhisker_vcomp ;
             rewrite vcomp_linv ;
             rewrite id2_rwhisker ;
             rewrite id2_left ;
             apply idpath).
      + use make_is_invertible_2cell.
        * use (comma_ump_cell χ₁).
          ** exact (comma_ump_mor_pr1 χ₂ q • (comma_ump_mor_pr1 χ₁ q)^-1).
          ** exact (comma_ump_mor_pr2 χ₂ q • (comma_ump_mor_pr2 χ₁ q)^-1).
          ** abstract
               (refine (!_) ;
                refine (maponpaths (λ z, _ • z) (comma_ump_mor_cell χ₁ q) @ _) ;
                rewrite !vassocl ;
                refine (!_) ;
                refine (maponpaths (λ z, z • _) (comma_ump_mor_cell χ₂ q) @ _) ;
                rewrite <- !rwhisker_vcomp ;
                rewrite !vassocl ;
                do 2 apply maponpaths ;
                rewrite !vassocr ;
                do 2 apply maponpaths_2 ;
                rewrite !vassocl ;
                rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ;
                rewrite rassociator_lassociator ;
                rewrite id2_left ;
                rewrite rwhisker_vcomp ;
                rewrite vcomp_linv ;
                rewrite id2_rwhisker ;
                rewrite id2_right ;
                rewrite !vassocl ;
                rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
                rewrite rassociator_lassociator ;
                rewrite id2_left ;
                rewrite !vassocr ;
                rewrite rwhisker_vcomp ;
                rewrite vcomp_linv ;
                rewrite id2_rwhisker ;
                rewrite id2_left ;
                apply idpath).
        * use (comma_ump_eq χ₁ _ _ (id₂ _) (id₂ _)).
          ** abstract
               (rewrite !id2_rwhisker ;
                rewrite !id2_right ;
                rewrite lassociator_rassociator ;
                rewrite !vassocl ;
                rewrite lassociator_rassociator ;
                rewrite id2_left, id2_right ;
                apply idpath).
          ** abstract
               (rewrite <- rwhisker_vcomp ;
                rewrite !comma_ump_cell_pr1 ;
                rewrite !vassocl ;
                rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
                rewrite vcomp_linv ;
                rewrite id2_left ;
                rewrite vcomp_rinv ;
                apply idpath).
          ** abstract
               (rewrite <- rwhisker_vcomp ;
                rewrite !comma_ump_cell_pr2 ;
                rewrite !vassocl ;
                rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
                rewrite vcomp_linv ;
                rewrite id2_left ;
                rewrite vcomp_rinv ;
                apply idpath).
          ** apply id2_rwhisker.
          ** apply id2_rwhisker.
        * use (comma_ump_eq χ₁ _ _ (id₂ _) (id₂ _)).
          ** abstract
               (rewrite !id2_rwhisker ;
                rewrite !id2_right ;
                rewrite lassociator_rassociator ;
                rewrite !vassocl ;
                rewrite lassociator_rassociator ;
                rewrite id2_left, id2_right ;
                apply idpath).
          ** abstract
               (rewrite <- rwhisker_vcomp ;
                rewrite !comma_ump_cell_pr1 ;
                rewrite !vassocl ;
                rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
                rewrite vcomp_linv ;
                rewrite id2_left ;
                rewrite vcomp_rinv ;
                apply idpath).
          ** abstract
               (rewrite <- rwhisker_vcomp ;
                rewrite !comma_ump_cell_pr2 ;
                rewrite !vassocl ;
                rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
                rewrite vcomp_linv ;
                rewrite id2_left ;
                rewrite vcomp_rinv ;
                apply idpath).
          ** apply id2_rwhisker.
          ** apply id2_rwhisker.
    - abstract
        (rewrite idtoiso_2_1_isotoid_2_1 ; cbn ;
         refine (!_) ;
         rewrite comma_ump_cell_pr1 ;
         rewrite !vassocl ;
         rewrite vcomp_linv ;
         apply id2_right).
    - abstract
        (rewrite idtoiso_2_1_isotoid_2_1 ; cbn ;
         refine (!_) ;
         rewrite comma_ump_cell_pr2 ;
         rewrite !vassocl ;
         rewrite vcomp_linv ;
         apply id2_right).
    Qed.
End CommaObject.

Arguments comma_cone {_ _ _ _} _ _.

(**
 5. Bicategories with comma objects
 *)
Definition has_comma
           (B : bicat)
  : UU
  := ∏ (b₁ b₂ b₃ : B)
       (f : b₁ --> b₃)
       (g : b₂ --> b₃),
     ∑ (p : comma_cone f g),
     has_comma_ump p.

Definition bicat_with_comma
  : UU
  := ∑ (B : bicat), has_comma B.

Coercion bicat_with_comma_to_bicat
         (B : bicat_with_comma)
  : bicat
  := pr1 B.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require Export pythagoras_difference_lemmas.

Lemma on_perp_d_ex : forall U V r,
 U<>V -> r<> 0 ->
 exists Y, on_perp_d Y U V r.
Proof.
intros.
assert (exists M: Point, ~ Col U V M).
apply build_point_not_collinear_1;auto.

elim H1;intros M HM; clear H1.
elim (proj_ex M U V);[intros N Hn|auto].

cases_equality U N.
subst.
unfold on_foot in *.
use Hn.
clear H3 H4.
assert (N<> M)
 by (intro;subst;auto with Geom).

elim (on_line_dex N M (r * Py N V N / (2*2*S V M N)) H2).
intros Y HY.
exists Y.
unfold on_perp_d.
repeat split;auto.
use HY.
apply (perp_para_perp N M N V Y N);auto with Geom.
use HY.
assert (~ Col V N M) by auto with Geom.
assert (Col N Y M) by auto with Geom.
IsoleVar r H4.
rewrite (A6 N Y M V H2 H5 H6) in H4.
rewrite H4.
uniformize_signed_areas.
field.
split;auto with Geom.
cut (S V M N <> 0).
auto with field_hints.
intro.
rewrite H10 in H8.
basic_simpl.
intuition.
auto with Geom.
repeat apply nonzeromult;auto with Geom.
auto with Geom.

assert (U<>M) by (intro;subst;intuition).

assert (~ Col U M N).
unfold on_foot in *.
use Hn.
assert (N<>M).
intro;subst;intuition.
assert (T:=perp_not_parallel N M U V H3 H4 H6).
intro.
assert (Col N M V).
apply (col_trans_1 N U M V); auto with Geom.
unfold parallel, S4 in T.
rewrite H8 in T.
assert (Col N U M) by auto with Geom.
rewrite H9 in T.
basic_simpl;intuition.

assert (M<>N) by (intro; subst;intuition).

elim (on_parallel_d_ex M N U (-(1)) H4).
2:auto with Geom.
intros B HB.

assert (U<>B).
intro;subst.
unfold on_parallel_d in *.
use HB.
basic_simpl.
assert (M=N).
auto with Geom.
intuition.

elim (on_line_dex U B (r*Py U V U / (2*2*S U V B)) H5).
intros Y HY.
use HY.

exists Y.
unfold on_perp_d.
repeat split; auto.

unfold on_parallel_d in HB.
use HB.
unfold on_foot in *.
use Hn.

assert (perp B U U V).
apply (perp_para_perp M N U V B U H8);auto with Geom.

apply (perp_para_perp U B U V Y U H5); auto with Geom.

assert (~ Col U V B).
intro.
unfold on_parallel_d in HB.
use HB.
unfold on_foot in *.
use Hn.

assert (Col U Y V)
by (apply (col_trans_1 U B Y V);auto with Geom).

assert (Col U Y N)
by (apply (col_trans_1 U V Y N);auto with Geom).

unfold parallel, S4 in H11.
assert (Col U B N).
apply (col_trans_1 U V B N);auto with Geom.
assert (Col B U N) by auto with Geom.
rewrite H18 in H11.
basic_simpl.
assert (Col B M U) by auto with Geom.
assert (Col U M N).
apply (col_trans_1 U B M N);auto with Geom.
intuition.

IsoleVar (r * Py U V U) H7.
rewrite H7.
rewrite (A6 U Y B V H5).
uniformize_signed_areas.
field.
cut (S U V B <> 0).
auto with field_hints.
intuition.
auto with Geom.
auto with Geom.
repeat apply nonzeromult; auto with Geom.
auto with Geom.
Qed.


Set Implicit Arguments.

Require Import Coq.Structures.OrderedType.

Module GLabel_as_MOT <: MiniOrderedType.

  Require Import Platform.Cito.GLabel.

  Definition t := glabel.

  Definition eq := @eq t.

  Require Import Bedrock.LabelMap.

  Definition to_bl (lbl : t) : Labels.label := (fst lbl, Labels.Global (snd lbl)).

  Definition lt (x y : t) := LabelKey.lt (to_bl x) (to_bl y).

  Lemma eq_refl : forall x : t, eq x x.
    unfold eq; eauto.
  Qed.

  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
    unfold eq; eauto.
  Qed.

  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    unfold eq; intuition.
    congruence.
  Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
    unfold lt; intros.
    eapply LabelKey.lt_trans; eauto.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
    unfold lt; unfold eq; intuition.
    subst.
    eapply LabelKey.lt_not_eq in H.
    contradict H.
    unfold LabelKey.eq.
    eauto.
  Qed.

  Definition compare : forall x y : t, Compare lt eq x y.
    unfold lt; unfold eq.
    intros.
    destruct (LabelKey.compare (to_bl x) (to_bl y)).
    econstructor 1; eauto.
    econstructor 2; eauto.
    unfold LabelKey.eq in *.
    unfold to_bl in *.
    destruct x; destruct y; simpl in *.
    injection e; intros; subst.
    eauto.
    econstructor 3; eauto.
  Defined.

End GLabel_as_MOT.

Module GLabel_as_OT := MOT_to_OT GLabel_as_MOT.
Require Import Coq.Structures.OrdersAlt.
Module GLabel_as_OT_new := Update_OT GLabel_as_OT.
Require Import Coq.Structures.Equalities.
Module GLabel_as_UDT := Make_UDT GLabel_as_OT.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Reproduce the results of a paper
  author    : ZhengPu Shi
  date      : 2022.06

  remark    :
  1. 这是对论文 "Formal verification of Matrix based MATLAB models using
    interactive theorem proving" 结果的重现，同时也验证这个矩阵库的适应能力。
*)

Require Import FieldStruct.
Require Import Function.MatrixThy.

Require Import ListListExt.
Require Import Lia.

Require Import Setoid.  (* ==> *)

(* ######################################################################### *)
(** * Instantiate matrix theory *)
Module MatrixThy := MatrixThy FieldR.
Export MatrixThy.

Open Scope R.

(* 打印矩阵元素 *)
Definition mprint {M N} (m : mat M N) :=
  let g := mdata m in
    let rows := map (fun i => g i) (seq 0 M) in
      let elems := map (fun row => map (fun j => row j) (seq 0 N)) rows in
        elems.

Definition m1 : mat 2 3 := mk_mat _ _ (fun i j => INR (i+j)).
Compute mprint m1.

(* ######################################################################### *)
(** * Multivariate Theory in HOL LIGHT *)

(* Def1，矩阵乘法 *)
Definition matrix_mul {M N P} (A : mat M N) (B : mat N P) := mmul A B.

(* Def2, 矩阵转置 *)
Definition transp {M N} (A : mat M N) := mtrans A.

(* Def3, 取出矩阵的一行或一列 *)
Definition row {M N} (A : mat M N) (i : nat) :=
  let g := mdata A in
(*     mk_mat M 1 (fun _ j => g i j)   (* 定义为矩阵 *). *)
    (fun j => g i j)    (* 定义为函数 *).

Definition column {M N} (A : mat M N) (j : nat) :=
  let g := mdata A in
(*     mk_mat 1 N (fun i _ => g i j)   (* 定义为矩阵 *). *)
    (fun i => g i j)    (* 定义为函数 *).

(* Def4, 对角矩阵 *)
Definition dmat {M N} (k : R) :=
  mk_mat M N (fun i j => if i =? j then k else R0).

(* Def5, 向量，无限长的一个常数序列 *)
Definition vec (n : nat) := fun (i : nat) => INR n.

(* Def6, 行向量、列向量，由一个生成函数 v 来构造 *)
Definition rowvector {N} (v : nat -> R) : mat N 1 :=
  mk_mat N 1 (fun i j => if j =? 0 then v i else R0).

Definition columnvector {N} (v : nat -> R) : mat 1 N :=
  mk_mat 1 N (fun i j => if i =? 0 then v j else R0).

(* Def7, 向量化，将 MxN矩阵转换为一个 M*N维的向量。
  以 M=2,N=3 为例
  i   1+(i-1)/N   1+(i-1)%N
  0   1           1
  1   1           1
  2   1           2
  3   1           3
  4   2           1
  5   2           2
  6   2           3
  7   3           1
  看起来，这里的下标是从1开始的，为何不从0开始呢？
*)
Definition vectorize {M N} (A : mat M N) : nat -> R :=
  let g := mdata A in
    fun i => g (Nat.div (i-1) N) (Nat.modulo (i-1) N).

Section test.

  Let m1 : mat 2 3 := l2m [[1;2;3];[4;5;6]]%R.
  Let v1 := vectorize m1.

  (* 取出从0开始的 前10个元素 *)
  Compute map (fun i => v1 i) (seq 0 10).

End test.

(* Def8, 矩阵化，将一个 M*N 维的向量转换为一个 MxN 矩阵。
其实，Def7和Def8也说明了一个公式： (x^a)^b = x^(a*b) *)

Definition Matrify {M N} (x : nat -> R) : mat M N :=
  mk_mat M N (fun i j => x (i * N + j)%nat).

Section test.

  Let x1 := fun n => INR n.
  Let m1 : mat 2 3 := Matrify x1.

  (* 取出元素 *)
  Let f := mdata m1.
  Compute
    let lst := map (fun i => f i) (seq 0 2) in
      map (fun l => map (fun j => l j) (seq 0 3)) lst.

End test.

(* ######################################################################### *)
(** * Formalization of matrix functions in HOL LIGHT *)

(* 上下翻转 *)
Definition flipud {M N} (m : mat M N) : mat M N :=
  let g := mdata m in
    mk_mat _ _ (fun i j => g (M - i - 1)%nat j).

(* 旋转90度（逆时针）
 1 2 3 =>  3 6
 4 5 6     2 5
           1 4
 拆分为基本操作如下
 (1) 转置为
 1 4
 2 5
 3 6
 (2) 所有行进行一次翻转(rev)，即上下翻转 flip_u_d
*)
Definition rot90 {M N} (A : mat M N) : mat N M :=

(* 翻转多个90度，就是多次作用 *)
Definition rot90_matrix {M N} (A : mat M N) (n : nat) :=

  let g := mdata A in
    fun i => g (Nat.div (i-1) N) (Nat.modulo (i-1) N).

Section test.

  Let m1 : mat 2 3 := l2m [[1;2;3];[4;5;6]]%R.
  Let v1 := vectorize m1.

  (* 取出从0开始的 前10个元素 *)
  Compute map (fun i => v1 i) (seq 0 10).

End test.

Module VectorThy (E : FieldSig) <: VectorThySig.

  (* ======================================================================= *)

  (* ======================================================================= *)
  (** ** Vector type *)

  Declare Scope vec_scope.
  Delimit Scope vec_scope with V.
  Open Scope vec_scope.

  Definition vec n := mat n 1.

  (** Get generate function of the vector *)
  Definition vdata {n} (v : vec n) : nat -> A :=
    let g := mdata v in
      fun i => g i 0.

  (* ======================================================================= *)
  (** ** Vector equility *)
  Definition veq {n} (v1 v2 : vec n) := meq v1 v2.

  Notation "v1 == v2 " := (@veq _ v1 v2) (at level 70).

  Lemma veq_refl : forall {n} (v : vec n), v == v.
  Proof. intros. apply meq_refl. Qed.

  Lemma veq_sym : forall {n} (v1 v2 : vec n), v1 == v2 -> v2 == v1.
  Proof. intros. apply meq_sym. easy. Qed.

  Lemma veq_trans : forall {n} (v1 v2 v3 : vec n),
    v1 == v2 -> v2 == v3 -> v1 == v3.
  Proof. intros. apply meq_trans with (m2:=v2); auto. Qed.

  Lemma veq_dec : forall {n} (v1 v2 : vec n), {v1 == v2} + {not (v1 == v2)}.
  Proof. intros. apply meq_dec. Qed.

  (* ======================================================================= *)
  (** ** Convert between tuples and vector *)
  Definition t2v_2 (t : @T2 A) : vec 2 :=
    let '(a,b) := t in l2m [[a];[b]].

  Definition t2v_3 (t : @T3 A) : vec 3 :=
    let '(a,b,c) := t in l2m [[a];[b];[c]].

  Definition t2v_4 (t : @T4 A) : vec 4 :=
    let '(a,b,c,d) := t in l2m [[a];[b];[c];[d]].

  Definition v2t_2 (v : vec 2) : @T2 A :=
    let g := vdata v in (g 0, g 1).

  Definition v2t_3 (v : vec 3) : @T3 A :=
    let g := vdata v in (g 0, g 1, g 2).

  Definition v2t_4 (v : vec 4) : @T4 A :=
    let g := vdata v in (g 0, g 1, g 2, g 3).

  Lemma v2t_t2v_id_2 : forall (t : A * A), v2t_2 (t2v_2 t) = t.
  Proof.
    intros. destruct t. simpl. unfold v2t_2. simpl. f_equal.
  Qed.

  Lemma t2v_v2t_id_2 : forall (v : vec 2), t2v_2 (v2t_2 v) == v.
  Proof.
    intros. intros i j Hi Hj. simpl.
    repeat (try destruct i; try destruct j; auto; try lia).
  Qed.

  (* ======================================================================= *)
  (** ** Convert between list and vector *)
  Definition v2l {n} (v : vec n) : list A := MCol 0 v.
  Definition l2v (l : list A) : vec (length l) := l2m (cvt_row2col l).

  (* ======================================================================= *)
  (** ** Zero vector *)
  Definition vec0 n : vec n := mat0 n 1.

  (** Assert that a vector is an zero vector. *)
  Definition vzero {n} (v : vec n) : Prop := @meq n 1 v (vec0 n).

  (** Assert that a vector is an non-zero vector. *)
  Definition vnonzero {n} (v : vec n) : Prop := ~(vzero v).

  (** vec0 is equal to mat0 with column 1 *)
  Lemma vec0_eq_mat0 : forall n, vec0 n == mat0 n 1.
  Proof. intros. easy. Qed.

  (** It is decidable that if a vector is zero vector. *)
  Lemma vzero_dec : forall {n} (v : vec n), {vzero v} + {vnonzero v}.
  Proof. intros. apply meq_dec. Qed.

  (* ======================================================================= *)
  (** ** algebra operations *)

  (** 一个向量的映射 *)
  Definition vmap {n} (v : vec n) f : vec n := mmap f v.

  (** 一个向量的fold操作 *)
(*   Definition vfold : forall {B : Type} {n} (v : vec n) (f : A -> B) (b : B), B. *)

  (** 两个向量的映射 *)
  Definition vmap2 {n} (v1 v2 : vec n) f : vec n := mmap2 f v1 v2.

  (* 两个向量的点积。这里用矩阵乘法来定义点积，而我们之前是用点积来定义乘法 *)
  Definition vdot {n : nat} (A : vec n) (B : vec n) :=
    scalar_of_mat (@mmul 1 n 1 (mtrans A) B).

  (** 向量加法 *)
  Definition vadd {n} (v1 v2 : vec n) : vec n := madd v1 v2.
  Infix "+" := vadd.

  (** 向量加法交换律 *)
  Lemma vadd_comm : forall {n} (v1 v2 : vec n), @meq n 1 (v1 + v2) (v2 + v1).
  Proof. intros. apply madd_comm. Qed.

  (** 向量加法结合律 *)
  Lemma vadd_assoc : forall {n} (v1 v2 v3 : vec n),
    @meq n 1 ((v1 + v2) + v3) (v1 + (v2 + v3)).
  Proof. intros. apply madd_assoc. Qed.

  (** 向量左加0 *)
  Lemma vadd_zero_l : forall {n} (v : vec n), @meq n 1 ((vec0 n) + v) v.
  Proof. intros. apply (@madd_0_l n 1). Qed.

  (** 向量右加0 *)
  Lemma vadd_zero_r : forall {n} (v : vec n), @meq n 1 (v + (vec0 n)) v.
  Proof. intros. apply (@madd_0_r n 1). Qed.

  (** 负向量 *)
  Definition vopp {n} (v : vec n) : vec n := mopp v.
  Notation "- v" := (vopp v).

  (** 加上负向量等于0 *)
  Lemma vadd_vopp : forall {n} (v : vec n), @meq n 1 (v + (- v)) (vec0 n).
  Proof. intros. apply (@madd_mopp n 1). Qed.

  (** 向量减法 *)
  Definition vsub {n} (v1 v2 : vec n) : vec n := v1 + (- v2).
  Infix "-" := vsub.

  (** 取元素 *)
  Definition vnth {n} (v : vec n) i : A := @mnth n 1 v i 0.

  Notation "v # i" := (vnth v i) (at level 30).

  (** 取出1x1矩阵的第 0,0 个元素 *)
  Definition scalar_of_mat (m : mat 1 1) := mnth m 0 0.

  (** 向量数乘 *)
  Definition vcmul {n} a (v : vec n) : vec n := a c* v.
  Definition vmulc {n} (v : vec n) a : vec n := v *c a.

  (** veq与vcmul的相容性 *)
  Add Parametric Morphism n : (@vcmul n)
    with signature eq ==> veq ==> veq as vcmul_mor.
  Proof.
    intros a [g1] [g2] H. unfold veq, meq in *; simpl in *. intros.
    assert (g1 i j = g2 i j); auto. rewrite H2. auto.
  Qed.

  (** 右数乘和左数乘等价 *)
  Lemma vmulc_eq_vcmul : forall {n} a (v : vec n), @meq n 1 (v *c a) (a c* v).
  Proof. intros. rewrite mmulc_eq_mcmul. easy. Qed.

  (** 数乘结合律1 *)
  Lemma vcmul_assoc1 : forall {n} a b (v : vec n),
    a c* (b c* v) == (a * b) c* v.
  Proof. intros. rewrite mcmul_assoc1. easy. Qed.

  (** 数乘结合律2 *)
  Lemma vcmul_assoc2 : forall {n} a b (v : vec n),
    a c* (b c* v) == b c* (a c* v).
  Proof. intros. rewrite mcmul_assoc2. easy. Qed.

  (** 数乘左分配律 *)
  Lemma vcmul_vadd_distr_l : forall {n} a b (v : vec n),
    (a + b)%A c* v == (a c* v) + (b c* v).
  Proof. intros. rewrite mcmul_madd_distr_r. easy. Qed.

  (** 数乘右分配律 *)
  Lemma vcmul_vadd_distr_r : forall {n} a (v1 v2 : vec n),
    a c* (v1 + v2) == (a c* v1) + (a c* v2).
  Proof. intros. unfold veq,vadd. rewrite mcmul_madd_distr_l. easy. Qed.

  (** 用1数乘 *)
  Lemma vcmul_1_l : forall {n} (v : vec n), @meq n 1 (A1 c* v) v.
  Proof. intros. rewrite mcmul_1_l. easy. Qed.

  (** 用0数乘 *)
  Lemma vcmul_0_l : forall {n} (v : vec n), @meq n 1 (A0 c* v) (vec0 n).
  Proof. intros. rewrite mcmul_0_l. easy. Qed.

  (** 非零向量是k倍关系，则系数k不为0 *)
  Lemma vec_eq_vcmul_imply_coef_neq0 : forall {n} (v1 v2 : vec n) k,
    vnonzero v1 -> vnonzero v2 -> (@meq n 1 v1 (k c* v2)) -> k <> A0.
  Proof.
    intros. intro. subst. rewrite vcmul_0_l in H1. easy.
  Qed.

  (* ======================================================================= *)
  (** ** 2-dim vector operations *)

  (** 2维向量的“长度”，这里不是欧式距离，而是欧式距离的平方，为了方便计算 *)
  Definition vlen2 (v : vec 2) : A :=
    let '(x,y) := v2t_2 v in
      (x * x + y * y)%A.

  (* ======================================================================= *)
  (** ** 3-dim vector operations *)

  (** 3维向量的“长度”，这里不是欧式距离，而是欧式距离的平方，为了方便计算 *)
  Definition vlen3 (v : vec 3) : A :=
    let '(x,y,z) := v2t_3 v in
      (x * x + y * y + z * z)%A.

  (** V3的点积 *)
  Definition vdot3 (v0 v1 : vec 3) : A :=
    let '(a0,b0,c0) := v2t_3 v0 in
    let '(a1,b1,c1) := v2t_3 v1 in
      (a0 * a1 + b0 * b1 + c0 * c1)%A.

End VectorThy.

(* ######################################################################### *)
(** * Vector on R *)
Module VectorR := VectorThy (FieldR).

(* ######################################################################### *)
(** * Test of VectorR *)
Module VectorR_test.

  Import VectorR.
  Open Scope R.
  Open Scope mat_scope.

  Definition v1 : vec 3 := l2v [1;2;3].
  Definition v2 : vec 3 := l2v [4;5;6].
  Example vdot_ex1 : vdot v1 v2 = (4+10+18)%R.
  Proof. compute. ring. Qed.

End VectorR_test.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e226m5_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.