Require Import Containers.Maps Containers.Sets Containers.SetProperties.

Generalizable All Variables.
Set Implicit Arguments.
Unset Strict Implicit.

Section AnyOrderedType.
  Context `{term_OT : OrderedType term}.

  SubClass t := Map[term, set term].

  Definition empty : t := [].

  Definition neqs (d : t) (a : term) : set term :=
    match d[a] with
      | Some s => s
      | None => {}
    end.

  Definition separate (d : t) (a b : term) : t :=
    insert a {b} (add b) (insert b {a} (add a) d).

  Definition are_diff (d : t) (a b : term) : bool :=
    a \in neqs d b.
  Global Coercion are_diff : t >-> Funclass.

  (** The properties that the Diff data structure must verify
     are rather easy ; it still helps in CC if the structure
     verifies a symmetry invariant. *)
  Section WithSpecs.

    Class Wf (d : t) := {
      is_wf : forall a b, d a b = d b a
    }.

    (* About [neqs] *)
    Property neqs_iff :
      forall d a b, a \In neqs d b <-> d a b = true.
    Proof.
      intros d a b; apply mem_iff.
    Qed.
    Property neqs_not_iff :
      forall d a b, (~ a \In neqs d b) <-> d a b = false.
    Proof.
      intros d a b; apply not_mem_iff.
    Qed.

    Instance neqs_m : Proper
      (@Logic.eq _ ==> _eq ==> @Logic.eq _) neqs.
    Proof.
      repeat intro; unfold neqs; subst.
      case_eq (y[x0]); intros.
      rewrite H0 in H; rewrite H; reflexivity.
      rewrite H0 in H; rewrite H; reflexivity.
    Qed.
    Instance are_diff_m : Proper
      (@Logic.eq _ ==> _eq ==> _eq ==> @Logic.eq bool) are_diff.
    Proof.
      repeat intro; subst.
      case_eq (y x0 x1); intros; symmetry.
      rewrite <- neqs_iff in *.
      rewrite <- H0, <- H1; exact H.
      rewrite <- neqs_not_iff in *.
      rewrite <- H0, <- H1; exact H.
    Qed.

    Remark neqs_sym : forall `{Wf d} a b, a \In neqs d b <-> b \In neqs d a.
    Proof.
      intros; rewrite 2neqs_iff; rewrite is_wf; reflexivity.
    Qed.

    (* About [empty] *)
    Property are_diff_empty : forall a b, empty a b = false.
    Proof.
      intros; reflexivity.
    Qed.
    Corollary neqs_empty : forall a, neqs empty a [=] {}.
    Proof.
      intros; intro b; rewrite neqs_iff, are_diff_empty.
      split; intro H; [discriminate H | contradiction (empty_1 H)].
    Qed.

    Instance Wf_empty : Wf empty.
    Proof. constructor.
      intros; rewrite 2are_diff_empty; reflexivity.
    Qed.

    (* About [separate] *)
    Property insert_eq_o :
      forall (m : t) k d f k', k === k' -> (insert k d f m)[k'] =
        match m[k'] with Some r => Some (f r) | None => Some d end.
    Proof.
      intros.
      destruct m[k'] as [sk'|]_eqn:Hk'.
      apply find_1; apply insert_1; auto using find_2.
      apply find_1; apply insert_2; auto using find_2.
      rewrite MapFacts.not_find_in_iff; assumption.
    Qed.
    Property insert_neq_o :
      forall (m : t) k d f k', k =/= k' -> (insert k d f m)[k'] = m[k'].
    Proof.
      intros.
      destruct m[k'] as [sk'|]_eqn:Hk'.
      apply find_1; apply insert_3; auto using find_2.
      destruct (insert k d f m)[k'] as [sik'|]_eqn; auto.
      assert (Hz := insert_4 H (find_2 Heqo)).
      rewrite (find_1 Hz) in Hk'; discriminate.
    Qed.

    Property neqs_separate_1 : forall d a b,
      neqs (separate d a b) a [=] {b; neqs d a}.
    Proof.
      intros; unfold neqs, separate.
      destruct (eq_dec a b).
      rewrite !insert_eq_o by auto.
      destruct d[a]; rewrite H.
      apply add_equal; apply add_1; reflexivity.
      rewrite singleton_equal_add; apply add_equal; apply add_1; reflexivity.
      rewrite insert_eq_o by auto.
      rewrite insert_neq_o by (symmetry; auto).
      destruct d[a]; try reflexivity.
      apply singleton_equal_add.
    Qed.
    Property neqs_separate_2 : forall d a b,
      neqs (separate d a b) b [=] {a; neqs d b}.
    Proof.
      intros; unfold neqs, separate.
      destruct (eq_dec a b).
      rewrite !insert_eq_o by auto.
      destruct d[b]; rewrite H.
      apply add_equal; apply add_1; reflexivity.
      rewrite singleton_equal_add; apply add_equal; apply add_1; reflexivity.
      rewrite insert_neq_o by (auto).
      rewrite insert_eq_o by auto.
      destruct d[b]; try reflexivity.
      apply singleton_equal_add.
    Qed.
    Property neqs_separate_3 : forall d a b c,
      a =/= c -> b =/= c -> neqs (separate d a b) c [=] neqs d c.
    Proof.
      intros; unfold neqs, separate.
      rewrite 2insert_neq_o by auto.
      reflexivity.
    Qed.

    Corollary are_diff_separate_1 : forall d a b,
      (separate d a b) a b = true.
    Proof.
      intros; unfold are_diff.
      rewrite neqs_separate_2; apply mem_1; apply add_1; auto.
    Qed.
    Corollary are_diff_separate_2 : forall d a b,
      (separate d a b) b a = true.
    Proof.
      intros; unfold are_diff.
      rewrite neqs_separate_1; apply mem_1; apply add_1; auto.
    Qed.
    Property are_diff_separate_3 : forall d a b a' b',
      (a =/= a' /\ b =/= a' \/ a =/= b' /\ b =/= b') ->
      (separate d a b) a' b' = d a' b'.
    Proof.
      intros; unfold are_diff.
      destruct (eq_dec b b').
      rewrite <- H0, neqs_separate_2.
      destruct H as [[E1 E2]|[E1 E2]]; try contradiction.
      rewrite add_b; destruct (eq_dec a a'); try contradiction; reflexivity.
      destruct (eq_dec a b').
      rewrite <- H1, neqs_separate_1.
      destruct H as [[E1 E2]|[E1 E2]]; try contradiction.
      rewrite add_b; destruct (eq_dec b a'); try contradiction; reflexivity.
      rewrite (neqs_separate_3 d H1 H0); reflexivity.
    Qed.

    Corollary separate_conservative :
      forall (d : t) a b x y, d x y = true -> (separate d a b) x y = true.
    Proof.
      intros; rewrite <- neqs_iff in *.
      destruct (eq_dec a y).
      rewrite <- H0, neqs_separate_1, H0; apply add_2; assumption.
      destruct (eq_dec b y).
      rewrite <- H1, neqs_separate_2, H1; apply add_2; assumption.
      rewrite neqs_separate_3; assumption.
    Qed.

    Instance Wf_separate `{Wf d} (a b : term) : Wf (separate d a b).
    Proof.
      intros; constructor; intros.
      destruct (eq_dec a a0); destruct (eq_dec a b0);
        try (rewrite <- H0, <- H1; reflexivity);
          destruct (eq_dec b a0); destruct (eq_dec b b0);
            try (rewrite <- H2, <- H3; reflexivity).
      rewrite (@are_diff_separate_3 d a b a0 b0) by (right; split; assumption).
      rewrite (@are_diff_separate_3 d a b b0 a0) by (left; split; assumption).
      apply is_wf.
      rewrite <- H0, <- H3, are_diff_separate_1, are_diff_separate_2; trivial.
      rewrite (@are_diff_separate_3 d a b a0 b0) by (right; split; assumption).
      rewrite (@are_diff_separate_3 d a b b0 a0) by (left; split; assumption).
      apply is_wf.
      rewrite <- H1, <- H2, are_diff_separate_1, are_diff_separate_2; trivial.
      rewrite (@are_diff_separate_3 d a b a0 b0) by (left; split; assumption).
      rewrite (@are_diff_separate_3 d a b b0 a0) by (right; split; assumption).
      apply is_wf.
      rewrite (@are_diff_separate_3 d a b a0 b0) by (left; split; assumption).
      rewrite (@are_diff_separate_3 d a b b0 a0) by (right; split; assumption).
      apply is_wf.
      rewrite (@are_diff_separate_3 d a b a0 b0) by (right; split; assumption).
      rewrite (@are_diff_separate_3 d a b b0 a0) by (left; split; assumption).
      apply is_wf.
      rewrite (@are_diff_separate_3 d a b a0 b0) by (left; split; assumption).
      rewrite (@are_diff_separate_3 d a b b0 a0) by (right; split; assumption).
      apply is_wf.
      rewrite (@are_diff_separate_3 d a b a0 b0) by (left; split; assumption).
      rewrite (@are_diff_separate_3 d a b b0 a0) by (right; split; assumption).
      apply is_wf.
    Qed.
  End WithSpecs.
End AnyOrderedType.

Global Opaque t empty neqs separate are_diff.


(***************************************************************************
* Preservation and Progress for mini-ML (CBV) - Definitions                *
* Arthur Charguéraud, July 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
  | typ_unit  : typ
  | typ_nat   : typ
  | typ_prod  : typ -> typ -> typ
  | typ_sum   : typ -> typ -> typ
  | typ_ref   : typ -> typ.

(** Computing free variables of a type.
    Needed to say that typ_exn is closed
    and that typing of store is done with ground terms *)

Fixpoint typ_fv (T : typ) {struct T} : vars :=
  match T with
  | typ_bvar i      => {}
  | typ_fvar x      => {{x}}
  | typ_arrow T1 T2 => (typ_fv T1) \u (typ_fv T2)
  | typ_unit        => {}
  | typ_nat         => {}
  | typ_prod T1 T2  => (typ_fv T1) \u (typ_fv T2)
  | typ_sum T1 T2   => (typ_fv T1) \u (typ_fv T2)
  | typ_ref T1      => (typ_fv T1)
  end.

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

Definition typ_def := typ_nat.

(** Exceptions is an abstract typ. typ_unit can be a naive implementation
    of exceptions, but to be able to pattern match on exceptions one may
    rather consider defining exception as a sum of types.
    The exception type must be ground (no free type variable). *)

Parameter typ_exn : typ.
Parameter typ_exn_fresh : typ_fv typ_exn = {}.

(** 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)
  | typ_unit        => typ_unit
  | typ_nat         => typ_nat
  | typ_prod T1 T2  => typ_prod (typ_open T1 Vs) (typ_open T2 Vs)
  | typ_sum T1 T2   => typ_sum (typ_open T1 Vs) (typ_open T2 Vs)
  | typ_ref T1      => typ_ref (typ_open T1 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)
  | type_unit :
      type (typ_unit)
  | type_nat :
      type (typ_nat)
  | type_prod : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_prod T1 T2)
  | type_sum : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_sum T1 T2)
  | type_ref : forall T1,
      type T1 ->
      type (typ_ref T1).

(** 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 *)

(** Definition of locations. *)

Definition loc := var.

(** Grammar of patterns. *)

Inductive pat : Set :=
  | pat_bvar : pat
  | pat_wild : pat
  | pat_unit : pat
  | pat_pair : pat -> pat -> pat
  | pat_inj1 : pat -> pat
  | pat_inj2 : pat -> pat.

(** Grammar of terms. *)

Inductive trm : Set :=
  | trm_bvar  : nat -> nat -> trm
  | trm_fvar  : var -> trm
  | trm_abs   : trm -> trm
  | trm_fix   : trm -> trm
  | trm_let   : trm -> trm -> trm
  | trm_match : trm -> pat -> trm -> trm -> trm
  | trm_app   : trm -> trm -> trm
  | trm_unit  : trm
  | trm_nat   : nat -> trm
  | trm_add  : trm
  | trm_pair  : trm -> trm -> trm
  | trm_inj1  : trm -> trm
  | trm_inj2  : trm -> trm
  | trm_loc   : loc -> trm
  | trm_ref   : trm -> trm
  | trm_get   : trm -> trm
  | trm_set   : trm -> trm -> trm
  | trm_raise : trm -> trm
  | trm_catch : trm -> trm -> trm.

(** Arity of a pattern. *)

Fixpoint pat_arity (p : pat) : nat :=
  match p with
  | pat_bvar       => 1
  | pat_wild       => 0
  | pat_unit       => 0
  | pat_pair p1 p2 => (pat_arity p1) + (pat_arity p2)
  | pat_inj1 p1    => (pat_arity p1)
  | pat_inj2 p1    => (pat_arity p1)
  end.

(** Pattern matching. *)

Fixpoint pat_match (p : pat) (t : trm) {struct p} : option (list trm) :=
  match p, t with
  | pat_bvar      , t1             => Some (t1::nil)
  | pat_wild      , t1             => Some nil
  | pat_unit      , trm_unit       => Some nil
  | pat_pair p1 p2, trm_pair t1 t2 => match (pat_match p1 t1), (pat_match p2 t2) with
                                      | Some r1, Some r2 => Some (r1 ++ r2)
                                      | _      , _       => None end
  | pat_inj1 p1   , trm_inj1 t1    => (pat_match p1 t1)
  | pat_inj2 p1   , trm_inj2 t1    => (pat_match p1 t1)
  | _             , _              => None
  end.

(** Default term and nth function on term lists *)

Definition trm_def := trm_bvar 0 0.

Definition trm_nth n ts := List.nth n ts trm_def.

(** Opening up abstractions *)

Fixpoint opens_rec (k : nat) (us : list trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i j  => if k === i then (trm_nth j us) else (trm_bvar i j)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (opens_rec (S k) us t1)
  | trm_fix t1    => trm_fix (opens_rec (S k) us t1)
  | trm_let t1 t2 => trm_let (opens_rec k us t1) (opens_rec (S k) us t2)
  | trm_match t1 p1 b t2 => trm_match (opens_rec k us t1) p1
                               (opens_rec (S k) us b)
                               (opens_rec (S k) us t2)
  | trm_app t1 t2 => trm_app (opens_rec k us t1) (opens_rec k us t2)
  | trm_unit      => trm_unit
  | trm_nat n     => trm_nat n
  | trm_add       => trm_add
  | trm_pair t1 t2 => trm_pair (opens_rec k us t1) (opens_rec k us t2)
  | trm_inj1 t1   => trm_inj1 (opens_rec k us t1)
  | trm_inj2 t1   => trm_inj2 (opens_rec k us t1)
  | trm_loc l     => trm_loc l
  | trm_ref t1    => trm_ref (opens_rec k us t1)
  | trm_get t1    => trm_get (opens_rec k us t1)
  | trm_set t1 t2 => trm_set (opens_rec k us t1) (opens_rec k us t2)
  | trm_raise t1    => trm_raise (opens_rec k us t1)
  | trm_catch t1 t2 => trm_catch (opens_rec k us t1) (opens_rec k us t2)
  end.

Definition opens t us := opens_rec 0 us t.
Definition open t u := opens t (u::nil).
Definition trm_fvars := List.map trm_fvar.

Notation "{ k ~> u } t" := (opens_rec k u t) (at level 67).
Notation "t ^^ us" := (opens t us) (at level 67).
Notation "t ^ xs" := (opens t (trm_fvars xs)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, fresh L 1 (x::nil) ->
        term (t1 ^ (x::nil))) ->
      term (trm_abs t1)
  | term_fix : forall L t1,
      (forall f x, fresh L 2 (f::x::nil) ->
        term (t1 ^ (f::x::nil))) ->
      term (trm_fix t1)
  | term_let : forall L t1 t2,
      term t1 ->
      (forall x, fresh L 1 (x::nil) ->
        term (t2 ^ (x::nil))) ->
      term (trm_let t1 t2)
  | term_match : forall L t1 p b t2,
      term t1 ->
      (forall xs, fresh L (pat_arity p) xs -> term (b ^ xs)) ->
      term t2 ->
      term (trm_match t1 p b t2)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2)
  | term_unit :
      term (trm_unit)
  | term_nat : forall n,
      term (trm_nat n)
  | term_add :
      term (trm_add)
  | term_pair : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_pair t1 t2)
  | term_inj1 : forall t1,
      term t1 ->
      term (trm_inj1 t1)
  | term_inj2 : forall t1,
      term t1 ->
      term (trm_inj2 t1)
  | term_loc : forall l,
      term (trm_loc l)
  | term_new : forall t1,
      term t1 ->
      term (trm_ref t1)
  | term_get : forall t1,
      term t1 ->
      term (trm_get t1)
  | term_set : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_set t1 t2)
  | term_raise : forall t1,
      term t1 ->
      term (trm_raise t1)
  | term_catch : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_catch t1 t2).

(** Definition of [bodys n t] as [t ^ xs] is a term when [|xs|=n] *)

Definition bodys n t :=
  exists L : vars, forall xs,
  fresh L n xs -> term (t ^ xs).

(* ********************************************************************** *)
(** ** Semantics *)

(** Representation of the store and its well-formedness judgment *)

Definition sto := Env.env trm.

Inductive sto_ok : sto -> Prop :=
  | sto_ok_empty : sto_ok empty
  | sto_ok_push : forall mu l t,
      sto_ok mu -> term t ->
      sto_ok (mu & l ~ t).

(** Grammar of values *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1, term (trm_abs t1) -> value (trm_abs t1)
  | value_fix : forall t1, term (trm_fix t1) -> value (trm_fix t1)
  | value_nat : forall n, value (trm_nat n)
  | value_add : value trm_add
  | value_add_1 : forall n, value (trm_app trm_add (trm_nat n))
  | value_pair : forall v1 v2, value v1 -> value v2 -> value (trm_pair v1 v2)
  | value_inj1 : forall v1, value v1 -> value (trm_inj1 v1)
  | value_inj2 : forall v1, value v1 -> value (trm_inj2 v1)
  | value_unit : value trm_unit
  | value_loc : forall l, value (trm_loc l).

(** Raising of Exceptions *)

Inductive fails : trm -> trm -> Prop :=
  | fails_raise_val : forall t1,
      value t1 ->
      fails (trm_raise t1) t1
  | fails_app_1 : forall t1 t2 e,
      term t2 ->
      fails t1 e ->
      fails (trm_app t1 t2) e
  | fails_app_2 : forall t1 t2 e,
      value t1 ->
      fails t2 e ->
      fails (trm_app t1 t2) e
  | fails_let_1 : forall t1 t2 e,
      bodys 1 t2 ->
      fails t1 e ->
      fails (trm_let t1 t2) e
  | fails_pair_1 : forall t1 t2 e,
      term t2 ->
      fails t1 e ->
      fails (trm_pair t1 t2) e
  | fails_pair_2 : forall t1 t2 e,
      value t1 ->
      fails t2 e ->
      fails (trm_pair t1 t2) e
  | fails_inj_1 : forall t1 e,
      fails t1 e ->
      fails (trm_inj1 t1) e
  | fails_inj_2 : forall t1 e,
      fails t1 e ->
      fails (trm_inj2 t1) e
  | fails_mat_1 : forall t1 p b t2 e,
      bodys (pat_arity p) b ->
      term t2 ->
      fails t1 e ->
      fails (trm_match t1 p b t2) e
  | fails_new_1 : forall t1 e,
      fails t1 e ->
      fails (trm_ref t1) e
  | fails_get_1 : forall t1 e,
      fails t1 e ->
      fails (trm_get t1) e
  | fails_set_1 : forall t1 t2 e,
      fails t1 e ->
      term t2 ->
      fails (trm_set t1 t2) e
  | fails_set_2 : forall t1 t2 e,
      value t1 ->
      fails t2 e ->
      fails (trm_set t1 t2) e
  | fails_raise_1 : forall t1 e,
      fails t1 e ->
      fails (trm_raise t1) e.

(** Reduction rules *)

Definition conf := (trm * sto)%type.

Inductive red : conf -> conf -> Prop :=

  (* -- reduction with substitution -- *)

  | red_beta : forall mu t1 t2,
      sto_ok mu ->
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2, mu) (t1 ^^ (t2::nil), mu)
  | red_fix : forall mu t1 t2,
      sto_ok mu ->
      term (trm_fix t1) ->
      value t2 ->
      red (trm_app (trm_fix t1) t2, mu)
          (t1 ^^ ((trm_fix t1)::t2::nil), mu)
  | red_let : forall mu t1 t2,
      sto_ok mu ->
      term (trm_let t1 t2) ->
      value t1 ->
      red (trm_let t1 t2, mu) (t2 ^^ (t1::nil), mu)
  | red_match_some : forall ts mu t1 p b t2,
      sto_ok mu ->
      value t1 ->
      bodys (pat_arity p) b ->
      term t2 ->
      pat_match p t1 = Some ts ->
      red (trm_match t1 p b t2, mu) (b ^^ ts, mu)
  | red_match_none : forall mu t1 p b t2,
      sto_ok mu ->
      value t1 ->
      bodys (pat_arity p) b ->
      term t2 ->
      pat_match p t1 = None ->
      red (trm_match t1 p b t2, mu) (t2, mu)

  (* -- reduction of primitives -- *)

  | red_add : forall mu n1 n2,
      sto_ok mu ->
      red (trm_app (trm_app trm_add (trm_nat n1)) (trm_nat n2), mu)
          (trm_nat (n1 + n2), mu)
  | red_new : forall mu t1 l,
      sto_ok mu ->
      value t1 ->
      l # mu ->
      red (trm_ref t1, mu) (trm_loc l, (mu & l ~ t1))
  | red_get : forall mu l t,
      sto_ok mu ->
      binds l t mu ->
      red (trm_get (trm_loc l), mu) (t, mu)
  | red_set : forall mu l t2,
      sto_ok mu ->
      value t2 ->
      red (trm_set (trm_loc l) t2, mu) (trm_unit, mu & l ~ t2)
  | red_catch_val : forall mu t1 t2,
      sto_ok mu ->
      term t1 ->
      value t2 ->
      red (trm_catch t1 t2, mu) (t2, mu)
  | red_catch_exn : forall mu t1 t2 e,
      sto_ok mu ->
      term t1 ->
      fails t2 e ->
      red (trm_catch t1 t2, mu) (trm_app t1 e, mu)

  (* -- reduction under context -- *)

  | red_app_1 : forall mu mu' t1 t1' t2,
      term t2 ->
      red (t1, mu) (t1', mu') ->
      red (trm_app t1 t2, mu) (trm_app t1' t2, mu')
  | red_app_2 : forall mu mu' t1 t2 t2',
      value t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_app t1 t2, mu) (trm_app t1 t2', mu')
  | red_match_1 : forall mu mu' t1 t1' p b t2,
      term t2 ->
      bodys (pat_arity p) b ->
      red (t1, mu) (t1', mu') ->
      red (trm_match t1 p b t2, mu) (trm_match t1' p b t2, mu')

  | red_pair_1 : forall mu mu' t1 t1' t2,
      term t2 ->
      red (t1, mu) (t1', mu') ->
      red (trm_pair t1 t2, mu) (trm_pair t1' t2, mu')
  | red_pair_2 : forall mu mu' t1 t2 t2',
      value t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_pair t1 t2, mu) (trm_pair t1 t2', mu')
  | red_inj1_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_inj1 t1, mu) (trm_inj1 t1', mu')
  | red_inj2_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_inj2 t1, mu) (trm_inj2 t1', mu')
  | red_new_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_ref t1, mu) (trm_ref t1', mu')
  | red_get_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_get t1, mu) (trm_get t1', mu')
  | red_set_1 : forall mu mu' t1 t1' t2,
      red (t1, mu) (t1', mu') ->
      term t2 ->
      red (trm_set t1 t2, mu) (trm_set t1' t2, mu')
  | red_set_2 : forall mu mu' t1 t2 t2',
      value t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_set t1 t2, mu) (trm_set t1 t2', mu')

  | red_catch_2 : forall mu mu' t1 t2 t2',
      term t1 ->
      red (t2, mu) (t2', mu') ->
      red (trm_catch t1 t2, mu) (trm_catch t1 t2', mu')
  | red_raise_1 : forall mu mu' t1 t1',
      red (t1, mu) (t1', mu') ->
      red (trm_raise t1, mu) (trm_raise t1', mu').

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

(* ********************************************************************** *)
(** ** Typing *)

(** Typing environments mapping variable to type schemes *)

Definition env := env sch.

(** Typing environments mapping locations to types
    and its well-formedness judgment *)

Definition phi := Env.env typ.

Inductive phi_ok : phi -> Prop :=
  | phi_ok_empty : phi_ok empty
  | phi_ok_push : forall P l T,
      phi_ok P -> type T -> (*  typ_fv T = {} -> *)
      phi_ok (P & l ~T).

(** Typing relation for patterns: if Us are the types of the
    bound variables in the pattern p, then the pattern p matches
    values of type T. *)

Reserved Notation "Us \= p ~: T" (at level 69).

Inductive pat_typing : list typ -> pat -> typ -> Prop :=
  | pat_typing_bvar : forall T,
     (T::nil) \= pat_bvar ~: T
  | pat_typing_wild : forall T,
     nil \= pat_wild ~: T
  | pat_typing_unit :
     nil \= pat_unit ~: typ_unit
  | pat_typing_pair : forall p1 p2 T1 T2 Us1 Us2,
     Us1 \= p1 ~: T1 ->
     Us2 \= p2 ~: T2 ->
     (Us1 ++ Us2) \= (pat_pair p1 p2) ~: (typ_prod T1 T2)
  | pat_typing_inj1 : forall T2 p1 T1 Us1,
     Us1 \= p1 ~: T1 ->
     Us1 \= (pat_inj1 p1) ~: (typ_sum T1 T2)
  | pat_typing_inj2 : forall T2 p1 T1 Us1,
     Us1 \= p1 ~: T2 ->
     Us1 \= (pat_inj2 p1) ~: (typ_sum T1 T2)

where "Ts \= p ~: T" := (pat_typing Ts p T).

(** The typing judgment for terms *)

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

Inductive typing : env -> phi -> trm -> typ -> Prop :=
  | typing_var : forall E P x M Us,
      ok E -> phi_ok P ->
      binds x M E ->
      types (sch_arity M) Us ->
      scheme M ->
      E ! P |= (trm_fvar x) ~: (M ^^ Us)
  | typing_abs : forall L E P U T t1,
      type U ->
      (forall x, fresh L 1 (x::nil) ->
       (E & x ~ Sch 0 U) ! P |= t1 ^ (x::nil) ~: T) ->
      E ! P |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_fix : forall L E P U T t1,
      type U ->
      (forall f x, fresh L 2 (f::x::nil) ->
        (E & f ~ Sch 0 (typ_arrow U T) & x ~ Sch 0 U) ! P |= t1 ^ (f::x::nil) ~: T) ->
      E ! P |= (trm_fix t1) ~: (typ_arrow U T)
  | typing_let : forall M L1 L2 E P T2 t1 t2,
      value t1 ->
      scheme M ->
      (forall Xs, fresh L1 (sch_arity M) Xs ->
         E ! P |= t1 ~: (M ^ Xs)) ->
      (forall x, fresh L2 1 (x::nil) ->
         (E & x ~ M) ! P |= (t2 ^ (x::nil)) ~: T2) ->
      E ! P |= (trm_let t1 t2) ~: T2
  | typing_match : forall T Us L R E P t1 p b t2,
      E ! P |= t1 ~: T ->
      Us \= p ~: T ->
      (forall xs, fresh L (pat_arity p) xs ->
        (E & (iter_push xs (List.map (Sch 0) Us))) ! P |= (b ^ xs) ~: R) ->
      E ! P |= t2 ~: R ->
      E ! P |= (trm_match t1 p b t2) ~: R
  | typing_app : forall E P S T t1 t2,
      E ! P |= t1 ~: (typ_arrow S T) ->
      E ! P |= t2 ~: S ->
      E ! P |= (trm_app t1 t2) ~: T
  | typing_unit : forall E P,
      ok E -> phi_ok P ->
      E ! P |= (trm_unit) ~: (typ_unit)
  | typing_nat : forall E P n,
      ok E -> phi_ok P ->
      E ! P |= (trm_nat n) ~: (typ_nat)
  | typing_add : forall E P,
      ok E -> phi_ok P ->
      E ! P |= trm_add ~: (typ_arrow typ_nat (typ_arrow typ_nat typ_nat))
  | typing_pair : forall E P t1 t2 T1 T2,
      E ! P |= t1 ~: T1 ->
      E ! P |= t2 ~: T2 ->
      E ! P |= (trm_pair t1 t2) ~: (typ_prod T1 T2)
  | typing_inj1 : forall T2 E P t1 T1,
      type T2 ->
      E ! P |= t1 ~: T1 ->
      E ! P |= (trm_inj1 t1) ~: (typ_sum T1 T2)
  | typing_inj2 : forall T1 E P t1 T2,
      type T1 ->
      E ! P |= t1 ~: T2 ->
      E ! P |= (trm_inj2 t1) ~: (typ_sum T1 T2)
  | typing_loc : forall E P l T,
      ok E -> phi_ok P ->
      binds l T P ->
      E ! P |= (trm_loc l) ~: (typ_ref T)
  | typing_ref : forall E P t1 T,
      E ! P |= t1 ~: T ->
      E ! P |= (trm_ref t1) ~: (typ_ref T)
  | typing_get : forall E P t1 T,
      E ! P |= t1 ~: (typ_ref T) ->
      E ! P |= (trm_get t1) ~: T
  | typing_set : forall E P t1 t2 T,
      E ! P |= t1 ~: (typ_ref T) ->
      E ! P |= t2 ~: T ->
      E ! P |= (trm_set t1 t2) ~: typ_unit
  | typing_raise : forall E P t1 T,
      type T ->
      E ! P |= t1 ~: typ_exn ->
      E ! P |= (trm_raise t1) ~: T
  | typing_catch : forall E P t1 t2 T,
      E ! P |= t1 ~: (typ_arrow typ_exn T) ->
      E ! P |= t2 ~: T ->
      E ! P |= (trm_catch t1 t2) ~: T

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

(** Typing store *)

Definition sto_typing P mu :=
     phi_ok P
  /\ sto_ok mu
  /\ (forall l, l # mu -> l # P)
  /\ (forall l T, binds l T P ->
        exists t, binds l t mu
               /\ empty ! P |= t ~: T).

Notation "P |== mu" := (sto_typing P mu) (at level 68).

(* ********************************************************************** *)
(** ** Theorems *)

(** Preservation: if t has type T in the empty context and under
    P typing the store mu, and if t reduces to t' by updating
    the context to mu', then there exists a extended relation P'
    typing the new store mu', such that t' has its typed preserved
    under P'. *)

Definition preservation := forall P t t' mu mu' T,
  empty ! P |= t ~: T ->
  (t,mu) --> (t',mu') ->
  P |== mu ->
  exists P',
     extends P P'
  /\ empty ! P' |= t' ~: T
  /\ P' |== mu'.

(** Progress: If a term t has type T in the empty environment and
    under P typing the store mu, then three cases are possibles:
    (1) t is a value, (2) t raises an exception e, or (3) there
    exists a term t' and a store mu' such that the configuration
    (t,mu) reduces to the configuration (t',mu'). *)

Definition progress := forall P t mu T,
  empty ! P |= t ~: T ->
  P |== mu ->
     value t
  \/ (exists e, fails t e)
  \/ (exists t', exists mu', (t,mu) --> (t',mu')).


Require Import Arith Lia List Bool Eqdep_dec EqdepFacts.
From Undecidability.Shared.Libs.DLW
  Require Import utils_tac utils_nat utils_list finite pos vec.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import Shared.ListAutomation Shared.Dec.
From Undecidability Require Import Shared.Libs.PSL.Vectors.Vectors.
Import ListAutomationNotations.

Require Import Undecidability.MuRec.recalg.

Definition C {n1 n2} (Heq:n1=n2) (alg:recalg n1) := (match Heq in (_ = x) return recalg x with eq_refl => alg end).

Lemma CE n H a : @C n n H a = a.
Proof.
  unshelve eapply (@K_dec_type nat _ n (fun h => C h a = a)). 2:easy.
  decide equality.
Qed.

Section EqDec.

  Definition recalg_inv_type := forall n (h : recalg n),
    {k & { H : 0 = n & h = C H (ra_cst k)}}
  + { H : 1 = n & h = C H (ra_zero)}
  + { H : 1 = n & h = C H (ra_succ)}
  + {k & {v & { H : k = n & h = C H (@ra_proj k v)}}}
  + {k & {i & {rk & {ri & { H : i = n & h = C H (@ra_comp k i rk ri)}}}}}
  + {k & {rk & {rSk & { H : S k = n & h = C H (@ra_rec k rk rSk)}}}}
  + {k & {rSk & { H : k = n & h = C H (@ra_min k rSk)}}}.

  Definition recalg_inv : recalg_inv_type.
  Proof.
    intros n h. induction h as [k| | |k v| k i rk ri IHrk IHri| k rk rSk Hrk HrSk|k rSk HrSk].
    + do 6 left. exists k, eq_refl. easy.
    + do 5 left; right. exists eq_refl. easy.
    + do 4 left; right. exists eq_refl. easy.
    + do 3 left; right. exists k, v, eq_refl. easy.
    + do 2 left; right. exists k, i, rk, ri, eq_refl. easy.
    + do 1 left; right. exists k, rk, rSk, eq_refl. easy.
    + do 0 left; right. exists k, rSk, eq_refl. easy.
  Qed.

  #[local] Ltac iinversion H := destruct (@recalg_inv _ H) as [[[[[[(k' & Heq & HH)|(Heq & HH)]|(Heq & HH)]|(k'&v'&Heq & HH)]|(k'&i'&rk'&ri'&Heq & HH)]|(k'&rk'&rSk'&Heq & HH)]|(k'&rSk'&Heq & HH)]; try discriminate Heq; try rewrite ! CE in *; subst; cbn.

  #[local] Ltac eqdec dec := let Hcc := fresh "Hcc" in let Hdd := fresh "Hdd" in
                        destruct (dec) as [Hcc|Hcc]; [try subst|right; intros Hdd; injection Hdd; try congruence].

  Lemma vec_pos_eq_dec X k (v1 v2: vec X k) :
    (forall (p : pos k) (e : X), {vec_pos v1 p = e} + {vec_pos v1 p <> e})
    -> {v1 = v2} + {v1 <> v2}.
  Proof.
    intros Hdec.
    assert ({forall p : pos k, vec_pos v1 p = vec_pos v2 p} + {~forall p : pos k, vec_pos v1 p = vec_pos v2 p}) as Hdec2.
    - induction k in v1,v2,Hdec|-*.
      + left. intros p. now apply pos_O_invert.
      + destruct (Hdec Fin.F1 (vec_pos v2 Fin.F1)) as [Hl|Hr].
        2: {right. intros H. apply Hr, H. }
        destruct (IHk (vec_tail v1) (vec_tail v2)) as [Hl2|Hr2].
        * intros p e. destruct (Hdec (Fin.FS p) e).
          -- left. rewrite vec_pos_tail. easy.
          -- right. rewrite vec_pos_tail. easy.
        * left. apply pos_S_invert.
          -- easy.
          -- intros p. specialize (Hl2 p). now rewrite <- !vec_pos_tail.
        * right. intros Hcc. apply Hr2. intros p. specialize (Hcc (Fin.FS p)).
          rewrite ! vec_pos_tail. easy.
    - destruct Hdec2 as [Hl|Hr].
      + left. apply vec_pos_ext. easy.
      + right. intros H. apply Hr. congruence.
  Qed.

  Definition recalg_dec n : eq_dec (recalg n).
  Proof.
    intros h1 h2. unfold dec.
    induction h1 in h2|-*; iinversion h2; try (right; discriminate).
    (*ra_cst*)
    + eqdec (Nat.eq_dec n k'). now left.
    (*ra_zero*)
    + now left.
    + assert (k' = 0) as -> by lia. rewrite ! CE. right; discriminate.
    (*ra_succ*)
    + now left.
    + assert (k' = 0) as -> by lia. rewrite ! CE. right; discriminate.
    (* ra_proj *)
    + eqdec (@pos_eq_dec k p v'). 1: now left.
      intros H'%inj_pair2_eq_dec. 1:congruence. apply Nat.eq_dec.
    (* ra_comp *)
    + eqdec (Nat.eq_dec k k').
      eqdec (IHh1 rk').
      - eqdec (@vec_pos_eq_dec _ _ gj ri' H). 1: now left.
        intros H'%inj_pair2_eq_dec%inj_pair2_eq_dec. 2-3: apply Nat.eq_dec.
        now apply Hcc.
      - intros H'%inj_pair2_eq_dec%inj_pair2_eq_dec. 1: intros H2%inj_pair2_eq_dec. 2-4: apply Nat.eq_dec.
        now apply Hcc.
    (* ra_rec *)
    + assert (k = 0) as -> by lia. rewrite ! CE. right; discriminate.
    + assert (k = 0) as -> by lia. rewrite ! CE. right; discriminate.
    + destruct (Nat.eq_dec k k') as [->|Hcc].
      2: lia.
      rewrite ! CE.
      eqdec (IHh1_1 rk').
      2: {intros H1%inj_pair2_eq_dec. 1: intros H2%inj_pair2_eq_dec. 2-3: apply Nat.eq_dec. congruence. }
      eqdec (IHh1_2 rSk').
      2: {intros H1%inj_pair2_eq_dec. 2: apply Nat.eq_dec. congruence. }
      now left.
    (* ra_min *)
    + eqdec (IHh1 rSk').
      2: {intros H1%inj_pair2_eq_dec. 2: apply Nat.eq_dec. congruence. }
      now left.
  Qed.

  #[global] Existing Instance recalg_dec.

End EqDec.

Section Enumerate.

  Definition match_n n {k} (l : list (recalg k)) : list (recalg n) :=
    match Nat.eq_dec k n with
      left Heq => match Heq in (_ = i) return list (recalg i) with eq_refl => l end
    | _ => nil end.

  Definition match_n_spec n l : @match_n n n l = l.
  Proof.
    unfold match_n. destruct (Nat.eq_dec n n) as [Heq|Hne]. 2:lia.
    unshelve eapply (@K_dec_type nat _ n (fun h => match h in (_ = i) return _ with eq_refl => l end = l)). 1: apply Nat.eq_dec. easy.
  Qed.

  Fixpoint list_le n : list nat := match n with
    0 => [0]
  | S n => list_le n ++ [S n]
  end.

  Lemma list_le_spec n m : n el list_le m <-> n <= m.
  Proof.
    induction n as [|n IH] in m|-*.
    + split; try lia. intros _. induction m as [|m IH]. 1:now left. cbn. apply in_app_iff. now left.
    + split.
      - induction m as [|m IHm].
        * cbn. intros [|[]]; discriminate.
        * cbn. destruct (Nat.eq_dec n m) as [->|Hne]; try lia.
          intros [H1|H2]%in_app_iff. 1: specialize (IHm H1); lia.
          cbn in H2; lia.
      - induction m as [|m IHm].
        * intros H; lia.
        * intros H. cbn. apply in_app_iff. assert (n = m \/ n < m) as [->|Hr] by lia. 1: right; now left.
          left. apply IHm. lia.
  Qed.

  Fixpoint list_vectors X n (L:list X) : list (vec X n) :=
    match n as nn return list (vec X nn) with
      0 => [Vector.nil X]
    | S n => [Vector.cons X x n xr | (x,xr) ∈ (L × list_vectors n L)]
    end.

  Lemma list_vectors_spec X n (L:list X) v : (forall (p:pos n), vec_pos v p el L) -> v el list_vectors n L.
  Proof.
    induction v as [|x n xr IH].
    - intros _. cbn. now left.
    - intros H. cbn. eapply in_map_iff. exists (x,xr). split; try easy.
      apply in_prod. 1: apply (H pos0).
      apply IH. intros p. apply (H (Fin.FS p)).
  Qed.

  Fixpoint all_fins (n : nat) : list (Fin.t n) :=
      match n with
      | 0 => nil
      | S n => Fin.F1 :: map Fin.FS (all_fins n)
      end.
  Fixpoint L_recalg n f : list (recalg n) :=
    match f with
    | 0 => []
    | S f => L_recalg n f
        ++ match_n n [ra_cst f] (* ra_cst *)
        ++ match_n n [ra_zero]  (* ra_zero *)
        ++ match_n n [ra_succ]  (* ra_succ *)
        ++ [@ra_proj n k | k ∈ all_fins n] (* ra_proj *)
        ++ match_n n (concat [concat [concat [  (* ra_comp *)
                      [@ra_comp k n v1 v2] | v2 ∈ list_vectors k (L_recalg n f)]
                                           | v1 ∈ L_recalg k f]
                                           | k ∈ list_le f])
        ++ match n as k return list (recalg k) with 0 => [] | S k => (* ra_rec *)
                     (concat [concat [
                    [@ra_rec k v1 v2] | v1 ∈ L_recalg k f]
                                      | v2 ∈ L_recalg (S (S k)) f]) end
        ++ match_n n (concat [ (* ra_min *)
                      [@ra_min n v] | v ∈ L_recalg (S n) f])
    end.

  Lemma L_recalg_cml n :
    cumulative (L_recalg n).
  Proof.
    intros ?; cbn; eauto.
  Qed.

  Ltac walklist n := let rec f m := try (apply in_app_iff; match m with 0 =>  left | S ?m => right; f m end) in
                     cbn -[app]; f n.

  Lemma exists_max k (P : pos k -> nat -> Prop) :
        (forall (p:pos k), exists n, P p n)
        -> exists m, forall (p:pos k), exists n, P p n /\ m >= n.
  Proof.
    intros H. induction k as [|k IH].
    - exists 0. intros p. now eapply pos_O_invert.
    - specialize (IH (fun p n => P (pos_nxt p) n)). cbn in IH.
      destruct IH as [m1 Hm1].
      + intros p. apply H.
      + destruct (H pos0) as [m2 Hm2].
        exists (max m1 m2).
        apply pos_S_invert.
        * exists m2. split; now try lia.
        * intros p. edestruct Hm1 as [m3 [Hm3A Hm3B]]. exists m3; split; try lia. exact Hm3A.
  Qed.

  Definition max3 a b c := max a (max b c).

  Lemma enum_recalg n:
    list_enumerator__T (L_recalg n) (recalg n).
  Proof.
    intros t. induction t as [k| | |k p|k i t gj [m1 IHt] IHgj|k t1 t2 [m1 IH1] [m2 IH2]|k t [m IHt]] using recalg_rect.
    - exists (S k). walklist 1. easy.
    - exists 1. walklist 2. easy.
    - exists 1. walklist 3. easy.
    - exists 1. walklist 4. apply in_map.
      induction p; cbn. 1: now left. right. now apply in_map.
    - destruct (exists_max IHgj) as [m2 Hm2].
      exists (S (max3 k m1 m2)). walklist 5. rewrite match_n_spec.
      eapply in_concat. exists (concat [concat [[@ra_comp k i v1 v2] | v2 ∈ list_vectors k (L_recalg i (max3 k m1 m2))] | v1 ∈ L_recalg k (max3 k m1 m2)]).
      split.
      1: { apply in_map_iff. exists k. split; try easy. apply list_le_spec. unfold max3. lia. }
      eapply in_concat. exists (concat [[@ra_comp k i t v2] | v2 ∈ list_vectors k (L_recalg i (max3 k m1 m2))]).
      split.
      1: { apply in_map_iff. exists t. split; try easy. eapply cum_ge'. 1: apply L_recalg_cml. 1: apply IHt. unfold max3; lia. }
      eapply in_concat. exists [@ra_comp k i t gj]. split.
      + eapply in_map_iff. exists gj; split; try easy.
        eapply list_vectors_spec. intros p. destruct (Hm2 p) as [idx [Hidx Hmidx]]. eapply cum_ge'. 1: apply L_recalg_cml.
        1: apply Hidx. unfold max3; lia.
      + now left.
    - exists (S (max m1 m2)). walklist 6.
      eapply in_concat. eexists (concat [[ra_rec v1 t2] | v1 ∈ L_recalg k (max m1 m2)]). split.
      1: { apply in_map_iff. exists t2. split; try easy. eapply cum_ge'. 1: apply L_recalg_cml. 1: apply IH2. lia. }
      eapply in_concat. eexists ([ra_rec t1 t2]). split. 2: now left.
      eapply in_map_iff. exists t1. split; try easy. eapply cum_ge'. 1: apply L_recalg_cml. 1: apply IH1. lia.
    - exists (S m). walklist 7. rewrite match_n_spec.
      eapply in_concat. eexists [_]. split. 2: now left.
      eapply in_map_iff. exists t. split. 1:easy. apply IHt.
  Qed.

  Lemma enumT_recalg n :
    enumerable__T (recalg n).
  Proof.
    apply enum_enumT. exists (L_recalg n). apply enum_recalg.
  Qed.
  Lemma enumeratorT_recalg n :
    {f & enumerator__T f (recalg n) }.
  Proof.
    eexists. eapply enumerator__T_to_list.
    apply enum_recalg.
  Defined.
End Enumerate.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Lists.List.

From Ltac2 Require Import Ltac2.
Set Default Proof Mode "Classic".

Require Import Blech.Bishop.
Require Import Blech.Monoid.
Require Import Blech.Monoid.List.
Require Blech.Monoid.Free.

Import ListNotations.
Import MonoidNotations.
Import BishopNotations.

Open Scope bishop_scope.

(* Loosely based around the cpdt reflection chapter
 http://adam.chlipala.net/cpdt/html/Reflection.html, FIXME give more
 proper credit *)

#[local]
Definition flatten {M: Monoid} (m: Free.Free M): M := ε (from_free m).

#[local]
Theorem denote_correct {M: Monoid} (x: Free.Free M): Free.ε x == ε (from_free x).
Proof.
  induction x.
  - cbn.
    rewrite app_e_right.
    reflexivity.
  - cbn.
    reflexivity.
  - cbn.
    rewrite counit_app.
    rewrite IHx1, IHx2.
    reflexivity.
Qed.

#[local]
 Theorem flatten_injective {M: Monoid} (x y: Free.Free M): flatten x == flatten y → Free.ε x == Free.ε y.
Proof.
  unfold flatten.
  cbn.
  repeat rewrite <- denote_correct.
  intro.
  assumption.
Qed.

#[local]
Ltac2 rec reify (p: constr) :=
  lazy_match! p with
| (@e ?m) => '(Free.e)
| (@app ?m ?x ?y) =>
  let rx := reify x in
  let ry := reify y in
  '(Free.app $rx $ry)
| ?p => '(Free.η $p)
end.

Ltac2 monoid () :=
  lazy_match! goal with
| [ |- ?x == ?y ] =>
  let rx := reify x in
  let ry := reify y in
  change (Free.ε $rx == Free.ε $ry) ; apply (flatten_injective $rx $ry); cbn
end.

Ltac monoid := ltac2:(Control.enter monoid).

Ltac monoid_simpl :=
  Tactics.program_simpl; repeat (try split; try monoid; reflexivity).


(*|
###########################################################################
Why is following Coq rewrite not applying on right hand side of assumption?
###########################################################################

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

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

I have following Coq env.

.. coq:: none
|*)

Section foo.

  Variables n m : nat.
  Hypothesis IHm : forall n : nat, n + n = m + m -> n = m.
  Hypothesis H : S (n + S n) = S (m + S m).
  Hypothesis ll : forall k : nat, k + S k = S k + k.

(*||*)

  Goal False. (* .unfold .hyps *)

(*|
Doing ``rewrite ll in H``, only changes the LHS ``S (n + S n)`` to ``S
(S n + n)`` but not the RHS ``S (m + S m)``:
|*)

    rewrite ll in H. (* .unfold .hyps *)
Abort. (* .none *)
End foo. (* .none *)

(*|
``ll`` should be applicable on all variables of type ``nat``. What is
wrong here?

----

**A (ejgallego):** ``rewrite H`` will only use one instantiation of
``H``, you need to use the ``!`` quantifier to force more rewrites to
happen. Example:
|*)

Lemma ex n m : n = m -> n + 0 = m + 0.
Proof. now rewrite <- !plus_n_O. Qed.

(*|
Answer
******

Expanding on Emilio's comment, ``rewrite H`` and ``rewrite H in H'``
will first find an instantiation for all (dependently) quantified
variables of ``H``, and then replace all occurrences [#]_ of that
instantiated LHS with the RHS. I believe it finds the topmost/leftmost
instantiation in the syntax tree. So, for example, if you do this:
|*)

Goal forall a b,
    (forall x, x + 0 = x) -> (a + 0) * (a + 0) * (b + 0) = a * a * b.
  intros a b H.
  rewrite H.
Abort. (* .none *)

(*|
the ``rewrite H`` will choose to instantiate ``x`` with ``a``, and the
resulting goal will be ``a * a * (b + 0) = a * a * b``. You can prefix
the lemma with ``!`` (as in ``rewrite !H``) to mean "rewrite
everywhere, picking as many instantiations as you can", or with ``?``
(as in ``rewrite ?H``) to mean ``try rewrite !H``, i.e., you can pick
multiple instantiations, and also don't fail if you can't find any.

.. [#] There's actually a bit more nuance, which is that the
   replacement is done in a single pass with rewrite H and in multiple
   passes with ``rewrite ?H`` and ``rewrite !H``. This only shows up
   when the first replacement(s) expose other replacement locations
   that weren't previously available. This shows up, for example, if
   you rewrite with ``a + 0 = a`` in the goal ``(a + 0) + 0 = a``;
   ``rewrite H`` leaves the goal ``a + 0 = 0``.
|*)


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__6a.
Require Export lemma__3__7a.
Require Export lemma__3__7b.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__ray1.
Require Export lemma__ray3.
Require Export lemma__rayimpliescollinear.
Require Export lemma__raystrict.
Require Export logic.
Definition lemma__supplements : forall A B C D F a b c d f, (euclidean__defs.CongA A B C a b c) -> ((euclidean__defs.Supp A B C D F) -> ((euclidean__defs.Supp a b c d f) -> (euclidean__defs.CongA D B F d b f))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro F.
intro a.
intro b.
intro c.
intro d.
intro f.
intro H.
intro H0.
intro H1.
assert (* Cut *) (euclidean__axioms.BetS A B F) as H2.
- destruct H1 as [H2 H3].
destruct H0 as [H4 H5].
exact H5.
- assert (* Cut *) (euclidean__defs.Out B C D) as H3.
-- destruct H1 as [H3 H4].
destruct H0 as [H5 H6].
exact H5.
-- assert (* Cut *) (euclidean__axioms.BetS a b f) as H4.
--- destruct H1 as [H4 H5].
destruct H0 as [H6 H7].
exact H5.
--- assert (* Cut *) (euclidean__defs.Out b c d) as H5.
---- destruct H1 as [H5 H6].
destruct H0 as [H7 H8].
exact H5.
---- assert (exists U V u v, (euclidean__defs.Out B A U) /\ ((euclidean__defs.Out B C V) /\ ((euclidean__defs.Out b a u) /\ ((euclidean__defs.Out b c v) /\ ((euclidean__axioms.Cong B U b u) /\ ((euclidean__axioms.Cong B V b v) /\ ((euclidean__axioms.Cong U V u v) /\ (euclidean__axioms.nCol A B C)))))))) as H6 by exact H.
destruct H6 as [U H7].
destruct H7 as [V H8].
destruct H8 as [u H9].
destruct H9 as [v H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
assert (* Cut *) (euclidean__axioms.neq A B) as H25.
----- assert (* Cut *) ((euclidean__axioms.neq B F) /\ ((euclidean__axioms.neq A B) /\ (euclidean__axioms.neq A F))) as H25.
------ apply (@lemma__betweennotequal.lemma__betweennotequal A B F H2).
------ destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H28.
----- assert (* Cut *) (euclidean__axioms.neq B U) as H26.
------ apply (@lemma__raystrict.lemma__raystrict B A U H11).
------ assert (* Cut *) (euclidean__axioms.neq U B) as H27.
------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B U H26).
------- assert (* Cut *) (euclidean__axioms.neq b u) as H28.
-------- apply (@lemma__raystrict.lemma__raystrict b a u H15).
-------- assert (* Cut *) (euclidean__axioms.neq u b) as H29.
--------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric b u H28).
--------- assert (* Cut *) (exists W, (euclidean__axioms.BetS U B W) /\ (euclidean__axioms.Cong B W U B)) as H30.
---------- apply (@lemma__extension.lemma__extension U B U B H27 H27).
---------- destruct H30 as [W H31].
destruct H31 as [H32 H33].
assert (* Cut *) (euclidean__axioms.neq a b) as H34.
----------- assert (* Cut *) ((euclidean__axioms.neq b f) /\ ((euclidean__axioms.neq a b) /\ (euclidean__axioms.neq a f))) as H34.
------------ apply (@lemma__betweennotequal.lemma__betweennotequal a b f H4).
------------ destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
exact H37.
----------- assert (* Cut *) (exists w, (euclidean__axioms.BetS u b w) /\ (euclidean__axioms.Cong b w U B)) as H35.
------------ apply (@lemma__extension.lemma__extension u b U B H29 H27).
------------ destruct H35 as [w H36].
destruct H36 as [H37 H38].
assert (* Cut *) (euclidean__axioms.Cong U B b w) as H39.
------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric U b w B H38).
------------- assert (* Cut *) (euclidean__axioms.Cong B W b w) as H40.
-------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive B W U B b w H33 H39).
-------------- assert (* Cut *) (euclidean__axioms.Cong U B u b) as H41.
--------------- assert (* Cut *) ((euclidean__axioms.Cong U B u b) /\ ((euclidean__axioms.Cong U B b u) /\ (euclidean__axioms.Cong B U u b))) as H41.
---------------- apply (@lemma__congruenceflip.lemma__congruenceflip B U b u H19).
---------------- destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
exact H42.
--------------- assert (* Cut *) (euclidean__axioms.Cong V W v w) as H42.
---------------- apply (@euclidean__axioms.axiom__5__line U B W V u b w v H40 H23 H21 H32 H37 H41).
---------------- assert (* Cut *) ((euclidean__axioms.BetS B U A) \/ ((A = U) \/ (euclidean__axioms.BetS B A U))) as H43.
----------------- apply (@lemma__ray1.lemma__ray1 B A U H11).
----------------- assert (* Cut *) (euclidean__axioms.BetS A B W) as H44.
------------------ assert ((euclidean__axioms.BetS B U A) \/ ((A = U) \/ (euclidean__axioms.BetS B A U))) as H44 by exact H43.
assert ((euclidean__axioms.BetS B U A) \/ ((A = U) \/ (euclidean__axioms.BetS B A U))) as __TmpHyp by exact H44.
destruct __TmpHyp as [H45|H45].
------------------- assert (* Cut *) (euclidean__axioms.BetS A U B) as H46.
-------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B U A H45).
-------------------- assert (* Cut *) (euclidean__axioms.BetS A B W) as H47.
--------------------- apply (@lemma__3__7a.lemma__3__7a A U B W H46 H32).
--------------------- exact H47.
------------------- destruct H45 as [H46|H46].
-------------------- assert (* Cut *) (euclidean__axioms.BetS A B W) as H47.
--------------------- apply (@eq__ind__r euclidean__axioms.Point U (fun A0 => (euclidean__defs.CongA A0 B C a b c) -> ((euclidean__defs.Supp A0 B C D F) -> ((euclidean__axioms.BetS A0 B F) -> ((euclidean__defs.Out B A0 U) -> ((euclidean__axioms.nCol A0 B C) -> ((euclidean__axioms.neq A0 B) -> (euclidean__axioms.BetS A0 B W)))))))) with (x := A).
----------------------intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
exact H32.

---------------------- exact H46.
---------------------- exact H.
---------------------- exact H0.
---------------------- exact H2.
---------------------- exact H11.
---------------------- exact H24.
---------------------- exact H25.
--------------------- exact H47.
-------------------- assert (* Cut *) (euclidean__axioms.BetS U A B) as H47.
--------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B A U H46).
--------------------- assert (* Cut *) (euclidean__axioms.BetS A B W) as H48.
---------------------- apply (@lemma__3__6a.lemma__3__6a U A B W H47 H32).
---------------------- exact H48.
------------------ assert (* Cut *) (euclidean__defs.Out B F W) as H45.
------------------- exists A.
split.
-------------------- exact H44.
-------------------- exact H2.
------------------- assert (* Cut *) ((euclidean__axioms.BetS B W F) \/ ((F = W) \/ (euclidean__axioms.BetS B F W))) as H46.
-------------------- apply (@lemma__ray1.lemma__ray1 B F W H45).
-------------------- assert (* Cut *) (euclidean__axioms.BetS U B F) as H47.
--------------------- assert ((euclidean__axioms.BetS B W F) \/ ((F = W) \/ (euclidean__axioms.BetS B F W))) as H47 by exact H46.
assert ((euclidean__axioms.BetS B W F) \/ ((F = W) \/ (euclidean__axioms.BetS B F W))) as __TmpHyp by exact H47.
destruct __TmpHyp as [H48|H48].
---------------------- assert (* Cut *) (euclidean__axioms.BetS U B F) as H49.
----------------------- apply (@lemma__3__7b.lemma__3__7b U B W F H32 H48).
----------------------- exact H49.
---------------------- destruct H48 as [H49|H49].
----------------------- assert (* Cut *) (euclidean__axioms.BetS U B F) as H50.
------------------------ apply (@eq__ind__r euclidean__axioms.Point W (fun F0 => (euclidean__defs.Supp A B C D F0) -> ((euclidean__axioms.BetS A B F0) -> ((euclidean__defs.Out B F0 W) -> (euclidean__axioms.BetS U B F0))))) with (x := F).
-------------------------intro H50.
intro H51.
intro H52.
exact H32.

------------------------- exact H49.
------------------------- exact H0.
------------------------- exact H2.
------------------------- exact H45.
------------------------ exact H50.
----------------------- assert (* Cut *) (euclidean__axioms.BetS U B F) as H50.
------------------------ apply (@euclidean__axioms.axiom__innertransitivity U B F W H32 H49).
------------------------ exact H50.
--------------------- assert (* Cut *) (euclidean__axioms.neq B F) as H48.
---------------------- assert (* Cut *) ((euclidean__axioms.neq B F) /\ ((euclidean__axioms.neq U B) /\ (euclidean__axioms.neq U F))) as H48.
----------------------- apply (@lemma__betweennotequal.lemma__betweennotequal U B F H47).
----------------------- destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
exact H49.
---------------------- assert (* Cut *) (euclidean__defs.Out B F W) as H49.
----------------------- exists A.
split.
------------------------ exact H44.
------------------------ exact H2.
----------------------- assert (* Cut *) ((euclidean__axioms.BetS b u a) \/ ((a = u) \/ (euclidean__axioms.BetS b a u))) as H50.
------------------------ apply (@lemma__ray1.lemma__ray1 b a u H15).
------------------------ assert (* Cut *) (euclidean__axioms.BetS a b w) as H51.
------------------------- assert ((euclidean__axioms.BetS b u a) \/ ((a = u) \/ (euclidean__axioms.BetS b a u))) as H51 by exact H50.
assert ((euclidean__axioms.BetS b u a) \/ ((a = u) \/ (euclidean__axioms.BetS b a u))) as __TmpHyp by exact H51.
destruct __TmpHyp as [H52|H52].
-------------------------- assert (* Cut *) (euclidean__axioms.BetS a u b) as H53.
--------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry b u a H52).
--------------------------- assert (* Cut *) (euclidean__axioms.BetS a b w) as H54.
---------------------------- apply (@lemma__3__7a.lemma__3__7a a u b w H53 H37).
---------------------------- exact H54.
-------------------------- destruct H52 as [H53|H53].
--------------------------- assert (* Cut *) (euclidean__axioms.BetS a b w) as H54.
---------------------------- apply (@eq__ind__r euclidean__axioms.Point u (fun a0 => (euclidean__defs.CongA A B C a0 b c) -> ((euclidean__defs.Supp a0 b c d f) -> ((euclidean__axioms.BetS a0 b f) -> ((euclidean__defs.Out b a0 u) -> ((euclidean__axioms.neq a0 b) -> (euclidean__axioms.BetS a0 b w))))))) with (x := a).
-----------------------------intro H54.
intro H55.
intro H56.
intro H57.
intro H58.
exact H37.

----------------------------- exact H53.
----------------------------- exact H.
----------------------------- exact H1.
----------------------------- exact H4.
----------------------------- exact H15.
----------------------------- exact H34.
---------------------------- exact H54.
--------------------------- assert (* Cut *) (euclidean__axioms.BetS u a b) as H54.
---------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry b a u H53).
---------------------------- assert (* Cut *) (euclidean__axioms.BetS a b w) as H55.
----------------------------- apply (@lemma__3__6a.lemma__3__6a u a b w H54 H37).
----------------------------- exact H55.
------------------------- assert (* Cut *) (euclidean__defs.Out b f w) as H52.
-------------------------- exists a.
split.
--------------------------- exact H51.
--------------------------- exact H4.
-------------------------- assert (* Cut *) ((euclidean__axioms.BetS b w f) \/ ((f = w) \/ (euclidean__axioms.BetS b f w))) as H53.
--------------------------- apply (@lemma__ray1.lemma__ray1 b f w H52).
--------------------------- assert (* Cut *) (euclidean__axioms.BetS u b f) as H54.
---------------------------- assert ((euclidean__axioms.BetS b w f) \/ ((f = w) \/ (euclidean__axioms.BetS b f w))) as H54 by exact H53.
assert ((euclidean__axioms.BetS b w f) \/ ((f = w) \/ (euclidean__axioms.BetS b f w))) as __TmpHyp by exact H54.
destruct __TmpHyp as [H55|H55].
----------------------------- assert (* Cut *) (euclidean__axioms.BetS u b f) as H56.
------------------------------ apply (@lemma__3__7b.lemma__3__7b u b w f H37 H55).
------------------------------ exact H56.
----------------------------- destruct H55 as [H56|H56].
------------------------------ assert (* Cut *) (euclidean__axioms.BetS u b f) as H57.
------------------------------- apply (@eq__ind__r euclidean__axioms.Point w (fun f0 => (euclidean__defs.Supp a b c d f0) -> ((euclidean__axioms.BetS a b f0) -> ((euclidean__defs.Out b f0 w) -> (euclidean__axioms.BetS u b f0))))) with (x := f).
--------------------------------intro H57.
intro H58.
intro H59.
exact H37.

-------------------------------- exact H56.
-------------------------------- exact H1.
-------------------------------- exact H4.
-------------------------------- exact H52.
------------------------------- exact H57.
------------------------------ assert (* Cut *) (euclidean__axioms.BetS u b f) as H57.
------------------------------- apply (@euclidean__axioms.axiom__innertransitivity u b f w H37 H56).
------------------------------- exact H57.
---------------------------- assert (* Cut *) (euclidean__axioms.neq b f) as H55.
----------------------------- assert (* Cut *) ((euclidean__axioms.neq b f) /\ ((euclidean__axioms.neq u b) /\ (euclidean__axioms.neq u f))) as H55.
------------------------------ apply (@lemma__betweennotequal.lemma__betweennotequal u b f H54).
------------------------------ destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
exact H56.
----------------------------- assert (* Cut *) (euclidean__defs.Out b f w) as H56.
------------------------------ exists a.
split.
------------------------------- exact H51.
------------------------------- exact H4.
------------------------------ assert (* Cut *) (euclidean__axioms.neq b f) as H57.
------------------------------- assert (* Cut *) ((euclidean__axioms.neq b f) /\ ((euclidean__axioms.neq u b) /\ (euclidean__axioms.neq u f))) as H57.
-------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal u b f H54).
-------------------------------- destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
exact H55.
------------------------------- assert (* Cut *) (euclidean__defs.Out b f w) as H58.
-------------------------------- exists a.
split.
--------------------------------- exact H51.
--------------------------------- exact H4.
-------------------------------- assert (* Cut *) (euclidean__axioms.Col U B W) as H59.
--------------------------------- right.
right.
right.
right.
left.
exact H32.
--------------------------------- assert (* Cut *) (euclidean__axioms.Col B A U) as H60.
---------------------------------- apply (@lemma__rayimpliescollinear.lemma__rayimpliescollinear B A U H11).
---------------------------------- assert (* Cut *) (~(euclidean__axioms.Col D B F)) as H61.
----------------------------------- intro H61.
assert (* Cut *) (euclidean__axioms.Col B C D) as H62.
------------------------------------ apply (@lemma__rayimpliescollinear.lemma__rayimpliescollinear B C D H3).
------------------------------------ assert (* Cut *) (euclidean__axioms.Col D B C) as H63.
------------------------------------- assert (* Cut *) ((euclidean__axioms.Col C B D) /\ ((euclidean__axioms.Col C D B) /\ ((euclidean__axioms.Col D B C) /\ ((euclidean__axioms.Col B D C) /\ (euclidean__axioms.Col D C B))))) as H63.
-------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C D H62).
-------------------------------------- destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
exact H68.
------------------------------------- assert (* Cut *) (euclidean__axioms.neq B D) as H64.
-------------------------------------- apply (@lemma__raystrict.lemma__raystrict B C D H3).
-------------------------------------- assert (* Cut *) (euclidean__axioms.neq D B) as H65.
--------------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B D H64).
--------------------------------------- assert (* Cut *) (euclidean__axioms.Col B F C) as H66.
---------------------------------------- apply (@euclidean__tactics.not__nCol__Col B F C).
-----------------------------------------intro H66.
apply (@euclidean__tactics.Col__nCol__False B F C H66).
------------------------------------------apply (@lemma__collinear4.lemma__collinear4 D B F C H61 H63 H65).

---------------------------------------- assert (* Cut *) (euclidean__axioms.Col A B F) as H67.
----------------------------------------- right.
right.
right.
right.
left.
exact H2.
----------------------------------------- assert (* Cut *) (euclidean__axioms.Col F B A) as H68.
------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col B A F) /\ ((euclidean__axioms.Col B F A) /\ ((euclidean__axioms.Col F A B) /\ ((euclidean__axioms.Col A F B) /\ (euclidean__axioms.Col F B A))))) as H68.
------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A B F H67).
------------------------------------------- destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
destruct H74 as [H75 H76].
exact H76.
------------------------------------------ assert (* Cut *) (euclidean__axioms.Col F B C) as H69.
------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col F B C) /\ ((euclidean__axioms.Col F C B) /\ ((euclidean__axioms.Col C B F) /\ ((euclidean__axioms.Col B C F) /\ (euclidean__axioms.Col C F B))))) as H69.
-------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B F C H66).
-------------------------------------------- destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
exact H70.
------------------------------------------- assert (* Cut *) (euclidean__axioms.neq B F) as H70.
-------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq b f) /\ ((euclidean__axioms.neq u b) /\ (euclidean__axioms.neq u f))) as H70.
--------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal u b f H54).
--------------------------------------------- destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
exact H48.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.neq F B) as H71.
--------------------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B F H70).
--------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B A C) as H72.
---------------------------------------------- apply (@euclidean__tactics.not__nCol__Col B A C).
-----------------------------------------------intro H72.
apply (@euclidean__tactics.Col__nCol__False B A C H72).
------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 F B A C H68 H69 H71).

---------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H73.
----------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B C A) /\ (euclidean__axioms.Col C A B))))) as H73.
------------------------------------------------ apply (@lemma__collinearorder.lemma__collinearorder B A C H72).
------------------------------------------------ destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
exact H74.
----------------------------------------------- apply (@euclidean__tactics.Col__nCol__False A B C H24 H73).
----------------------------------- assert (* Cut *) (euclidean__defs.Out B D V) as H62.
------------------------------------ apply (@lemma__ray3.lemma__ray3 B C D V H3 H13).
------------------------------------ assert (* Cut *) (euclidean__defs.Out b d v) as H63.
------------------------------------- apply (@lemma__ray3.lemma__ray3 b c d v H5 H17).
------------------------------------- assert (* Cut *) (euclidean__defs.CongA D B F d b f) as H64.
-------------------------------------- exists V.
exists W.
exists v.
exists w.
split.
--------------------------------------- exact H62.
--------------------------------------- split.
---------------------------------------- exact H49.
---------------------------------------- split.
----------------------------------------- exact H63.
----------------------------------------- split.
------------------------------------------ exact H58.
------------------------------------------ split.
------------------------------------------- exact H21.
------------------------------------------- split.
-------------------------------------------- exact H40.
-------------------------------------------- split.
--------------------------------------------- exact H42.
--------------------------------------------- apply (@euclidean__tactics.nCol__notCol D B F H61).
-------------------------------------- exact H64.
Qed.


Require Import A1_Plan A2_Orientation A4_Droite A5_Cercle .
Require Import B2_CollinearProp B5_BetweenProp B7_Tactics .
Require Import C1_Distance C2_CircleAndDistance C3_SumDistance C5_TriangularInequality C7_Tactics .
Require Import D1_IntersectionCirclesProp .
Require Import F1_IntersectionDiameterProp F2_MarkSegment F5_Tactics .
Require Import G1_Angles.

Section PARTICULAR_ANGLES.

Ltac destructAngle A B C Hab Hac B' C' bac :=
unfold Angle at 1 in |- *; simpl in |- *;
unfold IntersectionCirclesPoint in |- *;
let H7 := fresh in let H8 := fresh in let H9 := fresh in let H10 := fresh in
(destruct (InterCirclesPointDef uCircle
    (Compass Uu  (InterDiameterPoint (Ruler A B Hab) (Compass A Oo Uu) (CollinearABA A B))
       (InterDiameterPoint (Ruler A C Hac) (Compass A Oo Uu) (CollinearABA A C)))) as (bac, ((H7, (H8, H9)), H10));
unfold InterDiameterPoint in *;
let H1 := fresh in let H2 := fresh in let H3 := fresh in
(destruct (InterDiameterPointDef (Ruler A B Hab) (Compass A Oo Uu)) as (B', ((H1, H2), H3));
let H4 := fresh in let H5 := fresh in let H6 := fresh in
(destruct (InterDiameterPointDef (Ruler A C Hac) (Compass A Oo Uu)) as (C', ((H4, H5), H6));
simpl in H1, H2, H3, H4, H5, H6, H7, H8, H9, H10))).

(* L'angle nul est represente par le point Uu. *)

Lemma InterPointLineOoUuuCircle :
	Uu = InterDiameterPoint lineOoUu uCircle DiameterlineOoUuuCircle.
Proof.
	byDefEqPoint5; simpl in |- *; immediate5.
Qed.

Definition NullAngle ( A B C : Point)  := CongruentAngle A B C Uu Oo Uu.

Lemma NullAngleSym : forall A B C : Point,
	NullAngle A B C -> NullAngle C B A.
Proof.
	unfold NullAngle in |- *; intros.
	apply CongruentAngleRev1; immediate5.
Qed.

Lemma NullAngleDistinctBA : forall A B C : Point,
	NullAngle A B C ->
	B <> A.
Proof.
	unfold NullAngle in |- *; intros.
	apply (CongruentAngleDistinctBA A B C Uu Oo Uu H).
Qed.

Lemma NullAngleDistinctBC : forall A B C : Point,
	NullAngle A B C ->
	B <> C.
Proof.
	unfold NullAngle in |- *; intros.
	apply (CongruentAngleDistinctBC A B C Uu Oo Uu H).
Qed.

Lemma OpenRayNullAngle : forall A B C : Point,
	A <> B ->
	OpenRay A B C ->
	NullAngle B A C.
Proof.
	unfold NullAngle in |- *; intros.
	from5 H0 (A <> C).
	 apply (CongruentEqAngle B A C Uu Oo Uu H H1 DistinctOoUu DistinctOoUu).
	   destructAngle A B C H H1 ipattern:(D) ipattern:(E) ipattern:(alpha).
	   apply H5; intuition.
	  rewrite DistanceOoAngle; immediate5.
	  since5 (D = E).
	   apply H8; intuition.
	     step5 H10.
	   rewrite DistanceUuAngle.
	     rewrite H12; immediate5.
	  elim (NotClockwiseAngle Uu Oo Uu DistinctOoUu DistinctOoUu); immediate5.
Qed.

Lemma NullAngleOpenRay : forall A B C : Point,
	NullAngle B A C -> OpenRay A B C.
Proof.
	unfold NullAngle in |- *; intros.
	assert (Hab := CongruentAngleDistinctBA B A C Uu Oo Uu H).
	assert (Hac := CongruentAngleDistinctBC B A C Uu Oo Uu H).
	generalize  (EqCongruentAngle B A C Uu Oo Uu Hab Hac DistinctOoUu DistinctOoUu H).
	destructAngle A B C Hab Hac ipattern:(D) ipattern:(E) ipattern:(alpha).
	intro; from5 H1 (D = E).
	   subst.
	   rewrite DistanceUuAngle.
	   immediate5.
	 step5 H8.
	   step5 H11.
	   step5 H5.
	   step5 H4.
Qed.

Lemma CongruentNullAngle : forall A B C D E F : Point,
	NullAngle A B C ->
	CongruentAngle A B C D E F ->
	NullAngle D E F.
Proof.
	unfold NullAngle in |- *; intros.
	apply (CongruentAngleTrans D E F A B C Uu Oo Uu).
	 apply CongruentAngleSym; exact H0.
	 exact H.
Qed.

Lemma NullCongruentAngle : forall A B C D E F : Point,
	NullAngle A B C ->
	NullAngle D E F ->
	CongruentAngle A B C D E F.
Proof.
	unfold NullAngle in |- *; intros.
	apply (CongruentAngleTrans A B C Uu Oo Uu).
	 immediate5.
	 apply CongruentAngleSym; immediate5.
Qed.

Lemma IsAngleNullAngle : IsAngle Uu.
Proof.
	unfold IsAngle in |- *; split; immediate5.
Qed.

Lemma EqNullAngle : forall (A B C : Point) (Hba : B <> A) (Hbc: B <> C) ,
	NullAngle A B C ->
	Angle A B C Hba Hbc = Uu.
Proof.
	intros.
	rewrite <- (EqAnglePoint Uu DistinctOoUu DistinctOoUu IsAngleNullAngle).
	apply EqCongruentAngle; exact H.
Qed.

Lemma NullEqAngle : forall (A B C : Point) (Hba : B <> A) (Hbc: B <> C),
	Angle A B C Hba Hbc = Uu->
	NullAngle A B C.
Proof.
	intros.
	apply (CongruentEqAngle A B C Uu Oo Uu Hba Hbc DistinctOoUu DistinctOoUu).
	rewrite (EqAnglePoint Uu DistinctOoUu DistinctOoUu IsAngleNullAngle); exact H.
Qed.

(* L'angle plat est represente par le point uU. *)

Definition uU := SymmetricPoint Uu Oo (sym_not_eq DistinctOoUu).

Definition ElongatedAngle ( A B C : Point)  := CongruentAngle A B C Uu Oo uU.

Lemma ElongatedAngleSym : forall A B C : Point,
	ElongatedAngle A B C -> ElongatedAngle C B A.
Proof.
	unfold ElongatedAngle in |- *; intros.
	apply CongruentAngleRev1; immediate5.
Qed.

Lemma ElongatedAngleDistinctBA : forall A B C : Point,
	ElongatedAngle A B C ->
	B <> A.
Proof.
	intros; inversion H; immediate5.
Qed.

Lemma ElongatedAngleDistinctBC : forall A B C : Point,
	ElongatedAngle A B C ->
	B <> C.
Proof.
	intros; inversion H; immediate5.
Qed.

Lemma SecondInterPointLineOoUuuCircle :
	uU = SecondInterDiameterPoint lineOoUu uCircle DiameterlineOoUuuCircle.
Proof.
	step5 uU; simpl in |- *; immediate5.
Qed.

Lemma DistanceOouU : Distance Oo uU = Uu.
Proof.
	unfold uU in |- *; rewrite EqDistanceSymmetricPoint; immediate5.
Qed.

Lemma BetweenUuOouU : Between Uu Oo uU.
Proof.
	unfold uU in |- *; apply BetweenSymmetricPoint.
Qed.

Lemma DistinctOouU : Oo <> uU.
Proof.
	assert (H := BetweenUuOouU); immediate5.
Qed.

Lemma DistinctUuuU : Uu <> uU.
Proof.
	assert (H := BetweenUuOouU); immediate5.
Qed.

Lemma IsAngleElongatedAngle : IsAngle uU.
Proof.
	unfold IsAngle in |- *; split.
	 assert (H := DistanceOouU); immediate5.
	 assert (H := BetweenUuOouU); immediate5.
Qed.

Lemma BetweenElongatedAngle : forall A B C : Point,
	Between B A C -> ElongatedAngle B A C.
Proof.
	intros.
	assert (Hab : A <> B).
	 immediate5.
	 assert (Hac : A <> C).
	  immediate5.
	  apply (CongruentEqAngle B A C Uu Oo uU Hab Hac DistinctOoUu DistinctOouU).
	    destructAngle A B C Hab Hac ipattern:(D) ipattern:(E) ipattern:(alpha).
	    rewrite (EqAnglePoint uU DistinctOoUu DistinctOouU).
	   unfold uU in |- *; byDefEqPoint5.
	     assert (Segment Uu alpha Oo).
	    apply ChaslesRec.
	      rewrite H0.
	      rewrite <- H7.
	      step5 H1.
	      step5 H4.
	      usingChasles2 D A E.
	      step5 H5.
	      step5 H8.
	      step5 H7.
	    step5 H10.
	      step5 H12.
	      step5 H0.
	   exact IsAngleElongatedAngle.
Qed.

Lemma ElongatedAngleBetween : forall A B C : Point,
	ElongatedAngle B A C -> Between B A C.
Proof.
	intros; inversion H.
	generalize H0; clear H0.
	destructAngle A B C Hba Hbc ipattern:(D) ipattern:(E) ipattern:(alpha).
	rewrite (EqAnglePoint uU Hed Hef).
	 intro; step5 H5.
	   step5 H8.
	   subst; apply SegmentBetween.
	  apply ChaslesRec.
	    step5 H4.
	    step5 H0.
	    step5 H7.
	    step5 H1.
	    usingChasles2 Uu Oo uU.
	   immediate5.
	  step5 H4.
	  step5 H7.
	 exact IsAngleElongatedAngle.
Qed.

Lemma CongruentElongatedAngle : forall A B C D E F : Point,
	ElongatedAngle A B C ->
	CongruentAngle A B C D E F ->
	ElongatedAngle D E F.
Proof.
	unfold ElongatedAngle in |- *; intros.
	apply (CongruentAngleTrans D E F A B C Uu Oo uU).
	 apply CongruentAngleSym; exact H0.
	 exact H.
Qed.

Lemma ElongatedCongruentAngle : forall A B C D E F : Point,
	ElongatedAngle A B C ->
	ElongatedAngle D E F ->
	CongruentAngle A B C D E F.
Proof.
	unfold ElongatedAngle in |- *; intros.
	apply (CongruentAngleTrans A B C Uu Oo uU).
	 immediate5.
	 apply CongruentAngleSym; immediate5.
Qed.

Lemma EqElongatedAngle : forall (A B C : Point) (Hba : B <> A) (Hbc: B <> C) ,
	ElongatedAngle A B C ->
	Angle A B C Hba Hbc = uU.
Proof.
	intros.
	rewrite <- (EqAnglePoint uU DistinctOoUu DistinctOouU).
	 apply EqCongruentAngle.
	   exact H.
	 exact IsAngleElongatedAngle.
Qed.

Lemma ElongatedEqAngle : forall (A B C : Point) (Hba : B <> A) (Hbc: B <> C),
	Angle A B C Hba Hbc = uU->
	ElongatedAngle A B C.
Proof.
	intros.
	apply (CongruentEqAngle A B C Uu Oo uU Hba Hbc DistinctOoUu DistinctOouU).
	rewrite EqAnglePoint.
	 exact H.
	 exact IsAngleElongatedAngle.
Qed.

Lemma CongruentAngleCollinear : forall A B C D E F : Point,
	Collinear A B C ->
	CongruentAngle A B C D E F ->
	Collinear D E F.
Proof.
	intros.
	by3SegmentCases1 H.
	 since5 (OpenRay B C A).
	  since5 (NullAngle C B A).
	   apply OpenRayNullAngle.
	    apply (CongruentAngleDistinctBC _ _ _ _ _ _ H0).
	    immediate5.
	   since5 (NullAngle F E D).
	    apply NullAngleSym; apply (CongruentNullAngle A B C D E F).
	     apply NullAngleSym; immediate5.
	     immediate5.
	    since5 (OpenRay E F D).
	     apply NullAngleOpenRay; immediate5.
	 since5 (OpenRay B A C).
	  since5 (NullAngle A B C).
	   apply OpenRayNullAngle.
	    apply (CongruentAngleDistinctBA _ _ _ _ _ _ H0).
	    immediate5.
	   since5 (NullAngle D E F).
	    apply (CongruentNullAngle A B C D E F); immediate5.
	    since5 (OpenRay E D F).
	     apply NullAngleOpenRay; immediate5.
	 since5 (ElongatedAngle A B C).
	  apply BetweenElongatedAngle; step5 H2.
	   apply sym_not_eq; apply (CongruentAngleDistinctBC _ _ _ _ _ _ H0).
	   apply (CongruentAngleDistinctBA _ _ _ _ _ _ H0).
	  since5 (ElongatedAngle D E F).
	   apply (CongruentElongatedAngle A B C D E F); immediate5.
	   since5 (Between D E F).
	    apply ElongatedAngleBetween; immediate5.
Qed.

Lemma NullAngleNotElongatedAngle : forall A B C : Point,
	NullAngle A B C -> ~ElongatedAngle A B C.
Proof.
	intros; intro.
	inversion H; inversion H0.
	elim DistinctUuuU.
	rewrite <- (EqNullAngle A B C Hba Hbc H).
	rewrite <- (EqElongatedAngle A B C Hba0 Hbc0 H0).
	apply EqCongruentAngle; apply CongruentAngleRefl; immediate5.
Qed.

Lemma ElongatedAngleNotNullAngle : forall A B C : Point,
 	ElongatedAngle A B C -> ~NullAngle A B C.
Proof.
	intros; intro.
	inversion H; inversion H0.
	elim DistinctUuuU.
	rewrite <- (EqNullAngle A B C Hba0 Hbc0 H0).
	rewrite <- (EqElongatedAngle A B C Hba Hbc H).
	apply EqCongruentAngle; apply CongruentAngleRefl; immediate5.
Qed.

End PARTICULAR_ANGLES.


Require Import EnvListAux7.
Require Import IdModType.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Logic.ProofIrrelevance.

(*
Parameter CId : Type.

Parameter CIdEqDec : forall (x y : CId), {x = y} + {x <> y}.

Instance CIdEq: DEq CId :=
{
  dEq := CIdEqDec
}.
*)

Lemma valTyp_irrelevance : forall (T: Type) (p1 p2: ValTyp T), p1 = p2.
intros.
eapply proof_irrelevance.
Qed.

Instance pstate_nat : PState nat := {|

   loc_pi := valTyp_irrelevance;

   b_init := 0
|}.

(*
Parameter W2 : Type.

Parameter Loc_PI2 : forall (T: Type) (p1 p2: ValTyp T), p1 = p2.

Parameter BInit2 : W2.
*)

Module IdModM2 <: IdModType.

  Definition Id := string.

  Definition IdEqDec := string_dec.

  Instance IdEq2 : DEq Id :=
  {
  dEq := IdEqDec
  }.

  Definition IdEq := IdEq2.

  Definition W := nat.

  Definition Loc_PI := valTyp_irrelevance.

  Definition BInit := 0.

  Instance WP2 : PState W :=
  {
  loc_pi := Loc_PI;

  b_init := BInit
  }.

  Definition WP := WP2.

End IdModM2.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype path.
From fcsl
Require Import ordtype unionmap.
From Toychain
Require Import Types TypesImpl Parameters Address.
Require Import BinNat BinNatDef.
Require Import HexString String Ascii.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* TODO: find a way to remove this stuff from the extraction! *)
(** Instantiate Toychain with a proof-of-work scheme **)
Module ProofOfWork <: (ConsensusParams TypesImpl).
Import TypesImpl.

Definition GenesisBlock : block :=
  mkB (("0x6150cb353fe365318be1040f4f1d55ba6a6235c7fdee7e94602fed76f112f2de")%string <: Hash)
      [::]
      ((N_of_nat 0) <: VProof).

Definition subchain (bc1 bc2 : Blockchain) := exists p q, bc2 = p ++ bc1 ++ q.
Definition bcLast (bc : Blockchain) := last GenesisBlock bc.

(* Hash should be HexStrings prefixed with 0x, e.g. '0x1c2139314aab35' *)
Parameter hashT : Transaction -> Hash.
Parameter hashB : block -> Hash.

Definition WorkAmnt := N_ordType.

(* Lookup table; lz[i] = how many leading 0s does i have as a 4-bit binary number ? *)
Let leading_zeroes : seq N :=
  [:: 4; 3; 2; 2; 1; 1; 1; 1;
      0; 0; 0; 0; 0; 0; 0; 0
  ]%N .

Fixpoint _cbzs (s : string) : N :=
  match s with
  | String c s =>
        let d_opt := ascii_to_digit c in
        match d_opt with
        | None => N0
        | Some d =>
          let lz := (nth N0 leading_zeroes d) in
          if lz == N_of_nat(4) then (lz + _cbzs s)%N else lz
        end
  | _ => N0
  end.

(* Given a hex string, count how many binary zeroes it starts with *)
Definition count_binary_zeroes (s : string) : N :=
  match s with
  | String s0 (String so s)
      => if ascii_dec s0 "0"
        then if ascii_dec so "x"
          then _cbzs s
          else N0
        else N0
  | _ => N0
  end.

Definition work (b : block) : WorkAmnt :=
  count_binary_zeroes (hashB b).

Fixpoint total_work (bc : Blockchain) : N :=
  match bc with
  | b::bc' => (work b + total_work bc')%N
  | [::] => N_of_nat 0
  end.

Lemma total_work_sum xs ys :
  total_work (xs ++ ys) = (total_work xs + total_work ys)%N.
Proof.
elim: xs=>//=[x xs H].
case: (N.add_cancel_l (total_work (xs ++ ys)) (total_work xs + total_work ys)%N (work x))=>_ P.
by specialize (P H); rewrite P N.add_assoc.
Qed.

(* (* For some reason, only ltb is defined in BinNatDef *) *)
(* Definition gtb x y := *)
(*  match (x ?= y)%N with Gt => true | _ => false end. *)

(* Infix ">?" := gtb (at level 70, no associativity) : N_scope. *)

(* This is supposed to behave as >, not < *)
Definition FCR bc bc' : bool :=
  let w := total_work bc in
  let w' := total_work bc' in
  let l := (List.length bc) in
  let l' := (List.length bc') in
  let eW := w == w' in
  let eL := l == l' in
  let eO := bc == bc' in

  (* This is written in this weird fashion to be able to prove both
     transitivity and totality. *)
  match eW, eL, eO with
  | true, true, true => false
  | true, true, false => ords bc bc'
  | true, _, _ => ~~ (Nat.leb l l')
  | false, _, _ => ~~ (w <=? w')%N
  end.

Notation "A > B" := (FCR A B).
Notation "A >= B" := (A = B \/ A > B).

Definition txValid (tx : Transaction) (bc : Blockchain) :=
  tx \notin flatten (map (fun b => txs b) bc).

(* bt is an argument to allow you to validate transactions before
    adding them to your pool. However, all transactions are valid for us.
 *)
Definition tpExtend (tp : TxPool) (bt : BlockTree) (tx : Transaction) :=
  if tx \in tp then tp else (tx::tp).

(* You'd normally want some difficulty adjustment, but we're just toying around *)
(* TODO: don't hardcode difficulty *)
Definition VAF (b : Block) (bc : Blockchain) (tp : TxPool) : bool :=
  (* GenesisBlock doesn't have work requirements *)
  if (b == GenesisBlock) then
    if (bc == [::]) && (tp == [::]) then true else false
  (* All other blocks do *)
  else if (12 <? (work b))%N then true else false.

(* For proof-of-work, this would be more aptly called "getNonce" *)
(* TODO: Implement this in the extraction *)
(* We can't (reasonably) implement this in Coq since it required randomness. *)
Parameter genProof : Blockchain -> TxPool -> Timestamp -> option (TxPool * VProof).

(************************************************************)
(*********************** <axioms> ***************************)
(************************************************************)

Lemma txValid_nil : forall t, txValid t [::].
Proof. done. Qed.

(** VAF **)
Lemma VAF_init : VAF GenesisBlock [::] (txs GenesisBlock).
Proof. by rewrite/VAF !eq_refl. Qed.

Lemma VAF_GB_first :
  forall bc, VAF GenesisBlock bc (txs GenesisBlock) -> bc = [::].
Proof. by rewrite/VAF eq_refl=>bc; case: ifP=>//=; move/andP; case=>/eqP. Qed.

(** FCR **)
(* It's a bit of a pain to prove these, since we have different types of numbers. *)
Lemma FCR_ext :
  forall (bc : Blockchain) (b : block) (ext : seq block),
    bc ++ (b :: ext) > bc.
Proof.
move=>bc b ext; rewrite/FCR.
(* When total work is different, LHS will have more work *)
case: ifP; last first.
- move=>A; rewrite -N.ltb_antisym; elim: bc A=>//=.
  + move/negbT=>A; apply/N.ltb_lt.
    case: (N.neq_0_lt_0 (work b + total_work ext)%N)=>P _.
    by move/eqP in A; specialize (P A).
  + move=>x xs Hi X.
    case Q: (total_work (xs ++ b :: ext) == total_work xs).
    by move/eqP in Q; rewrite Q eq_refl in X.
    by specialize (Hi Q); move/N.ltb_lt in Hi;
       case: (N.add_lt_mono_l (total_work xs) (total_work (xs ++ b :: ext))  (work x))=>P _ ;
       specialize (P Hi); apply/N.ltb_lt.

(* When total work is equal, LHS is longer *)
- case: ifP;
  have X: (Datatypes.length bc + 0 = Datatypes.length bc) by rewrite ?addn0.
  by rewrite List.app_length -{2}X eqn_add2l.
  by move=>_ _; rewrite -PeanoNat.Nat.ltb_antisym List.app_length -{1}X;
     apply/PeanoNat.Nat.ltb_lt/ltP; rewrite ltn_add2l.
Qed.

Lemma FCR_nrefl :
  forall (bc : Blockchain), bc > bc -> False.
Proof. by move=>bc; rewrite/FCR !eq_refl. Qed.

Lemma FCR_trans :
  forall (A B C : Blockchain), A > B -> B > C -> A > C.
Proof.
move=>x y z; rewrite/FCR.
case: ifP; case: ifP; case: ifP=>//=.
- case: ifP; case: ifP=>//=.
  + case: ifP=>//=;
    move=>A /eqP -> /eqP -> B /eqP -> /eqP -> C D;
    rewrite !eq_refl; case: ifP.
    by move/eqP=>X; subst z; move: (trans_ords C D) (irr_ords x)=>->.
    by move: (trans_ords C D).
  + by move=>A /eqP -> B /eqP -> /eqP ->; rewrite !eq_refl A.
  + by move=>/eqP -> A B /eqP -> /eqP A'; rewrite A' eq_refl in A.
  + by move=>_ _ _ _ /eqP ->.
- move=>/eqP -> A /eqP -> B; rewrite !eq_refl; case: ifP; case: ifP=>//=.
  + case: ifP.
    by move=>/eqP <- _ /eqP A'; rewrite A' eq_refl in A.
    by move=>_ _ /eqP B'; rewrite B' in B.
  + move=>/eqP <- _; move: B; rewrite -!PeanoNat.Nat.ltb_antisym;
    move/PeanoNat.Nat.ltb_lt/ltP=>B; move/PeanoNat.Nat.ltb_lt/ltP=>B'.
      by move: (ltn_trans B B') (ltnn (Datatypes.length y))=>->.
    move=>_ _; move: B; rewrite -!PeanoNat.Nat.ltb_antisym.
    move/PeanoNat.Nat.ltb_lt/ltP=>B; move/PeanoNat.Nat.ltb_lt/ltP=>B'.
      by move/ltP/PeanoNat.Nat.ltb_lt: (ltn_trans B' B).
- by move=>A B /eqP ->; rewrite A.
- by move=>/eqP <- /eqP <- A; rewrite A.
- by move=>A /eqP <- B; rewrite B.
- by move=>/eqP-> A _; rewrite -!N.ltb_antisym;
     move/N.ltb_lt=>B; move/N.ltb_lt=>B';
     move: (N.lt_trans _ _ _ B B') (N.lt_irrefl (total_work y)).
by move=>_ _ _; rewrite -!N.ltb_antisym;
   move/N.ltb_lt=>A; move/N.ltb_lt=>B; apply/N.ltb_lt;
   move: (N.lt_trans _ _ _ B A).
Qed.

Lemma FCR_rel :
  forall (A B : Blockchain),
    A = B \/ A > B \/ B > A.
Proof.
move=>x y; rewrite/FCR; case: ifP.
(* Same total work *)
- move/eqP=>A; case: ifP=>/eqP B; rewrite A eq_refl.
  + rewrite B; case: ifP; first by move=>/eqP->; left.
    rewrite eq_refl eq_sym=>->.
    case/or3P: (total_ords x y).
    by right; left.
    by move/eqP; left.
    by right;right.
  + rewrite eq_sym; case: ifP; first by move/eqP.
    move=>_; rewrite -!PeanoNat.Nat.ltb_antisym.
    case/or3P: (total_ltn_nat (Datatypes.length x) (Datatypes.length y)).
    by right; right; apply/PeanoNat.Nat.ltb_lt/ltP.
    by move/eqP.
    by right; left; apply/PeanoNat.Nat.ltb_lt/ltP.
(* Different total work *)
- rewrite eq_sym=>X; rewrite X -!N.ltb_antisym.
  case/or3P: (total_ltbN (total_work x) (total_work y)).
  by right; right.
  by move/eqP=>E; rewrite E eq_refl in X.
  by right; left.
Qed.

Lemma FCR_subchain :
  forall bc1 bc2, subchain bc1 bc2 -> bc2 >= bc1.
Proof.
move=>bc bc'; rewrite/subchain/FCR; move=>[fs][ls]=>->; case: ifP.
- case: ifP.
  + case: ifP; first by move/eqP=>->; left.
    move=>A; rewrite !List.app_length.
    rewrite PeanoNat.Nat.add_comm Plus.plus_assoc_reverse.
    have X: (Datatypes.length bc + 0 = Datatypes.length bc) by rewrite ?addn0.
    rewrite -{2}X.
    move/eqP/(Plus.plus_reg_l (Datatypes.length ls + Datatypes.length fs)%coq_nat
                              0 (Datatypes.length bc)).
    move/PeanoNat.Nat.eq_add_0=>[].
    move/List.length_zero_iff_nil=>->; move/List.length_zero_iff_nil=>->.
    by left; rewrite cats0.
  + move=>A B; right; move: A;
    rewrite -!PeanoNat.Nat.ltb_antisym !List.app_length;
    rewrite {1 2}PeanoNat.Nat.add_comm !Plus.plus_assoc_reverse=>A.
    apply/PeanoNat.Nat.ltb_spec0; apply: PeanoNat.Nat.lt_add_pos_r.
    have X: (Datatypes.length bc + 0 = Datatypes.length bc) by rewrite ?addn0.
    move: A; rewrite -{2}X; clear X.
    case Z: ((Datatypes.length ls + Datatypes.length fs)%coq_nat == 0).
    by move/eqP: Z=>->; rewrite eq_refl.
    by move=>_; apply Lt.neq_0_lt; move: Z; rewrite eq_sym=>/eqP.
(* Basically the same proof as above, but with BinNat *)
- move=>A; right; rewrite -N.ltb_antisym.
  rewrite catA !total_work_sum in A *.
  rewrite N.add_comm (N.add_comm (total_work fs) _) N.add_comm -N.add_assoc in A *.
  apply/N.ltb_spec0; apply N.lt_add_pos_r.
  case Z: ((total_work fs + total_work ls) == 0)%N.
  by move: A; move/eqP: Z=>->; rewrite N.add_0_r eq_refl.
  by case: (N.neq_0_lt_0 (total_work fs + total_work ls)%N)=>P _;
     move/eqP in Z; specialize (P Z).
Qed.

End ProofOfWork.


(* Copyright 2021 Pierre Courtieu
  This file is part of LibHyps. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it. *)
(* Lemma on determinism needs generalization. *)

Require Import FSets.FMapList FSets.FMapFacts Arith ZArith
        LibHyps.LibHyps List.
Require Import Structures.OrderedTypeEx FSets.FSetList.

Module Env := FMapList.Make(Nat_as_OT).
Module EnvFact := FMapFacts.Facts(Env).

Inductive binop := Plus | Minus | Mult.

Inductive exp : Type :=
| Val : Z -> exp
| Var : nat -> exp
| BinOp: binop -> exp -> exp -> exp.

Definition eval_op op :=
  match op with
     Plus => Z.add| Minus => Z.sub| Mult => Z.mul
  end.

Inductive Eval_exp Γ: exp -> Z -> Prop:=
  EE_val: forall v, Eval_exp Γ (Val v) v
| EE_var: forall x v, Env.MapsTo x v Γ -> Eval_exp Γ (Var x) v
| EE_binop: forall e1 e2 v1 v2 op f,
    Eval_exp Γ e1 v1
    -> Eval_exp Γ e2 v2
    -> eval_op op = f
    -> Eval_exp Γ (BinOp op e1 e2) (f v1 v2).

(* optional customization *)
Ltac rename_depth ::= constr:(3).
Local Open Scope autonaming_scope.
Import ListNotations.
Ltac rename_hyp_eval n th :=
  match th with
    Eval_exp _ ?e ?v => name(`_EE` ++ e#n ++ v#n)
  | Val ?v => name(v#(S n))
  | Var ?x => name(x#(S n))
  | BinOp ?o ?e1 ?e2 => name(o#(S 0) ++ e1#n ++ e2#n)
  | eval_op ?o ?v1 ?v2 => name(o#(S 0) ++ v1#n ++ v2#n)
  | Env.Equal ?X ?Y => name(`_EQ` ++ X#n ++ Y#n) (* shorten Equal *)
  end.
Close Scope autonaming_scope.
Ltac rename_hyp ::= rename_hyp_eval.

(* We actually need to prove modulo equivalence of environments *)
Lemma determ_nolibhyp: forall Γ Γ' e v v',
    Eval_exp Γ e v ->
    Eval_exp Γ' e v' ->
    Env.Equal Γ Γ' ->
    v = v'.
Proof.
  intros * h_EE_e_v.
  revert v'.
  induction h_EE_e_v as
      [v | x v h_MapsTo | e1 e2 v1 v2 op f h_e_v1 IH_v1 h_e_v2 IH_v2 hop];
    intros v' h_EE_e_v'.
  - inversion h_EE_e_v'.
    auto.
  - inversion h_EE_e_v'; auto; subst.
    eapply EnvFact.MapsTo_fun;eauto.
  - inversion h_EE_e_v'.
    subst.
    erewrite IH_v1;eauto.
    erewrite IH_v2;eauto.
Qed.

Lemma determ: forall Γ Γ' e v v',
    Eval_exp Γ e v ->
    Eval_exp Γ' e v' ->
    Env.Equal Γ Γ' ->
    v = v'.
Proof.
  intros until 1 /ng.
  revert v'.
  induction h_EE_e_v_; intros /sng.
  - inversion h_EE_v_v'_.
    auto.
  - inversion h_EE_x_v'_ ; auto/sng.
    eapply EnvFact.MapsTo_fun;eauto.
  - inversion h_EE_op_e1_e2_v'_ /sng.
    erewrite h_all_eq_v1_v'_;eauto.
    erewrite h_all_eq_v2_v'_;eauto.
Qed.

(*** Local Variables: ***)
(*** eval: (company-coq-mode 1) ***)
(*** End: ***)


(* Adequacy of Operational Semantics vs. Sampling Semantics *)

(* We don't bother with soundness, which is (or should be) dull *)

Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Program.
Require Import EqNat.

Require Import LiftedTypes.
Require Import MyReals.

Require Import Types.
Require Import Syntax.
Require Import SamplingSemantics.
Require Import Substitutions.
Require Import OperationalSemantics.

(* false_invert: a tactic from SF *)
(* false_invert proves any goal provided there is at least one *)
(* hypothesis H in the context that can be proved absurd by calling *)
(* inversion H. *)

Ltac false_invert :=
  intros;
  match goal with
    [ H:_ |- _ ] => solve [ inversion H ]
  end.

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

(* The Logical Relation *)

(* The relation will be defined compositionally in Otype. *)

(* First we build some combinators for the different cases. *)

Definition EqReal : (den_Mtype Real_type) ->
                    (den_Mtype Real_type) -> Prop :=
  fun v1 v2 => (v1 = v2).

(* Combinators for Mtypes:  *)

Function Real_Rel
         (d : (den_Mtype Real_type))
         (val : (Val nil (Stype Real_type)))
  :=
    exists n, val = constexp n /\ d = n.

Function Prod_Rel {ma mb : Mtype}
         (RA : (den_Mtype ma) -> (Val nil (Stype ma)) -> Prop)
         (RB : (den_Mtype mb) -> (Val nil (Stype mb)) -> Prop)
         (d  : (den_Mtype (Prod_type ma mb)))
         (val : (Val nil (Stype (Prod_type ma mb))))
  :=
    exists e1 e2, val = prodval e1 e2 /\
                  (RA (fst d) e1) /\ (RB (snd d) e2).

Fixpoint Mtype_Rel (m : Mtype)
  : (den_typeS (Stype m)) -> (Val nil (Stype m)) -> Prop :=
  match m with
  | Real_type => Real_Rel
  | Prod_type m1 m2 => Prod_Rel (Mtype_Rel m1) (Mtype_Rel m2)
  end.

(* General recipe for lifting a relation *)
(* (liftRel o R d e) iff d is bottom or d = lift(a) and e evaluates to *)
(* a value v such (Rel a v) holds*)

Function lift_Rel {o : Otype} (R : (den_typeS o) -> (Val nil o) -> Prop)
: (lifted (den_typeS o)) -> (Exp nil o) -> Prop :=
  fun d e =>
    match d with
      | bottom => True
      | lift a => exists v, ev e v /\ R a v
    end.

Definition Fun_Rel {o1 o2}
           (Rel1 : (den_typeS o1) -> (Val [] o1) -> Prop)
           (Rel2 : (lifted (den_typeS o2)) -> (Exp [] o2) -> Prop)
           (f1 : (den_typeS o1) -> (lifted (den_typeS o2)))
           (val1 : Val nil (Funtype o1 o2))
: Prop :=
  exists e, val1 = absexp e /\
  forall (a1 : den_typeS o1) (val2: Val [] o1),
    (Rel1 a1 val2) ->
    (Rel2 (f1 a1) (ap_Se (subst1 val2) e)).

Definition Meas_Rel
           (m : Mtype)
           (s : den_typeS (Meastype m))
           (c : Val nil (Meastype m)) : Prop :=
  forall (u:Unit),
    match (s u) with
      | bottom => True
      | lift (a,w) => exists c', evs u c c' w /\ Mtype_Rel m a c'
    end.

(* Now the main relation simply branches depending on its Otype argument: *)

Fixpoint Rel {o : Otype} : (den_typeS o) -> (Val nil o) -> Prop :=
  match o with
  | Stype m => Mtype_Rel m
  | Funtype o1 o2 => Fun_Rel (@Rel o1)  (lift_Rel (@Rel o2))
  | Meastype m => Meas_Rel m
  end.

(* Extend the relation to environments based on a type environment G *)

Fixpoint Rel_Env {G} : (den_env G) -> (Subst G nil) -> Prop :=
  match G with
    | nil => fun r s => True
    | (o :: G') => fun (r : den_env (o::G')) s =>
                     Rel (fst r) (hd_subst s)
                     /\ Rel_Env (snd r) (tl_subst s)
  end.

Lemma lookup_preserves_Rel : forall G (o : Otype)
                       (var : Var G o)
                       (r : den_env G)
                       (s : Subst G nil),
    Rel_Env r s -> Rel (apply_env r var) (s _ var).
Proof.
  intros.
  induction G as [| o' G'].
  (* G = [] *)
  inversion var.
  (* G = o' :: G' *)
  induction var as [| G''].
  (* var = var_0 *)
  simpl.
  inversion H.
  apply H0.
  (* var = var_S v' *)
  apply (IHvar (snd r) (tl_subst s)).
  apply H.
  intros.
  apply IHG'.
  apply H0.
Qed.

Hint Resolve lookup_preserves_Rel.

Lemma extend_env_preserves_Rel :
  forall (o: Otype) G r (s : Subst G nil) (d : den_typeS o) (val: Val nil o),
    Rel_Env r s -> Rel d val
    -> Rel_Env (cons_env d r) (cons_subst val s).
Proof.
  intros.
  simpl.
  split.
  apply H0.
  apply H.
Qed.

Lemma bind_preserves_Rel :
  forall m m'
         (s1 : den_typeS (Meastype m))
         (f : (den_typeS (Stype m))
              -> lifted (den_typeS (Meastype m')))
         c1 c2,
    Meas_Rel m s1 c1 ->
    Fun_Rel (Rel ) (lift_Rel (Meas_Rel m')) f c2 ->
    Meas_Rel m' (bindopS s1 f) (bindval c1 c2).
Proof.
  intros.
  unfold Meas_Rel.
  intros.
  destruct (bindopS s1 f u) as [|b]  eqn: f_u; try false_invert; auto.
  unfold bindopS in f_u.
  destruct (s1 (left_half u)) eqn: s1_uL; try false_invert; simpl in *; auto.

  destruct b.
  unfold prod_curry in f_u.
  destruct p.
  destruct (f d0) as [| s2] eqn: f_d; try false_invert; auto.
  simpl in f_u.
  destruct (s2 (right_half u)) as [| b'] eqn: s2_uR; try false_invert; simpl in *; auto.
  unfold prod_curry in f_u.
  destruct b'.
  inversion f_u; clear f_u.
  (* rewrite H2 in *. *)
  subst.

  (* now we have all the denotations, next let's work on the
     reductions *)

  (* First reduction: evs (left_half u) c1 c3 *)
  unfold Meas_Rel in H.
  specialize (H (left_half u)).
  rewrite s1_uL in H; simpl in H.
  inversion H as [c3]; clear H.
  inversion H1 as [Red1a Red1b]; clear H1.

  (* second reduction: ev (appexp (valexp c2) (valexp c3)) c4 *)
  (* c2: is a function, so it has to be an abstraction *)

  unfold Fun_Rel in H0.
  inversion H0 as [e]; clear H0.
  inversion H; clear H.
  specialize (H1 _ _ Red1b).
  unfold lift_Rel in H1.
  rewrite f_d in *; simpl in *.
  inversion H1 as [c4]; clear H1.
  inversion H; clear H.

  assert (Red2: ev (appexp (valexp c2) (valexp c3)) c4).
  assert (Red2a: ev (valexp c2) c2) by apply ev_val.
  assert (Red2b: ev (valexp c3) c3) by apply ev_val.
  rewrite H0 in *.
  apply (ev_app Red2a Red2b H1).

  (* now for the last step *)
  unfold Meas_Rel in H2.
  specialize (H2 (right_half u)).
  rewrite s2_uR in *.
  inversion H2 as [c5]; clear H2.
  inversion H as [Red3a Red3b]; clear H.
  exists c5.
  split.
  apply (evs_bind Red1a Red2 Red3a).
  apply Red3b.
Qed.

Hint Resolve bind_preserves_Rel.

Lemma bind_preserves_Rel' :
  forall m m'
         (s1 : den_typeS (Meastype m))
         (f : (den_typeS (Stype m))
              -> lifted (den_typeS (Meastype m')))
         c1 c2,
    Meas_Rel m s1 c1 ->
    Fun_Rel (Rel ) (lift_Rel (Meas_Rel m')) f c2 ->
    Meas_Rel m' (bindopS s1 f) (bindval c1 c2).
Proof.
  intros.
  unfold Meas_Rel.
  intros.
  destruct (bindopS s1 f u) as [|b]  eqn: f_u; try false_invert; auto.
  unfold bindopS in f_u.
  destruct (s1 (left_half u)) eqn: s1_uL; try false_invert; simpl in *; auto.

  destruct b.
  unfold prod_curry in f_u.
  destruct p.
  destruct (f d0) as [| s2] eqn: f_d; try false_invert; auto.
  simpl in f_u.
  destruct (s2 (right_half u)) as [| b'] eqn: s2_uR; try false_invert; simpl in *; auto.
  unfold prod_curry in f_u.
  destruct b'.
  inversion f_u; clear f_u.
  subst.

  (* now we have all the denotations, next let's work on the
     reductions *)

  (* First reduction: evs (left_half u) c1 c3 *)
  unfold Meas_Rel in H.
  specialize (H (left_half u)).
  rewrite s1_uL in H; simpl in H.
  inversion H; clear H.
  inversion H1 as [Red1a Red1b]; clear H1.

  (* second reduction: ev (appexp (valexp c2) (valexp c3)) c4 *)
  (* c2: is a function, so it has to be an abstraction *)

  unfold Fun_Rel in H0.
  inversion H0 as [e]; clear H0.
  inversion H; clear H.

  specialize (H1 _ _ Red1b).
  unfold lift_Rel in H1.
  rewrite f_d in *; simpl in *.
  inversion H1; clear H1.
  inversion H; clear H.

  (* finish unfolding *)
  unfold Meas_Rel in H2.
  specialize (H2 (right_half u)).
  rewrite s2_uR in *.
  inversion H2; clear H2.
  inversion H.

  (* Now patch the pieces together.  Coq is actually good at this! *)

  subst.
  eauto using evs_bind, ev_app, ev_val.

  (* split. *)
  (* eapply evs_bind. *)
  (* eassumption. *)

  (* eapply ev_app. *)
  (* subst. *)
  (* apply ev_val. *)
  (* apply ev_val. *)
  (* eassumption. *)
  (* eassumption. *)
  (* assumption. *)
Qed.

Lemma return_preserves_Rel :
  forall m (v : den_typeS (Stype m)) (c : Val nil (Stype m)),
         Rel v c ->
         Meas_Rel m (returnopS v) (returnval c).
Proof.
  intros.
  unfold returnopS.
  unfold Meas_Rel.
  intros.
  exists c.
  split.
  apply evs_return.
  apply H.
Qed.

Hint Resolve return_preserves_Rel.

Lemma unif_preserves_Rel :
  Meas_Rel _ uniformopS uniformval.
Proof.
  unfold Meas_Rel.
  intros.
  unfold uniformopS.
  exists (constexp (unit_real u)).
  split.
  apply evs_unif.
  unfold Mtype_Rel.
  unfold Real_Rel.
  eauto.
Qed.

Hint Resolve unif_preserves_Rel.

Lemma dist_preserves_Rel :
  forall r,
    Meas_Rel _ (distvalS r) (distval (constexp r)).
Proof.
  intros.
  unfold Meas_Rel.
  intros.
  simpl.
  eexists.
  split.
  apply evs_dist.
  unfold Real_Rel.
  eauto.
Qed.

(* This should really be of the form
  forall d v, Rel d v -> Meas_Rel _ (distvalS d) (distval v)

 *)

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

(* The Fundamental Theorem *)

Definition Fun_Thm_Exp G o  (exp: Exp G o) :=
  forall
         (r : den_env G)
         (s : Subst G nil),
    Rel_Env r s
    -> lift_Rel (@Rel o) (den_expS exp r) (ap_Se s exp).

Definition Fun_Thm_Val G o   (val: Val G o):=
  forall

         (r : den_env G)
         (s : Subst G nil),
    Rel_Env r s
    -> @Rel o (den_valS val r) (ap_Sv s val).

(* Tactics for proving the fundamental theorem *)

(* Ltac helpers *)
Ltac invert_ex :=
  repeat
    match goal with
    | [ H : exists _, _ |- _ ] => inversion H; clear H; intuition
    end.

Ltac solve_ex := invert_ex; try (eexists; intuition).

Ltac auto_specialize :=
  repeat
    match goal with
    | [ H : forall x : ?a, _, v : ?a |- _ ] => specialize H with (x:=v)
    | [ H : ?a -> _, v : ?a |- _ ] =>
      let Hv := fresh H in
      apply H in v as Hv; clear H
    end.

Ltac destruct_lift :=
  match goal with
  | [ H : lift_Rel _ ?x _ |- _ ] =>
    match x with
    | bottom => fail 1
    | lift _ => fail 1
    | _ => destruct x
    end
  end.

Theorem Fund_Thm: forall G o exp, @Fun_Thm_Exp G o exp.
Proof.
  apply (exp_val_rec Fun_Thm_Exp Fun_Thm_Val);
  unfold Fun_Thm_Exp;
  unfold Fun_Thm_Val;
  simpl; intros;
  try solve [auto_specialize; eauto;
                  repeat destruct_lift;
                  unfold Prod_Rel, lift_Rel in *;
                  solve_ex; subst; eauto].

  { (* appexp e e0 *)
    auto_specialize.
    repeat destruct_lift; eauto.
    simpl in *.
    invert_ex.
    destruct (d0 d) eqn: d0_d; unfold lift_Rel; auto.
    unfold Fun_Rel in *.
    invert_ex.
    subst.
    auto_specialize.
    rewrite d0_d in *.
    simpl in H4.
    invert_ex.
    eauto.
    }

  (* Now on to values: *)

  { (* varexp *)
    apply lookup_preserves_Rel.
    assumption.
  }

  { (* absexp *)
    unfold Fun_Rel.
    solve_ex.
    replace (ap_Se (subst1 val2) (ap_Se (shift_subst s) e))
    with (ap_Se (cons_subst val2 s) e)
      by (rewrite <- cSS_subst1, <- ap_cSS_e; auto).
    auto.
    }

  { (* distval *)
    auto_specialize.
    unfold Real_Rel in H1.
    invert_ex.
    subst.
    rewrite H1.
    apply dist_preserves_Rel.
    }
Qed.