(***************************************************************************
* Core Generic Environments                                                *
*                                                                          *
* Emmanuel Polonowski, April 2011, Coq v8.3                                *
*                                                                          *
* (Inspired by the work of A. Chargueraud :                                *
*  http://www.chargueraud.org/softs/ln/index.php)                          *
***************************************************************************)

Require Import Utf8.
Set Implicit Arguments.

(* ********************************************************************** *)
(** * Module Type of an implementation of environments                    *)

Require Import Equalities.
Require Import List.

Module Type CoreGenericEnvironmentType (VarType : UsualDecidableType).

Import VarType.

Definition TVar := VarType.t.

(* ---------------------------------------------------------------------- *)
(** ** Definitions and Notations *)

(** gen_env A is an environment that binds variables to values of type A. *)
Parameter gen_env : Type -> Type.

Section CoreDefinitions.

Variable A B : Type.

(** The decidability of equality on keys (variables) is imported from Var.*)
Definition eq_keys_dec := VarType.eq_dec.

(** Empty environment. *)
Parameter empty : gen_env A.

(** Environment build upon explicit associations. *)
Parameter single : TVar -> A -> gen_env A.
Parameter singles : list TVar -> list A -> gen_env A.

(** Concatenation of environment (the second one binds first). *)
Parameter concat : gen_env A -> gen_env A -> gen_env A.

(** The main operation on environment, get the type of a variable. *)
Parameter get : TVar -> gen_env A -> option A.

(** Domain and image of an environment. *)
Parameter dom : gen_env A -> list TVar.
Parameter img : gen_env A -> list A.

(** Check the occurence of variable(s) in an environment. *)
Axiom belongs : TVar -> gen_env A -> Prop.
Axiom all_belongs : list TVar -> gen_env A -> Prop.

(** Check the non-occurence of variable(s) in an environment. *)
Axiom notin  : TVar -> gen_env A -> Prop.
Axiom all_notin : list TVar -> gen_env A -> Prop.

(** Map function on types. *)
Parameter map : (A -> B) -> gen_env A -> gen_env B.

(** Updating of types with bindings of another environment. *)
Parameter update_one : gen_env A -> TVar -> A -> gen_env A.
Parameter update : gen_env A -> gen_env A -> gen_env A.

(** Remove a binding from an environment. *)
Parameter remove : TVar -> gen_env A -> gen_env A.
Parameter all_remove : list TVar -> gen_env A -> gen_env A.

(** The ok predicate states that the bindings are pairwise distinct,
   i.e. each variable appears only once. *)
Inductive ok : gen_env A -> Prop :=
| ok_nil : ok empty
| ok_cons : forall x v F, ok F ∧ notin x F -> ok (concat F (single x v))
.

End CoreDefinitions.

(** [x ∶ v] is the notation for a singleton environment mapping x to v. *)

Notation "x '∶' v" := (single x v)
  (at level 63) : gen_env_scope.

(** [xs ∷ vs] is the notation for an environment mapping xs to vs. *)

Notation "xs '∷' vs" := (singles xs vs)
  (at level 63) : gen_env_scope.

(** [E & F] is the notation for concatenation of E and F. *)

Notation "E '&' F" := (concat E F)
  (at level 65, left associativity) : gen_env_scope.

(** [E ∖ { x } ] is the notation for removing x from E. *)

Notation "E '∖' '{' x '}'" := (remove x E)
  (at level 64, left associativity) : gen_env_scope.

(** [E ∖ xs ] is the notation for removing xs from E. *)

Notation "E '∖' xs" := (all_remove xs E)
  (at level 64, left associativity) : gen_env_scope.

(** [E '[' x '<-' v ']' ] is the notation for updating x in E with v. *)

Notation "E '[' x '<-' v ']'" := (update_one E x v)
  (at level 65, left associativity) : gen_env_scope.

(** [E ::= F] is the notation for updating of E with F. *)

Notation "E '::=' F" := (update E F)
  (at level 65, left associativity) : gen_env_scope.

(** [x ∈ E] to be read x is bound in E. *)

Notation "x '∈' E" := (belongs x E)
  (at level 67) : gen_env_scope.

(** [xs ⊂ E] to be read xs are bound in E. *)

Notation "xs '⊂' E" := (all_belongs xs E)
  (at level 67) : gen_env_scope.

(** [x '∉' E] to be read x is unbound in E. *)

Notation "x '∉' E" := (notin x E)
  (at level 67) : gen_env_scope.

(** [xs '⊄' E] to be read xs are unbound in E. *)

Notation "xs '⊄' E" := (all_notin xs E)
  (at level 67) : gen_env_scope.

Bind Scope gen_env_scope with gen_env.
Delimit Scope gen_env_scope with gen_env.
Local Open Scope gen_env_scope.

(* ---------------------------------------------------------------------- *)
(** ** Properties *)

Section Properties.
Implicit Types x y : TVar.
Implicit Types xs ys : list TVar.

(* ---------------------------------------------------------------------- *)
(** *** Primary properties *)

(** Induction scheme over environments. *)
Axiom env_ind : forall A, forall P : gen_env A -> Prop,
  (P (@empty A)) ->
  (forall (E : gen_env A) x (v : A), P E -> P (E & (x ∶ v))) ->
  (forall (E : gen_env A), P E).

(* ---------------------------------------------------------------------- *)
(** **** Properties of singulars *)

(** Environment built from lists. *)
Axiom singles_empty : forall A,
  nil ∷ nil = (@empty A).
Axiom singles_cons : forall A x xs (v : A) (vs : list A),
  (x :: xs) ∷ (v :: vs) = (xs ∷ vs) & (x ∶ v).

(* ---------------------------------------------------------------------- *)
(** **** Properties of concatenation *)

(** Concatenation admits empty as neutral element, and is associative. *)
Axiom concat_empty_r : forall A (E : gen_env A),
  E & (@empty A) = E.
Axiom concat_empty_l : forall A (E : gen_env A),
  (@empty A) & E = E.
Axiom concat_assoc : forall A (E F G : gen_env A),
  E & (F & G) = (E & F) & G.

(* ---------------------------------------------------------------------- *)
(** **** Properties of get *)

(** Get is None on empty. *)
Axiom get_empty : forall A x,
  get x (@empty A) = None.

(** Get is Some when it binds. *)
Axiom get_single_eq : forall A x y (v : A),
  x = y ->
  get x (y ∶ v) = Some v.
Axiom get_single_eq_inv : forall A x y (v w : A),
  get x (y ∶ w) = Some v ->
  x = y /\ v = w.

(** Get is decidable. *)
Axiom get_dec : forall A x (E : gen_env A),
   { v : A | get x E = Some v } + { get x E = None }.

(** Get and concatenation. *)
Axiom get_concat_r : forall A x y (v : A) (E : gen_env A),
  x = y ->
  get x (E & (y ∶ v)) = Some v.
Axiom get_concat_l : forall A x y (v : A) (E : gen_env A),
  x <> y ->
  get x (E & (y ∶ v)) = get x E.
Axiom get_concat_inv : forall A x y (v w : A) (E : gen_env A),
  get x (E & (y ∶ v)) = Some w ->
  (x = y /\ v = w) \/ (x <> y /\ get x E = Some w).

(* ---------------------------------------------------------------------- *)
(** **** Properties of dom *)

(** Dom builds a list. *)
Axiom dom_empty : forall A,
  dom (@empty A) = nil.
Axiom dom_empty_inv : forall A (E : gen_env A),
  dom (E) = nil ->
  E = (@empty A).
Axiom dom_single : forall A x (v : A),
  dom (x ∶ v) = (x :: nil).
Axiom dom_singles : forall A xs (vs : list A),
  length xs = length vs ->
  dom (xs ∷ vs) = xs.
Axiom dom_singles_incl : forall A xs (vs : list A),
  List.incl (dom (xs ∷ vs)) xs.
Axiom dom_concat : forall A (E F : gen_env A),
  dom (E & F) = List.app (dom F) (dom E).

(* ---------------------------------------------------------------------- *)
(** **** Properties of img *)

(** Img builds a list. *)
Axiom img_empty : forall A,
  img (@empty A) = nil.
Axiom img_empty_inv : forall A (E : gen_env A),
  img (E) = nil ->
  E = (@empty A).
Axiom img_single : forall A x (v : A),
  img (x ∶ v) = v :: nil.
Axiom img_singles : forall A xs (vs : list A),
  length xs = length vs ->
  img (xs ∷ vs) = vs.
Axiom img_singles_incl : forall A xs (vs : list A),
  List.incl (img (xs ∷ vs)) vs.
Axiom img_concat : forall A (E F : gen_env A),
  img (E & F) = List.app (img F) (img E).

(** Dom and img builds identity. *)
Axiom dom_img_id : forall A (E : gen_env A),
  (dom E) ∷ (img E) = E.
Axiom length_dom_img_eq : forall A (E : gen_env A),
  length (dom E) = length (img E).

(* ---------------------------------------------------------------------- *)
(** **** Properties of belongs *)

(** Belongs is false on empty environments. *)
Axiom belongs_empty : forall A x,
  x ∈ (@empty A) ->
  False.

(** Belongs in singular(s). *)
Axiom belongs_single : forall A x y (v : A),
  x = y ->
  x ∈ (y ∶ v).
Axiom belongs_single_inv : forall A x y (v : A),
  x ∈ (y ∶ v) ->
  x = y.
Axiom belongs_singles : forall A x xs (vs : list A),
  length xs = length vs ->
  List.In x xs ->
  x ∈ (xs ∷ vs).
Axiom belongs_singles_inv : forall A x xs (vs : list A),
  length xs = length vs ->
  x ∈ (xs ∷ vs) ->
  List.In x xs.

(** Belongs and concatenation. *)
Axiom belongs_concat_l : forall A x (F G : gen_env A),
  x ∈ F ->
  x ∈ (F & G).
Axiom belongs_concat_r : forall A x (F G : gen_env A),
  x ∈ F ->
  x ∈ (G & F).
Axiom belongs_concat_inv : forall A x (F G : gen_env A),
  x ∈ (F & G) ->
  x ∈ F ∨ x ∈ G.

(** Belongs and dom. *)
Axiom belongs_dom : forall A x (E : gen_env A),
  x ∈ E ->
  List.In x (dom E).
Axiom belongs_dom_inv : forall A x (E : gen_env A),
  List.In x (dom E) ->
  x ∈ E.

(* ---------------------------------------------------------------------- *)
(** **** Properties of all_belongs *)

(** All_belongs and belongs. *)
Axiom all_belongs_def : forall A xs (E : gen_env A),
  (forall x, List.In x xs -> x ∈ E) ->
  xs ⊂ E.
Axiom all_belongs_def_inv : forall A xs (E : gen_env A),
  xs ⊂ E ->
  (forall x, List.In x xs -> x ∈ E).
Axiom all_belongs_belongs : forall A x xs (E : gen_env A),
  (x :: xs) ⊂ E ->
  x ∈ E ∧ xs ⊂ E.
Axiom belongs_all_belongs : forall A x xs (E : gen_env A),
  x ∈ E ∧ xs ⊂ E ->
  (x :: xs) ⊂ E.

(** All_belongs is false on empty environments. *)
Axiom all_belongs_empty : forall A xs,
  xs ⊂ (@empty A) ->
  xs = nil.
Axiom all_belongs_nil : forall A (E : gen_env A),
  nil ⊂ E.

(** All_belongs in singular(s). *)
Axiom all_belongs_single : forall A xs y (v : A),
  xs = y :: nil ->
  xs ⊂ (y ∶ v).
Axiom all_belongs_single_inv : forall A xs y (v : A),
  length xs = 1 ->
  xs ⊂ (y ∶ v) ->
  xs = y :: nil.
Axiom all_belongs_singles : forall A xs ys (vs : list A),
  length ys = length vs ->
  List.incl xs ys ->
  xs ⊂ (ys ∷ vs).
Axiom all_belongs_singles_inv : forall A xs ys (vs : list A),
  xs ⊂ (ys ∷ vs) ->
  List.incl xs ys.

(** All_belongs and concatenation. *)
Axiom all_belongs_concat_l : forall A xs (F G : gen_env A),
  xs ⊂ F ->
  xs ⊂ (F & G).
Axiom all_belongs_concat_r : forall A xs (F G : gen_env A),
  xs ⊂ F ->
  xs ⊂ (G & F).

(** All_belongs and dom. *)
Axiom all_belongs_dom : forall A xs (E : gen_env A),
  xs ⊂ E ->
  List.incl xs (dom E).
Axiom all_belongs_dom_inv : forall A xs (E F : gen_env A),
  List.incl xs (dom E) ->
  xs ⊂ E.

(* ---------------------------------------------------------------------- *)
(** **** Properties of notin *)

(** Notin and belongs. *)
Axiom notin_belongs : forall A x (E : gen_env A),
  x ∉ E ->
  ¬ x ∈ E.
Axiom belongs_notin : forall A x (E : gen_env A),
  x ∈ E ->
  ¬ x ∉ E.
Axiom not_belongs_notin : forall A x (E : gen_env A),
  ¬ x ∈ E ->
  x ∉ E.
Axiom notin_belongs_neq : forall A x y (E : gen_env A),
  x ∈ E -> y ∉ E ->
  x <> y.

(** Notin is true on empty environments. *)
Axiom notin_empty : forall A x,
  x ∉ (@empty A).

(** Notin in singular(s). *)
Axiom notin_single : forall A x y (v : A),
  x <> y ->
  x ∉ (y ∶ v).
Axiom notin_single_inv : forall A x y (v : A),
  x ∉ (y ∶ v) ->
  x <> y.
Axiom notin_singles : forall A x xs (vs : list A),
  ¬ List.In x xs ->
  x ∉ (xs ∷ vs).
Axiom notin_singles_inv : forall A x xs (vs : list A),
  length xs = length vs ->
  x ∉ (xs ∷ vs) ->
  ¬ List.In x xs.

(** Notin and concatenation. *)
Axiom notin_concat : forall A x (F G : gen_env A),
  x ∉ F -> x ∉ G ->
  x ∉ (F & G).
Axiom notin_concat_inv : forall A x (F G : gen_env A),
  x ∉ (F & G) ->
  x ∉ F ∧ x ∉ G.

(** Notin and dom. *)
Axiom notin_dom : forall A x (E : gen_env A),
  x ∉ E ->
  ¬ List.In x (dom E).
Axiom notin_dom_inv : forall A x (E F : gen_env A),
  ¬ List.In x (dom E) ->
  x ∉ E.

(* ---------------------------------------------------------------------- *)
(** **** Properties of all_notin *)

(** All_notin is true on empty lists. *)
Axiom all_notin_empty_l : forall A (E : gen_env A),
  nil ⊄ E.

(** All_notin and notin. *)
Axiom all_notin_def : forall A xs (E : gen_env A),
  (forall x, List.In x xs -> x ∉ E) ->
  xs ⊄ E.
Axiom all_notin_def_inv : forall A xs (E : gen_env A),
  xs ⊄ E ->
  (forall x, List.In x xs -> x ∉ E).
Axiom all_notin_notin : forall A x xs (E : gen_env A),
  (x :: xs) ⊄ E ->
  x ∉ E ∧ xs ⊄ E.
Axiom notin_all_notin : forall A x xs (E : gen_env A),
  x ∉ E ∧ xs ⊄ E ->
  (x :: xs) ⊄ E.

(** All_notin and belongs. *)
Axiom all_notin_belongs_neq : forall A x ys (E : gen_env A),
  x ∈ E -> ys ⊄ E ->
  ¬ List.In x ys.

(** All_notin is true on empty environments. *)
Axiom all_notin_empty_r : forall A xs,
  xs ⊄ (@empty A).

(** All_notin in singular(s). *)
Axiom all_notin_single : forall A xs y (v : A),
  ¬ List.In y xs ->
  xs ⊄ (y ∶ v).
Axiom all_notin_single_inv : forall A xs y (v : A),
  xs ⊄ (y ∶ v) ->
  ¬ List.In y xs.
Axiom all_notin_singles : forall A xs ys (vs : list A),
  List.Forall (fun x => ¬ List.In x ys) xs ->
  xs ⊄ (ys ∷ vs).
Axiom all_notin_singles_inv : forall A xs ys (vs : list A),
  length ys = length vs ->
  xs ⊄ (ys ∷ vs) ->
  List.Forall (fun x => ¬ List.In x ys) xs.

(** All_notin and concatenation. *)
Axiom all_notin_concat : forall A xs (F G : gen_env A),
  xs ⊄ F -> xs ⊄ G ->
  xs ⊄ (F & G).
Axiom all_notin_concat_inv : forall A xs (F G : gen_env A),
  xs ⊄ (F & G) ->
  xs ⊄ F ∧ xs ⊄ G.

(** All_notin and dom. *)
Axiom all_notin_dom : forall A xs (E : gen_env A),
  xs ⊄ E ->
  List.Forall (fun x => ¬ List.In x (dom E)) xs.
Axiom all_notin_dom_inv : forall A xs (E : gen_env A),
  List.Forall (fun x => ¬ List.In x (dom E)) xs ->
  xs ⊄ E.

(* ---------------------------------------------------------------------- *)
(** **** Properties of map *)

(** Map is applied on type(s). *)
Axiom map_empty : forall A B (f : A -> B),
  map f (@empty A) = (@empty B).
Axiom map_single : forall A B (f : A -> B) x (v : A),
  map f (x ∶ v) = x ∶ (f v).
Axiom map_singles : forall A B (f : A -> B) xs (vs : list A),
  map f (xs ∷ vs) = xs ∷ (List.map f vs).

(** Map commutes with concatenation. *)
Axiom map_concat : forall A B (f : A -> B) (E F : gen_env A),
  map f (E & F) = (map f E) & (map f F).

(** Dom is unchanged by map. *)
Axiom dom_map : forall A B (E : gen_env A) (f : A -> B),
  dom (map f E) = dom E.

(** Belongs commutes with map. *)
Axiom belongs_map : forall A B x (E : gen_env A) (f : A -> B),
  x ∈ E ->
  x ∈ (map f E).
Axiom belongs_map_inv : forall A B x (E : gen_env A) (f : A -> B),
  x ∈ (map f E) ->
  x ∈ E.

(** All_belongs commutes with map. *)
Axiom all_belongs_map : forall A B xs (E : gen_env A) (f : A -> B),
  xs ⊂ E ->
  xs ⊂ (map f E).
Axiom all_belongs_map_inv : forall A B xs (E : gen_env A) (f : A -> B),
  xs ⊂ (map f E) ->
  xs ⊂ E.

(** Notin commutes with map. *)
Axiom notin_map : forall A B x (E : gen_env A) (f : A -> B),
  x ∉ E ->
  x ∉ (map f E).
Axiom notin_map_inv : forall A B x (E : gen_env A) (f : A -> B),
  x ∉ (map f E) ->
  x ∉ E.

(** All_notin commutes with map. *)
Axiom all_notin_map : forall A B xs (E : gen_env A) (f : A -> B),
  xs ⊄ E ->
  xs ⊄ (map f E).
Axiom all_notin_map_inv : forall A B xs (E : gen_env A) (f : A -> B),
  xs ⊄ (map f E) ->
  xs ⊄ E.

(** Ok commutes with map. *)
Axiom ok_map : forall A B (E : gen_env A) (f : A -> B),
  ok E ->
  ok (map f E).
Axiom ok_map_inv : forall A B (E : gen_env A) (f : A -> B),
  ok (map f E) ->
  ok E.

(* ---------------------------------------------------------------------- *)
(** **** Properties of update_one *)

(** Update_one is identity on empty environments. *)
Axiom update_one_empty : forall A x (v : A),
  (@empty A) [x <- v] = (@empty A).

(** Update_one with single. *)
Axiom update_one_single : forall A x y (v w : A),
  x = y ->
  (x ∶ v) [y <- w] = (x ∶ w).
Axiom update_one_single_neq : forall A x y (v w : A),
  x <> y ->
  (x ∶ v) [y <- w] = (x ∶ v).

(** Update_one and  concatenation. *)
Axiom update_one_concat_r : forall A x (v : A) (E F : gen_env A),
  x ∈ F ->
  (E & F) [x <- v] = E & (F [x <- v]).
Axiom update_one_concat_l : forall A x (v : A) (E F : gen_env A),
  x ∉ F ->
  (E & F) [x <- v] = (E [x <- v]) & F.

(** Dom is unchanged by updating. *)
Axiom dom_update_one : forall A x (v : A) (E : gen_env A),
  dom (E [x <- v]) = dom E.

(** Belongs commutes with update. *)
Axiom belongs_update_one : forall A x y (v : A) (E : gen_env A),
  y ∈ E ->
  y ∈ (E [x <- v]).
Axiom belongs_update_one_inv : forall A x y (v : A) (E : gen_env A),
  y ∈ (E [x <- v]) ->
  y ∈ E.

(** All_belongs commutes with update. *)
Axiom all_belongs_update_one : forall A x xs (v : A) (E : gen_env A),
  xs ⊂ E ->
  xs ⊂ (E [x <- v]).
Axiom all_belongs_update_one_inv : forall A x xs (v : A) (E : gen_env A),
  xs ⊂ (E [x <- v]) ->
  xs ⊂ E.

(** Notin commutes with update. *)
Axiom notin_update_one : forall A x y (v : A) (E : gen_env A),
  y ∉ E ->
  y ∉ (E [x <- v]).
Axiom notin_update_one_inv : forall A x y (v : A) (E : gen_env A),
  y ∉ (E [x <- v]) ->
  y ∉ E.

(** All_notin commutes with update. *)
Axiom all_notin_update_one : forall A x xs (v : A) (E : gen_env A),
  xs ⊄ E ->
  xs ⊄ (E [x <- v]).
Axiom all_notin_update_one_inv : forall A x xs (v : A) (E : gen_env A),
  xs ⊄ (E [x <- v]) ->
  xs ⊄ E.

(** Update is identity when the domains are disjoints. *)
Axiom update_one_notin : forall A x (v : A) (E : gen_env A),
  x ∉ E ->
  E [x <- v] = E.

(** Update commutes with map. *)
Axiom map_update_one : forall A B (f : A -> B) x (v : A) (E : gen_env A),
  map f (E [x <- v]) = (map f E) [x <- f v].

(** Ok commutes with update. *)
Axiom ok_update_one : forall A x (v : A) (E : gen_env A),
  ok E ->
  ok (E [x <- v]).
Axiom ok_update_one_inv : forall A x (v : A) (E : gen_env A),
  ok (E [x <- v]) ->
  ok E.

(* ---------------------------------------------------------------------- *)
(** **** Properties of update *)

(** Update is identity in presence of empty environments. *)
Axiom update_empty_r : forall A (E : gen_env A),
  E ::= (@empty A) = E.
Axiom update_empty_l : forall A (E : gen_env A),
  (@empty A) ::= E = (@empty A).

(** Update with single. *)
Axiom update_update_one : forall A x (v : A) (E : gen_env A),
  E ::= (x ∶ v) = E [x <- v].
Axiom update_single_single : forall A x y (v w : A),
  x = y ->
  (x ∶ v) ::= (y ∶ w) = (x ∶ w).
Axiom update_single_single_neq : forall A x y (v w : A),
  x <> y ->
  (x ∶ v) ::= (y ∶ w) = (x ∶ v).

(** Update commutes with concatenation on the right. *)
Axiom update_concat_r : forall A (E F G : gen_env A),
  E ::= (F & G) = (E ::= F) ::= G.

(** Dom is unchanged by updating. *)
Axiom dom_update : forall A (E F : gen_env A),
  dom (E ::= F) = dom E.

(** Belongs commutes with update. *)
Axiom belongs_update : forall A x (E F : gen_env A),
  x ∈ E ->
  x ∈ (E ::= F).
Axiom belongs_update_inv : forall A x (E F : gen_env A),
  x ∈ (E ::= F) ->
  x ∈ E.

(** All_belongs commutes with update. *)
Axiom all_belongs_update : forall A xs (E F : gen_env A),
  xs ⊂ E ->
  xs ⊂ (E ::= F).
Axiom all_belongs_update_inv : forall A xs (E F : gen_env A),
  xs ⊂ (E ::= F) ->
  xs ⊂ E.

(** Notin commutes with update. *)
Axiom notin_update : forall A x (E F : gen_env A),
  x ∉ E ->
  x ∉ (E ::= F).
Axiom notin_update_inv : forall A x (E F : gen_env A),
  x ∉ (E ::= F) ->
  x ∉ E.

(** All_notin commutes with update. *)
Axiom all_notin_update : forall A xs (E F : gen_env A),
  xs ⊄ E ->
  xs ⊄ (E ::= F).
Axiom all_notin_update_inv : forall A xs (E F : gen_env A),
  xs ⊄ (E ::= F) ->
  xs ⊄ E.

(** Update is identity when the domains are disjoints. *)
Axiom update_notin : forall A (E F : gen_env A),
  (dom F) ⊄ E ->
  E ::= F = E.

(** Update commutes with map. *)
Axiom map_update : forall A B (f : A -> B) (E F : gen_env A),
  map f (E ::= F) = (map f E) ::= (map f F).

(** Ok commutes with update. *)
Axiom ok_update : forall A (E F : gen_env A),
  ok E ->
  ok (E ::= F).
Axiom ok_update_inv : forall A (E F : gen_env A),
  ok (E ::= F) ->
  ok E.

(* ---------------------------------------------------------------------- *)
(** **** Properties of remove *)

(** Remove is identity on empty environments. *)
Axiom remove_empty : forall A x,
  (@empty A) ∖ {x} = (@empty A).

(** Remove on singular. *)
Axiom remove_single_eq : forall A x y (v : A),
  x = y ->
  (x ∶ v) ∖ {y} = (@empty A).
Axiom remove_single_neq : forall A x y (v : A),
  x <> y ->
  (x ∶ v) ∖ {y} = (x ∶ v).

(** Remove and notin and belongs. *)
Axiom remove_notin : forall A x (E : gen_env A),
  x ∉ E ->
  E ∖ {x} = E.
Axiom notin_remove_notin : forall A x y (E : gen_env A),
  x ∉ E ->
  x ∉ (E ∖ {y}).
Axiom all_notin_remove_notin : forall A xs y (E : gen_env A),
  xs ⊄ E ->
  xs ⊄ (E ∖ {y}).
Axiom belongs_remove : forall A x y (E : gen_env A),
  x <> y -> x ∈ E ->
  x ∈ (E ∖ {y}).
Axiom belongs_remove_inv : forall A x y (E : gen_env A),
  ok E ->
  x ∈ (E ∖ {y}) -> x <> y.

(** Remove and concatenation. *)
Axiom remove_belongs_concat_r : forall A x (E F : gen_env A),
  x ∈ F ->
  (E & F) ∖ {x} = E & (F ∖ {x}).
Axiom remove_belongs_concat_l : forall A x (E F : gen_env A),
  x ∉ F ->
  (E & F) ∖ {x} = (E ∖ {x}) & F.

(** Remove and belongs and all_belongs. *)
Axiom remove_ok_notin : forall A x (E : gen_env A),
  ok E ->
  x ∉ (E ∖ {x}).
Axiom remove_all_belongs : forall A x xs (F : gen_env A),
  ¬ List.In x xs -> (x :: xs) ⊂ F ->
  xs ⊂ (F ∖ {x}).

(** Remove commutes with map and updating. *)
Axiom remove_map : forall A B (f : A -> B) (E : gen_env A) x,
  (map f E) ∖ {x} = map f (E ∖ {x}).
Axiom remove_update : forall A x (E F : gen_env A),
  ok E ->
  (E ::= F) ∖ {x} = (E ∖ {x}) ::= F.
Axiom remove_update_eq : forall A x y (v : A) (E : gen_env A),
  x = y ->
  (E ::= (y ∶ v)) ∖ {x} = E ∖ {x}.

(** Ok and remove. *)
Axiom ok_remove : forall A x (E : gen_env A),
  ok E ->
  ok (E ∖ {x}).

(* ---------------------------------------------------------------------- *)
(** **** Properties of all_remove *)

(** All_remove and remove. *)
Axiom all_remove_remove : forall A x xs (E : gen_env A),
  E ∖ (x :: xs) = (E ∖ {x}) ∖ xs.

(** All_remove is identity on empty environments. *)
Axiom all_remove_empty : forall A xs,
  (@empty A) ∖ xs = (@empty A).
Axiom all_remove_nil : forall A (E : gen_env A),
  E ∖ nil = E.

(** All_remove on singular. *)
Axiom all_remove_single_in : forall A x xs (v : A),
  List.In x xs ->
  (x ∶ v) ∖ xs = (@empty A).
Axiom all_remove_single_not_in : forall A x xs (v : A),
  ¬ List.In x xs ->
  (x ∶ v) ∖ xs = (x ∶ v).

(** All_remove on singulars. *)
Axiom all_remove_singles_in : forall A xs ys (vs : list A),
  xs = ys -> length xs = length vs ->
  (xs ∷ vs) ∖ ys = (@empty A).
Axiom all_remove_singles_not_in : forall A xs ys (vs : list A),
  List.Forall (fun x => ¬ List.In x xs) ys ->
  (xs ∷ vs) ∖ ys = (xs ∷ vs).

(** All_remove and notin. *)
Axiom all_remove_notin : forall A xs (E : gen_env A),
  xs ⊄ E ->
  E ∖ xs = E.
Axiom notin_all_remove_notin : forall A x ys (E : gen_env A),
  x ∉ E ->
  x ∉ (E ∖ ys).
Axiom all_notin_all_remove_notin : forall A xs ys (E : gen_env A),
  xs ⊄ E ->
  xs ⊄ (E ∖ ys).

(** Remove and all_notin. *)
Axiom all_remove_ok_notin : forall A xs (E : gen_env A),
  ok E ->
  xs ⊄ (E ∖ xs).

(** All_remove and concatenation. *)
Axiom all_remove_belongs_concat_r : forall A xs (E F : gen_env A),
  List.NoDup xs ->
  xs ⊂ F ->
  (E & F) ∖ xs = E & (F ∖ xs).
Axiom all_remove_belongs_concat_l : forall A xs (E F : gen_env A),
  xs ⊄ F ->
  (E & F) ∖ xs = (E ∖ xs) & F.

(** All_remove commutes with map and updating. *)
Axiom all_remove_map : forall A B (f : A -> B) (E : gen_env A) xs,
  (map f E) ∖ xs = map f (E ∖ xs).
Axiom all_remove_update : forall A xs (E F : gen_env A),
  ok E ->
  (E ::= F) ∖ xs = (E ∖ xs) ::= F.

(** Ok and all_remove. *)
Axiom ok_all_remove : forall A xs (E : gen_env A),
  ok E ->
  ok (E ∖ xs).

(* ---------------------------------------------------------------------- *)
(** **** Properties of ok *)

(** Ok stands for empty and singular environments. *)
Axiom ok_empty : forall A,
  ok (@empty A).
Axiom ok_single : forall A x (v : A),
  ok (x ∶ v).

(** Ok stands if there is no variable duplication. *)
Axiom ok_singles : forall A xs (vs : list A),
  List.NoDup xs ->
  ok (xs ∷ vs).
Axiom ok_singles_inv : forall A xs (vs : list A),
  length xs = length vs ->
  ok (xs ∷ vs) ->
  List.NoDup xs.

(** Ok stands on concatenation when domains are disjoints. *)
Axiom ok_concat : forall A (E F : gen_env A),
  ok E -> ok F ->
  (dom E) ⊄ F -> (dom F) ⊄ E ->
  ok (E & F).
Axiom ok_concat_inv : forall A (E F : gen_env A),
  ok (E & F) ->
  ok E ∧ ok F ∧ (dom E) ⊄ F ∧ (dom F) ⊄ E.
Axiom ok_concat_comm : forall A (E F : gen_env A),
  ok (E & F) ->
  ok (F & E).

(** Belongs and concat with ok. *)
Axiom belongs_ok_concat_inv_l : forall A x (F G : gen_env A),
  ok (F & G) ->
  x ∈ F ->
  x ∉ G.
Axiom belongs_ok_concat_inv_r : forall A x (F G : gen_env A),
  ok (F & G) ->
  x ∈ G ->
  x ∉ F.
Axiom concat_not_ok : forall A x (F G : gen_env A),
  x ∈ F -> x ∈ G ->
  ¬ ok (F & G).

(** Additional properties when ok stands. *)

(** Update commutes with concatenation on the left. *)
Axiom update_concat_l : forall A (E F G : gen_env A),
  ok (E & F) ->
  (E & F) ::= G = (E ::= G) & (F ::= G).

End Properties.

End CoreGenericEnvironmentType.


From Undecidability.L Require Import L.
From Undecidability.L.Datatypes Require Import LProd LTerm LBool.
From Complexity.Complexity Require Import NP Definitions Monotonic Subtypes.
From Complexity.NP.L Require Import CanEnumTerm_def GenNP.
From Undecidability.L.Functions Require Import Size.

Import Nat.
Import L_Notations.

Lemma NPhard_GenNP X__cert `{R__cert : encodable X__cert}:
  canEnumTerms X__cert -> NPhard (GenNP X__cert).
Proof.
  intros enumTerm'.
  destruct (canEnumTerms_compPoly enumTerm') as (enumTerm&[comp1]&[comp2]&[comp3]);clear enumTerm'.
  intros X reg__X regP__X Q [R R__comp' R__spec'(*[p Rsound Rcomplete p__poly p__mono]*)].
  destruct (polyCertRel_compPoly R__spec') as (R__spec&[pR__comp]);clear R__spec'.
  destruct (inTimePoly_compTime R__comp') as (timeR&[timeR__comp]&[R__comp]&poly_t__R&mono_t__R);clear R__comp'.
  (*intros X reg__X regP__X vX Q [ R R__dec R__spec].
    destruct R__dec as (time__R&[R__comp]&poly_t__R&mono_t__R). *)
  pose (f x := fun c => f__decInTime R__comp (x,f__toTerm enumTerm c)).
  evar (time : nat -> nat). [time]:intros n.
  assert (computableTime' f (fun x _ => (1,fun c _ => (time (size (enc (x,c))) (*t__R (size (enc (x, c))) + 3*) ,tt))));cbn [timeComplexity] in *.
  {subst f. extract.
   recRel_prettify. intros x _. split. nia. intros c__t _. split. 2:easy.
   remember (size (enc (x, c__t))) as n0 eqn:eqn0.
   rewrite (mono__polyTC enumTerm (x':=n0)). 2:{ subst n0. rewrite size_prod. cbn;lia. }
   erewrite (mono_t__R _).
   2:{
     rewrite size_prod in eqn0|-*;cbn [fst snd] in eqn0|-*.
     rewrite (bounds__rSP enumTerm c__t). rewrite (mono__rSP _ (x':=n0)). 2:{subst n0;nia. }
     instantiate (1:=n0 + resSize__rSP enumTerm n0). nia.
   }
   unfold time;reflexivity.
  }
  (*specialize inOPoly_computable with (1:=poly__pCR R__spec) as (p__cert'&tf__Rbal'&[]&polyf__Rbal'&leq_f__Rbal'&?&?&?).
    specialize inOPoly_computable with (1:=poly_t__R) as (time__R'&tt__R'&[]&poly_t__R'&leq_t__R'&?&?&?). *)
  evar (stepsInner : nat -> nat). [stepsInner]:intros n0.
  evar (mSize : nat -> nat). [mSize]:intros n0. evar (steps : nat -> nat). [steps]:intros n0.
  pose (g:= fun (x:X) => (lam (trueOrDiverge (extT f (enc x) 0)), mSize (size (enc x))(*f__Rbal' (size (enc x))*)
                   ,steps (size (enc x))(*t__R' (size (enc x) + f__Rbal' (size (enc x))+4)+9*))).
  apply reducesPolyMO_intro_restrictBy_out with (f:= g);cbn [fst snd].
  2:{
    intros x. remember (g x) as x0 eqn:eqx0. destruct x0 as ((t0,maxSize0),steps0).
    unfold g in eqx0. injection eqx0. intros Hx0 Hsize0 Hsteps0. clear eqx0.
    cbn [GenNP restrictBy fst snd].
    unfold LHaltsOrDiverges.

    set (n0:= size (enc x)).
    assert (Ht0 : forall c, size (enc c) <= maxSize0 -> t0 (enc c) >(<= stepsInner n0) trueOrDiverge (enc (f x c))).
    {intros c Hc. subst t0. eapply le_redLe_proper. 2,3:reflexivity. 2:now  Lsimpl.
     cbn [fst snd]. ring_simplify.
     rewrite size_prod. cbn [fst snd]. unfold time.
     rewrite (mono__polyTC enumTerm). 2:now rewrite Hc.
     hnf in mono_t__R;erewrite mono_t__R.
     2:{ rewrite (mono__rSP enumTerm). all:rewrite Hc. all:reflexivity. }
     unfold stepsInner. subst maxSize0. fold n0. reflexivity.
    }
    assert (Ht0' : forall c, t0 (enc c) >* trueOrDiverge (enc (f x c))).
    {intros c. subst t0. eapply redLe_star_subrelation.
     eapply le_redLe_proper. 2,3:reflexivity. 2:now Lsimpl. reflexivity.
    }
    split.
    +repeat simple apply conj.
     *now subst t0;Lproc.
     *intros c k t Ht.
      specialize (Ht0' c) as Ht0''.
      unshelve eassert (eqb := trueOrDiverge_eval _).
      3:{
        eapply equiv_eval_proper.
        3:eapply evalIn_eval_subrelation;exact Ht. 2:reflexivity.
        rewrite Ht0'. easy.
      }
      rewrite eqb in Ht0''.
      assert (H:=eqb).
      unfold f in H. unshelve rewrite <- correct__decInTime in H.
      hnf in H.
      replace t with I in *. clear t.
      2:{eapply eval_unique. 2:now eapply evalIn_eval_subrelation.
         split. 2:Lproc. rewrite Ht0''. rewrite trueOrDiverge_true. easy. }
      edestruct complete__pCR with (p:=R__spec) as (tc'&HRc'&Hsizec').
      { eapply sound__pCR in H. 2:easy. eassumption. }
      (*eapply sound__pCR in HRc'. 2:easy. *) subst t0.
      cbn [proj1_sig] in Hsizec'.
      specialize (complete__toTerm enumTerm tc') as (c'&<-&Hc').
      eexists c';split.
      2:{ Intern.infer_instances. Lsimpl. split. 2:now Lproc. rewrite <- trueOrDiverge_true. apply star_trans_r.
          enough (H':f x c' = true) by (rewrite H';reflexivity ).
          unfold f. rewrite <- correct__decInTime. hnf. easy.
      }
      subst steps0. rewrite Hc'.
      etransitivity. 1:{eapply monoIn__toTerm. eassumption. }
      subst maxSize0. subst mSize. set (size _). hnf. reflexivity.
     *intros c H' k t Ht. specialize (Ht0 c H') as (kt0&lt__j&Ht0).
      unshelve eassert (eqb := trueOrDiverge_eval _).
      3:{
        eapply equiv_eval_proper.
        3:eapply evalIn_eval_subrelation;exact Ht. 2:reflexivity.
        eapply pow_star in Ht0;rewrite Ht0. easy.
      }
      rewrite eqb in Ht0.
      edestruct evalIn_unique with (1:=Ht) as [eqk _].
      {clear Ht. eapply evalIn_trans. exact Ht0. split. apply trueOrDiverge_true. Lproc. }
      subst k steps0. rewrite lt__j. fold n0. unfold steps. reflexivity.
    +split.
     *intros (c&?&H')%(complete__pCR R__spec). cbn [proj1_sig] in H'. (*specialize (spec_d__R (x,c) x__valid). cbn [fst snd] in *. cbn in *. *)
      destruct (complete__toTerm enumTerm c) as (c__X&eqf__term&le_c__X).
      exists c__X. split.
      --rewrite le_c__X. subst maxSize0.
        rewrite (monoIn__toTerm enumTerm (x:=_)). 2:exact H'.
        set (n1:=size (enc x)). unfold mSize. reflexivity.
      --exists I.
        unshelve eassert (Hc'' := Ht0 c__X _).
        {subst maxSize0. rewrite le_c__X. rewrite (monoIn__toTerm enumTerm (x:=_)). 2:exact H'. unfold mSize. reflexivity. }
        eapply evalIn_mono.
        {Lsimpl. unfold f. rewrite eqf__term.
         erewrite (complete__decInTime R__comp). 2:cbn;easy. Lsimpl. Lreflexivity. }
        subst steps0 steps. fold n0. easy.
     *intros (c&size__c&?&R'). eapply (sound__pCR R__spec).
      eapply (sound__decInTime (P__dec:=R__comp) (x:=(x,_))). cbn.
      eapply trueOrDiverge_eval with (t:=x0).
      eapply equiv_eval_proper. 2:reflexivity.
      {unfold f in Ht0. specialize (Ht0 _ size__c). apply redLe_star_subrelation in  Ht0.  rewrite <- Ht0.
       symmetry. apply star_equiv_subrelation. eapply redLe_star_subrelation. apply R'.
      }
      destruct R'. Lreflexivity.
  }
  -unfold g. evar (f':nat -> nat). [f']:refine (fun x => _).
   eexists (fun x => f' x).
   +unfold mSize, steps, stepsInner. extract.
    recRel_prettify2. generalize (size (enc x)). intro. unfold f'. reflexivity.
   +subst f'. cbn beta. setoid_rewrite size_nat_enc. all:smpl_inO. all:eapply inOPoly_comp.
     all:unfold add_time; smpl_inO. all:eapply inOPoly_comp. all:smpl_inO. all:eapply inOPoly_comp. all:smpl_inO.
    all:eapply inOPoly_comp. all:smpl_inO.
   +subst f'. cbn beta. setoid_rewrite size_nat_enc. all:unfold add_time; smpl_inO.
   +unfold mSize,steps,stepsInner. eexists (fun x => _).
    *intros.
     repeat (setoid_rewrite -> size_prod;cbn[fst snd]).
     rewrite !size_nat_enc,!size_term_enc. cbn [size].
     generalize (size (enc x)). intros. reflexivity.
    *smpl_inO. all:eapply inOPoly_comp. all:smpl_inO. all:eapply inOPoly_comp. all:smpl_inO. all:eapply inOPoly_comp. all:smpl_inO.
    *smpl_inO.
Qed.


From iris Require Export base.
From stdpp Require Export base list sets mapset.
From Autosubst Require Export Autosubst.
Require Export Utf8_core.
Require Import Coq.Arith.Minus.
From fae_gtlc_mu.backtranslation Require Import implication_consistencies.help_lemmas.listset_ext.
From fae_gtlc_mu.cast_calculus Require Export types types_lemmas.

Fixpoint closed_rec_types (τ : type) : listset type :=
  match τ with
  | TUnit => ∅
  | TProd τ1 τ2 => closed_rec_types τ1 ∪ closed_rec_types τ2
  | TSum τ1 τ2 => closed_rec_types τ1 ∪ closed_rec_types τ2
  | TArrow τ1 τ2 => closed_rec_types τ1 ∪ closed_rec_types τ2
  | TRec τb => {[ TRec τb ]} ∪ fmap (subst (TRec τb .: ids)) (closed_rec_types τb)
  | TVar x => ∅
  | TUnknown => ∅
  end.

From Coq Require Import Relation_Operators Operators_Properties.

Inductive p_le_pre : type → type → Prop :=
  | prod_l_p_le_pre τ τ' : p_le_pre τ (TProd τ τ')
  | prod_r_p_le_pre τ τ' : p_le_pre τ' (TProd τ τ')
  | sum_l_p_le_pre τ τ' : p_le_pre τ (TSum τ τ')
  | sum_r_p_le_pre τ τ' : p_le_pre τ' (TSum τ τ')
  | arrow_l_p_le_pre τ τ' : p_le_pre τ (TArrow τ τ')
  | arrow_r_p_le_pre τ τ' : p_le_pre τ' (TArrow τ τ').

Definition p_le : type → type → Prop := rtc p_le_pre.

Fixpoint subst_chain (ch : list type) : var → type :=
  match ch with
  | nil => ids
  | cons τ1 ch => ((TRec τ1) .: ids) >> subst_chain ch
  end.

Fixpoint subst_chains_fmap (pk : list type) (pn : list type) : var → type :=
  match pk with
  | nil => ids
  | cons α1 αs => (((TRec α1).[upn (length αs) (subst_chain pn)]) .: ids) >> subst_chains_fmap αs pn
  end.

Lemma subst_chains_fmap_nil (pk : list type) : subst_chains_fmap pk [] = subst_chain pk.
Proof.
  induction pk; try by simpl.
  simpl. rewrite up_id_n. rewrite IHpk. by rewrite up_id subst_id.
Qed.

Inductive Chain : type → type → list type → Prop :=
  | nil_Chain α τ (p : p_le α τ) : Chain α τ []
  | cons_Chain α τ0 (p0 : p_le α τ0) τ1 (p : p_le (TRec τ0) τ1) τn (ls : list type) (pc : Chain τ1 τn ls) :
      Chain α τn (τ0 :: ls).

Lemma chain_diff_prefix α α' τ pn : Chain α' τ pn → p_le α α' → Chain α τ pn.
Proof.
  inversion 1.
  - simplify_eq.
    intro. apply nil_Chain. by eapply rtc_transitive.
  - simplify_eq.
    intro. eapply cons_Chain. by eapply rtc_transitive. apply p. apply pc.
Qed.

Lemma chain_diff_suffix α τ τ' pn : Chain α τ pn → p_le τ τ' → Chain α τ' pn.
Proof.
  induction 1.
  - intros. simplify_eq.
    apply nil_Chain. by eapply rtc_transitive.
  - intros. eapply cons_Chain. apply p0. apply p. by apply IHChain.
Qed.

Lemma app_Chain (pk pn : list type) (α1 τ1 τn : type) (pchk : Chain α1 τ1 pk) (pchn : Chain τ1 τn pn) : Chain α1 τn (pk ++ pn).
Proof.
  generalize dependent α1.
  generalize dependent pn.
  induction pk as [| α1' pk ].
  - intros. simpl. inversion_clear pchk.
    eapply chain_diff_prefix. apply pchn. apply p.
  - intros. inversion pchk; simplify_eq.
    eapply cons_Chain. auto. apply p. fold (app pk ( pn)).
    apply IHpk; auto.
Qed.

Lemma subst_over_rec τ σ : TRec τ.[up σ] = (TRec τ).[σ]. Proof. by asimpl. Qed.

Lemma subst_chain_subst_chains_fmap (pk pn : list type) :
      upn (length pk) (subst_chain pn) >> subst_chains_fmap pk pn = subst_chain (pk ++ pn).
Proof.
  induction pk as [|α1 pk].
  - by asimpl.
  - simpl; rewrite subst_over_rec -scomp_assoc subst_commut.
    fold (iterate up).
    by rewrite scomp_assoc IHpk.
Qed.

Lemma var_subst_chain j pn : sumor ((j < length pn) * { p : type | pn !! j = Some p ∧ (TRec p).[subst_chain (drop (S j) pn)] = (TVar j).[subst_chain pn] })%type
                             (length pn ≤ j ∧ (TVar j).[subst_chain pn] = (TVar (j - length pn))).
Proof.
  destruct (decide (j < length pn)).
  - left. split. auto.
    destruct (pn !! j) eqn:eq.
    + exists t. split. auto.
      generalize dependent j.
      induction pn.
      * intros. exfalso. simpl in l. lia.
      * intros. destruct j. simpl in *. inversion eq.
        simplify_eq. by simpl.
        simpl. rewrite subst_over_rec.
        simpl in l.
        apply IHpn. lia. simpl in eq.  auto.
    + exfalso. assert (H : length pn ≤ j). by apply lookup_ge_None.
      lia.
  - right. split. lia.
    generalize dependent j.
    induction pn. intros. simpl. f_equal. by rewrite Nat.sub_0_r.
    destruct j. intros. exfalso. simpl in n. lia.
    intros. assert (triv : (TVar (S j)).[subst_chain (a :: pn)] = (TVar j).[subst_chain pn]).
    by asimpl. rewrite triv. rewrite (IHpn j). by simpl. simpl in n. lia.
Qed.

Lemma drop_Chain τ0 τ ls x τx (pchn : Chain τ0 τ ls)
      (Hx : x < length ls)
      (Hlsx : ls !! x = Some τx) : Chain (TRec τx) τ (drop (S x) ls).
Proof.
  generalize dependent ls.
  generalize dependent τ0.
  induction x.
  - intros.
    destruct ls. inversion Hlsx. inversion Hlsx.
    inversion pchn. inversion Hx.
    simplify_eq. simpl. rewrite drop_0.
    eapply chain_diff_prefix. apply pc. done.
    simplify_eq. simpl. rewrite drop_0.
    eapply chain_diff_prefix. apply pc. done.
  - intros.
    destruct ls. inversion Hlsx.
    inversion pchn. simplify_eq.
    simpl. eapply IHx.
    apply pc. simpl in *. lia.
    by simpl in *.
Qed.

Lemma subst_chain_app (ls ks : list type) : subst_chain (ls ++ ks) = subst_chain ls >> subst_chain ks.
Proof. induction ls. by asimpl. simpl. rewrite IHls. by asimpl. Qed.

Lemma split_Chain (ls ks : list type) τ1 τ : Chain τ1 τ (ls ++ ks) → exists δ, Chain τ1 δ ls ∧ Chain δ τ ks.
Proof.
  generalize dependent τ1.
  induction ls.
  - intros. simpl in *. exists τ1. split. apply nil_Chain. apply rtc_refl. auto.
  - simpl in *. intros. inversion H. simplify_eq.
    specialize (IHls τ2 pc).
    destruct IHls as [δ [H1 H2]].
    exists δ. split. eapply cons_Chain. apply p0. apply p. auto. auto.
Qed.

Lemma chop_off_last {A} (ls : list A) n : length ls = S n → exists ks x, ls = ks ++ [x].
Proof.
  intro.
  generalize dependent n.
  induction ls.
  - intros. exfalso. simpl in H. lia.
  - intros. destruct n.
    + simpl in H. inversion H. destruct ls. exists [], a. by simpl. inversion H1.
    + simpl in H. inversion H. destruct (IHls n H1) as [ks [x ->]].
      exists (a :: ks), x. by simpl.
Qed.

Lemma mono_map_subseteq {A B : Type} (f : A → B) (ls ks : listset A) : ls ⊆ ks → f <$> ls ⊆ f <$> ks.
Proof. intro. set_solver. Qed.

Lemma le_TUnit τ : p_le τ TUnit → τ = TUnit.
Proof.
  intro. apply (@rtc_ind_l _ p_le_pre (fun τ : type => (τ = TUnit)) TUnit); auto.
  intros. inversion H0; rewrite H2 in H4; inversion H4.
Qed.

Lemma le_TVar τ x : p_le τ (TVar x) → τ = (TVar x).
Proof.
  intro. apply (@rtc_ind_l _ p_le_pre (fun τ : type => (τ = TVar x)) (TVar x)); auto.
  intros. inversion H0; rewrite H2 in H4; inversion H4.
Qed.

Lemma le_TUnknown τ : p_le τ TUnknown → τ = TUnknown.
Proof.
  intro. apply (@rtc_ind_l _ p_le_pre (fun τ : type => (τ = TUnknown)) TUnknown); auto.
  intros. inversion H0; rewrite H2 in H4; inversion H4.
Qed.

Lemma le_TProd τ τ1 τ2 : p_le τ (TProd τ1 τ2) → τ = TProd τ1 τ2 ∨ p_le τ τ1 ∨ p_le τ τ2.
Proof.
  intro.
  apply (@rtc_ind_l _ p_le_pre (fun τ' : type => (τ' = TProd τ1 τ2 ∨ p_le τ' τ1 ∨ p_le τ' τ2)) (TProd τ1 τ2)).
  - by left.
  - intros. destruct H2 as [-> | [p1 | p2] ].
    + inversion H0; simplify_eq.
      * right. left. by constructor.
      * right. right. by constructor.
    + right. left. by econstructor.
    + right. right. by econstructor.
  - auto.
Qed.

Lemma le_TSum τ τ1 τ2 : p_le τ (TSum τ1 τ2) → τ = TSum τ1 τ2 ∨ p_le τ τ1 ∨ p_le τ τ2.
Proof.
  intro.
  apply (@rtc_ind_l _ p_le_pre (fun τ' : type => (τ' = TSum τ1 τ2 ∨ p_le τ' τ1 ∨ p_le τ' τ2)) (TSum τ1 τ2)).
  - by left.
  - intros. destruct H2 as [-> | [p1 | p2] ].
    + inversion H0; simplify_eq.
      * right. left. by constructor.
      * right. right. by constructor.
    + right. left. by econstructor.
    + right. right. by econstructor.
  - auto.
Qed.

Lemma le_TArrow τ τ1 τ2 : p_le τ (TArrow τ1 τ2) → τ = TArrow τ1 τ2 ∨ p_le τ τ1 ∨ p_le τ τ2.
Proof.
  intro.
  apply (@rtc_ind_l _ p_le_pre (fun τ' : type => (τ' = TArrow τ1 τ2 ∨ p_le τ' τ1 ∨ p_le τ' τ2)) (TArrow τ1 τ2)).
  - by left.
  - intros. destruct H2 as [ | [p1 | p2] ].
    + inversion H0; simplify_eq.
      * right. left. by constructor.
      * right. right. by constructor.
    + right. left. by econstructor.
    + right. right. by econstructor.
  - auto.
Qed.

Lemma le_TRec τ τ' : p_le τ (TRec τ') → τ = TRec τ'.
Proof.
  intro.
  apply (@rtc_ind_l _ p_le_pre (fun τ : type => (τ = TRec τ')) (TRec τ')); auto.
  intros. simplify_eq. inversion H0.
Qed.

Lemma chain_off_last (ls : list type) α τ n : length ls = S n → Chain α τ ls → exists ks δ, ls = ks ++ [δ] ∧ Chain α δ ks ∧ p_le (TRec δ) τ.
Proof.
  intros Hls pchn.
  destruct (chop_off_last ls n Hls) as [ks [z ->]].
  destruct (split_Chain ks [z] _ _ pchn) as [δ [Hch1 Hch2]].
  inversion Hch2. simplify_eq. inversion pc. simplify_eq.
  exists ks, z. split; split; auto.
  eapply chain_diff_suffix. apply Hch1. auto.
  by eapply rtc_transitive.
Qed.

Lemma chain_cons_right ks α δ τ : Chain α δ ks → p_le (TRec δ) τ → Chain α τ (ks ++ [δ]).
Proof.
  intros. eapply app_Chain. apply H.
  eapply cons_Chain. constructor. apply H0.
  constructor. constructor.
Qed.

Lemma elem_of_closed_rec_types n : forall (τ : type) (αb : type)
      (ls : list type) (Hls : length ls = n) (pch : Chain (TRec αb) τ ls), {[(TRec αb).[subst_chain ls]]} ⊆ closed_rec_types τ.
Proof.
  induction n.
  - intros. destruct ls; try by inversion Hls. clear Hls. rewrite subst_id. inversion_clear pch.
    induction τ.
    + assert (abs : TRec αb = TUnit). by apply le_TUnit. inversion abs.
    + destruct (le_TProd _ _ _ p) as [abs | [p1 | p2]].
      * inversion abs.
      * set_solver.
      * set_solver.
    + destruct (le_TSum _ _ _ p) as [abs | [p1 | p2]].
      * inversion abs.
      * set_solver.
      * set_solver.
    + destruct (le_TArrow _ _ _ p) as [abs | [p1 | p2]].
      * inversion abs.
      * set_solver.
      * set_solver.
    + clear IHτ.
      simpl. destruct (le_TRec (TRec αb) τ p). set_solver.
    + assert (abs : TRec αb = TVar x). by apply le_TVar. inversion abs.
    + assert (abs : TRec αb = TUnknown). by apply le_TUnknown. inversion abs.
  - induction τ; intros.
    + destruct (chain_off_last ls _ _ n Hls pch) as [ks [δ [eq [pchn pμδτ]]]].
      assert (abs : TRec δ = TUnit). by apply le_TUnit. inversion abs.
    + clear IHn.
      destruct (chain_off_last ls _ _ n Hls pch) as [ks [δ [-> [pchn pμδτ]]]].
      destruct (le_TProd _ _ _ pμδτ) as [abs | [p1 | p2]].
      * inversion abs.
      * specialize (IHτ1 αb (ks ++ [δ]) Hls (chain_cons_right _ _ _ _ pchn p1)). set_solver.
      * specialize (IHτ2 αb (ks ++ [δ]) Hls (chain_cons_right _ _ _ _ pchn p2)). set_solver.
    + clear IHn.
      destruct (chain_off_last ls _ _ n Hls pch) as [ks [δ [-> [pchn pμδτ]]]].
      destruct (le_TSum _ _ _ pμδτ) as [abs | [p1 | p2]].
      * inversion abs.
      * specialize (IHτ1 αb (ks ++ [δ]) Hls (chain_cons_right _ _ _ _ pchn p1)). set_solver.
      * specialize (IHτ2 αb (ks ++ [δ]) Hls (chain_cons_right _ _ _ _ pchn p2)). set_solver.
    + clear IHn.
      destruct (chain_off_last ls _ _ n Hls pch) as [ks [δ [-> [pchn pμδτ]]]].
      destruct (le_TArrow _ _ _ pμδτ) as [abs | [p1 | p2]].
      * inversion abs.
      * specialize (IHτ1 αb (ks ++ [δ]) Hls (chain_cons_right _ _ _ _ pchn p1)). set_solver.
      * specialize (IHτ2 αb (ks ++ [δ]) Hls (chain_cons_right _ _ _ _ pchn p2)). set_solver.
    + clear IHτ.
      destruct (chain_off_last ls _ _ n Hls pch) as [ks [δ [-> [pchn pμδτ]]]].
      rewrite app_length in Hls. simpl in Hls.
      specialize (IHn δ αb ks ltac:(lia) pchn).
      destruct (le_TRec (TRec δ) τ pμδτ).
      rewrite subst_chain_app. simpl (subst_chain [δ]). simpl (closed_rec_types (TRec δ)).
      cut (subst (TRec δ .: ids) <$> {[(TRec αb).[subst_chain ks]]} ⊆ subst (TRec δ .: ids) <$> closed_rec_types δ ).
      { rewrite map_singleton. asimpl. set_solver. }
      by apply mono_map_subseteq.
    + destruct (chain_off_last ls _ _ n Hls pch) as [ks [δ [eq [pchn pμδτ]]]].
      assert (abs : TRec δ = TVar x). by apply le_TVar. inversion abs.
    + destruct (chain_off_last ls _ _ n Hls pch) as [ks [δ [eq [pchn pμδτ]]]].
      assert (abs : TRec δ = TUnknown). by apply le_TUnknown. inversion abs.
Qed.

Lemma elem_of_closed_rec_types' n : forall (τ : type) (αb : type)
      (ls : list type) (Hls : length ls = n) (pch : Chain (TRec αb) τ ls), (TRec αb).[subst_chain ls] ∈ closed_rec_types τ.
Proof. intros. apply elem_of_subseteq_singleton. by eapply elem_of_closed_rec_types. Qed.

Lemma crt_closed_gen τ : forall n, NClosed n τ → set_Forall (NClosed n) (closed_rec_types τ).
Proof.
  induction τ; intros; simpl.
  - apply set_Forall_empty.
  - apply set_Forall_union.
    + apply IHτ1. by eapply TProd_nclosed1.
    + apply IHτ2. by eapply TProd_nclosed2.
  - apply set_Forall_union.
    + apply IHτ1. by eapply TSum_nclosed1.
    + apply IHτ2. by eapply TSum_nclosed2.
  - apply set_Forall_union.
    + apply IHτ1. by eapply TArrow_nclosed1.
    + apply IHτ2. by eapply TArrow_nclosed2.
  - apply set_Forall_union.
    + by apply set_Forall_singleton.
    + specialize (IHτ (S n)). apply set_Forall_fmap_impl with (P := NClosed (S n)).
      { intros τ' Hτ'. by apply NClosed_subst. }
      apply IHτ. by apply TRec_nclosed1.
  - apply set_Forall_empty.
  - apply set_Forall_empty.
Qed.

Lemma crt_closed τ (pτ : Closed τ) : set_Forall Closed (closed_rec_types τ).
Proof. eapply set_Forall_impl. apply (crt_closed_gen _ 0). auto. auto. Qed.

Lemma nat_total_induction (P : nat → Prop) (base : P 0) (IH : forall n, (forall m, m ≤ n → P m) → P (S n)) : forall n, P n.
Proof.
  cut (forall n m, m ≤ n → P m).
  - intros. apply (H n n). lia.
  - intros n. induction n.
    + intros. inversion H. apply base.
    + intros. inversion H. apply IH. apply IHn. by apply IHn.
Qed.

Lemma closed_rec_types_unfold_subset_gen τ (pτ : Closed τ) : ∀ (n : nat),
    forall (α : type) (k : nat) (pk : list type) (Hpk : length pk = k) (αk : type) (pchk : Chain α αk pk)
    (pn : list type) (Hpn : length pn = n) (pchn : Chain αk τ pn),
    fmap (subst (subst_chains_fmap pk pn)) (closed_rec_types α.[upn k (subst_chain pn)]) ⊆ closed_rec_types τ.
Proof.
  apply (nat_total_induction (fun n => forall (α : type) (k : nat) (pk : list type) (Hpk : length pk = k) (αk : type) (pchk : Chain α αk pk)
                                      (pn : list type) (Hpn : length pn = n) (pchn : Chain αk τ pn),
                                  fmap (subst (subst_chains_fmap pk pn)) (closed_rec_types α.[upn k (subst_chain pn)]) ⊆ closed_rec_types τ)).
  - intro α. induction α as [ | β1 IHβ1 β2 IHβ2 | β1 IHβ1 β2 IHβ2 | β1 IHβ1 β2 IHβ2 | αb IHαb | x | ];
      intros k pk Hpk αk pchk nil p0 pchnil; try by set_solver.
    + specialize (IHβ1 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (prod_l_p_le_pre β1 β2))) nil p0 pchnil).
      specialize (IHβ2 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (prod_r_p_le_pre β1 β2))) nil p0 pchnil).
      set_solver.
    + specialize (IHβ1 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (sum_l_p_le_pre β1 β2))) nil p0 pchnil).
      specialize (IHβ2 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (sum_r_p_le_pre β1 β2))) nil p0 pchnil).
      set_solver.
    + specialize (IHβ1 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (arrow_l_p_le_pre β1 β2))) nil p0 pchnil).
      specialize (IHβ2 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (arrow_r_p_le_pre β1 β2))) nil p0 pchnil).
      set_solver.
    + specialize (IHαb (S k) (αb :: pk) ltac:(simpl; by rewrite Hpk) αk (cons_Chain _ _ (rtc_refl _ αb) _ (rtc_refl _ (TRec αb)) _ _ pchk) nil p0 pchnil).
      simpl. rewrite map_union. apply union_least.
      * destruct nil; simpl in p0; try by (exfalso; lia).
        rewrite subst_chains_fmap_nil. asimpl. rewrite up_id_n. asimpl.
        eapply elem_of_closed_rec_types. auto. eapply chain_diff_suffix. apply pchk. by inversion_clear pchnil.
      * rewrite -set_fmap_compose.
        erewrite set_Forall_fmap_ext_1. apply IHαb.
        rewrite subst_over_rec.
        intro.
        rewrite scomp_comp. rewrite -Hpk. simpl. reflexivity.
    + destruct nil; simpl in p0; try by (exfalso; lia). simpl (subst_chain []). rewrite up_id_n. asimpl. set_solver.
  - intros n Hni α.
    induction α as [ | β1 IHβ1 β2 IHβ2 | β1 IHβ1 β2 IHβ2 | β1 IHβ1 β2 IHβ2 | αb IHαb | x | ];
      intros k pk Hpk αk pchk pSn HpSn pchSn.
    + clear Hni. simpl. set_solver.
    + clear Hni. simpl.
      specialize (IHβ1 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (prod_l_p_le_pre β1 β2))) pSn HpSn pchSn).
      specialize (IHβ2 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (prod_r_p_le_pre β1 β2))) pSn HpSn pchSn).
      set_solver.
    + clear Hni. simpl.
      specialize (IHβ1 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (sum_l_p_le_pre β1 β2))) pSn HpSn pchSn).
      specialize (IHβ2 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (sum_r_p_le_pre β1 β2))) pSn HpSn pchSn).
      set_solver.
    + clear Hni. simpl.
      specialize (IHβ1 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (arrow_l_p_le_pre β1 β2))) pSn HpSn pchSn).
      specialize (IHβ2 k pk Hpk αk (chain_diff_prefix _ _ _ _ pchk (rtc_once _ _ (arrow_r_p_le_pre β1 β2))) pSn HpSn pchSn).
      set_solver.
    + clear Hni.
      specialize (IHαb (S k) (αb :: pk) ltac:(simpl;auto) αk (cons_Chain αb αb (rtc_refl _ _) (TRec αb) (rtc_refl _ _) _ _ pchk) pSn HpSn pchSn).
      simpl. rewrite map_union. apply union_least.
      * clear IHαb. rewrite subst_over_rec.
        rewrite map_singleton.
        assert (triv : (TRec αb).[upn k (subst_chain pSn)].[subst_chains_fmap pk pSn] = ((TRec αb).[upn k (subst_chain pSn) >> subst_chains_fmap pk pSn])). by asimpl. rewrite triv. clear triv.
        rewrite -Hpk.
        rewrite subst_chain_subst_chains_fmap.
        eapply elem_of_closed_rec_types. auto. eapply app_Chain. apply pchk. done.
      * rewrite -set_fmap_compose.
        erewrite set_Forall_fmap_ext_1.
        apply IHαb.
        rewrite subst_over_rec.
        intro.
        rewrite scomp_comp. rewrite -Hpk. simpl. reflexivity.
    + destruct pSn as [ | τ0' pn]; first by (simpl in HpSn; exfalso; lia).
      inversion HpSn as [Hpn]. inversion pchSn.
      clear H3 ls H2 τ0 τn H0 α H.
      destruct (subst_fv_upn_cases x k (subst_chain (τ0' :: pn))) as [[-> plt] | [j [eq ->]] ].
      * set_solver.
      * destruct (var_subst_chain j (τ0' ::pn)) as [[pj [τj [plk <-]]] | [_ ->]].
        ++ assert (Hch : Chain (TRec τj) τ (drop (S j) (τ0' :: pn))). eapply drop_Chain; auto. apply pchSn. simpl in Hch. simpl (drop (S j) _).
           specialize (Hni (n - j) ltac:(lia) (TRec τj) 0 [] ltac:(auto) (TRec τj) (nil_Chain _ _ (rtc_refl _ _)) (drop j pn) ltac:(by rewrite drop_length Hpn) Hch).
           rewrite upn0 in Hni. simpl (subst_chains_fmap [] (drop j pn)) in Hni. rewrite subst_idX in Hni.
           assert (Hni' : closed_rec_types (TRec τj).[subst_chain (drop j pn)] ⊆ closed_rec_types τ). set_solver. clear Hni. rename Hni' into Hni.
           assert (Hc : Closed (TRec τj).[subst_chain (drop j pn)]).
           { apply (crt_closed τ pτ). eapply elem_of_closed_rec_types'; auto. }
           rewrite Hc.
           assert (Hcc : set_Forall Closed (closed_rec_types (TRec τj).[subst_chain (drop j pn)])).
           { eapply set_Forall_subseteq. apply Hni. apply (crt_closed τ pτ). }
           rewrite (set_Forall_fmap_ext_1 _ id). set_solver.
           eapply set_Forall_impl. apply Hcc. intros. by rewrite H.
        ++ (* impossible cast but yeah.. *) simpl. set_solver.
    + simpl. set_solver.
Qed.

Lemma closed_rec_types_unfold_subset τb (pμτb : Closed (TRec τb)) : closed_rec_types τb.[TRec τb/] ⊆ closed_rec_types (TRec τb).
Proof.
  cut (fmap (subst (subst_chains_fmap [] [τb])) (closed_rec_types τb.[upn 0 (subst_chain [τb])])  ⊆ closed_rec_types (TRec τb)).
  { intro. asimpl. asimpl in H. set_solver. }
  apply closed_rec_types_unfold_subset_gen with (αk := τb) (n := 1); auto.
  constructor; constructor. econstructor; constructor. constructor.
Qed.


Require Import ListAux.
Require Import TreeAux.
Lemma bankersq2consistent_Force0 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (id_spec  il_0 il_1) -> (((list_member  il_0 u_1)) -> (list_member  il_1 u_1)).
Proof. solve_id; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_Force1 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (id_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(list_order  il_0 u_1 u_0)/\(list_member  il_0 u_1)) -> (list_order  il_1 u_1 u_0)).
Proof. solve_id; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_Force2 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (id_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_1)) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_id; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_Force3 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (id_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(list_member  il_0 u_0)/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_1)) -> (list_order  il_1 u_0 u_1)).
Proof. solve_id; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_Force4 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (id_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_member  il_0 u_0))/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_1)) -> (not (list_member  il_1 u_0))).
Proof. solve_id; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_Force5 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (id_spec  il_0 il_1) -> (((not (list_member  il_0 u_1))) -> (not (list_member  il_1 u_1))).
Proof. solve_id; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_Force6 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (id_spec  il_0 il_1) -> (((not (list_member  il_0 u_1))) -> (not (list_order  il_1 u_0 u_1))).
Proof. solve_id; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_Force7 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (id_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(list_member  il_0 u_0)/\(not (list_member  il_0 u_1))) -> (list_member  il_1 u_0)).
Proof. solve_id; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma bankersq2consistent_Force8 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (id_spec  il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_member  il_0 u_0))/\(not (list_member  il_0 u_1))) -> (not (list_member  il_1 u_0))).
Proof. solve_id; try (assert (u_0 = u_1); subst; eauto). Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^384 - 79*2^376 - 1
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 6%nat;
    base := 64;
    bitwidth := 64;
    s := 2^384;
    c := [(1, 1); (79, 2^376)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import CPidgin.Control.Applicative.
Require Import CPidgin.Control.Functor.
Require Import CPidgin.Control.Monad.

Module Maybe.

Import Applicative.
Import Functor.
Import Monad.

(* The Maybe inductive type describes an optional value. *)
Inductive Maybe (A : Type) : Type :=
    | Just : A -> Maybe A
    | Nothing : Maybe A.

(* The implicit type A maps to the type of the Just parameter. *)
Arguments Just {A} a.
(* Gather the type A parameter from implicit context. *)
Arguments Nothing {A}.

(* The Maybe inductive type can be mapped to an Applicative functor space, in *)
(* which operations on Maybe values can be mapped back to operations on       *)
(* regular values. *)
Instance maybeApplicative : Applicative Maybe := {
    pure t x := Just x;
    app a b af ax :=
        match af with
            Nothing => Nothing
          | Just f =>
                match ax with
                    Nothing => Nothing
                  | Just x => Just (f x)
                end
        end
}.

(* The Maybe inductive type can be mapped to a Functor space in which         *)
(* functions are either executed on values or map to nothing.                 *)
Instance maybeFunctor : Functor Maybe := {
    fmap a b f ax :=
        match ax with
            Nothing => Nothing
          | Just x => Just (f x)
        end
}.

(* The Maybe inductive type can be mapped to a Monad space in which           *)
(* computations on optional values can be short-circuited if these values do  *)
(* not exist.                                                                 *)
Instance maybeMonad : Monad Maybe := {
    mret t x := Just x;
    bind a b m f :=
        match m with
            Nothing => Nothing
          | Just x => f x
        end
}.

End Maybe.


From iris.proofmode Require Import tactics.
From iris_named_props Require Import named_props.

Section demo.
Context {PROP: bi} `{Haff: BiAffine PROP}.
Context (P Q: PROP).

Definition foo_rep :=
("HP" ∷ P ∗
 "HR" ∷ Q)%I.

Theorem foo_rep_read_P : foo_rep -∗ P.
Proof using Haff.
  iIntros "H".
  iNamed "H".
  (* at this point we have a context of

  "HP" : P
  "HR" : Q
  --------------------------------------∗
  P

  *)
  iExact "HP".
Qed.

End demo.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B S MA : Universe, ((wd_ A O /\ (wd_ MA O /\ (wd_ S O /\ (wd_ E O /\ (wd_ B O /\ (wd_ B S /\ (wd_ A S /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (col_ O E S /\ (col_ O E A /\ col_ O E B))))))))))) -> col_ B O S)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import FOL.Reification.GeneralReflection FOL.Arithmetics FOL.FullSyntax.
Import MetaCoq.Template.Ast MetaCoq.Template.TemplateMonad.Core.
Import Vector.VectorNotations.
Require Import String List.

Fixpoint num n := match n with 0 => zero | S n => σ (num n) end.

Section ReificationExample.
  (* We assume an arbitrary model of PA which fulfills the axioms of PA *)
  Context (D':Type).
  Context {I : interp D'}.
  Context {D_ext : extensional I}. (* Furthermore, we assume that a i= b -> a = b, i.e. equality is extensional*)
  Context {D_fulfills : forall f rho, PAeq f -> rho ⊨ f}.

  Open Scope bs_scope.

  Fixpoint inum n := match n with 0 => iO | S n => iσ (inum n) end.

  Instance PA_reflector : tarski_reflector := buildDefaultTarski
                        (iO) (* we need a point in D *)
                        (anyVariableOf ("D'" :: nil)). (* We need to know when some type is D *)

  Section ReflectionExtension.
    (* Do a correctness proof for the specific extension *)
    Definition mergeNum (rho:nat -> D) (n:nat) : representsF (inum n) (num n) rho.
    Proof. unfold representsF. induction n.
    * easy.
    * cbn. do 2 f_equal. cbn in IHn. now rewrite IHn.
    Defined.
    (* Define some MetaCoq terms we will need later *)
    MetaCoq Quote Definition qNum := inum.
    MetaCoq Quote Definition qMergeNum := mergeNum.
    MetaCoq Quote Definition qMergeTermNum := @num.

    Definition mergeEqProp (rho:nat -> D) (d1 d2 : D) (t1 t2 : Core.term) : representsF d1 t1 rho -> representsF d2 t2 rho -> @representsP _ _ 0 (t1==t2) rho (d1 = d2).
    Proof. intros pt1 pt2. cbn. unfold representsF in pt1, pt2. cbn in pt1, pt2. rewrite pt1, pt2. now rewrite D_ext.
    Defined.
    MetaCoq Quote Definition qMergeFormEq := (constructForm Eq).
    MetaCoq Quote Definition qMergeEqProp := mergeEqProp.

    Definition reifyCoqEq : baseConnectiveReifier := fun tct qff l fuel envTerm env fPR fTR => match l with (tv::x::y::nil) => if maybeD tct tv then
                                               xr <- fTR tct qff x envTerm env ;;
                                               yr <- fTR tct qff y envTerm env ;; let '((xt,xp),(yt,yp)) := (xr,yr) in
                                               ret (tApp qMergeFormEq (xt::yt::nil), tApp qMergeEqProp (envTerm::x::y::xt::yt::xp::yp::nil)) else fail "Eq applied to wrong type"%bs | _ => fail "Eq constructor applied to != 2 terms"%bs end.
    Definition varsCoqEq : baseConnectiveVars := fun lst fuel tct _ fUVT => match lst with tv::x::y::nil => if maybeD tct tv then
                                               xr <- fUVT x;;
                                               yr <- fUVT y;;
                                               ret (List.app xr yr) else fail "Eq applied to wrong type" | _ => fail "Eq constructor applied to != 2 terms" end.
    Definition reifyBLC s : baseConnectiveReifier := match s with "eq" => reifyCoqEq | _ => fun _ _ _ _ _ _ _ _ => fail (String.append "Unknown connective " s) end.
    Definition varsBLC s : baseConnectiveVars := match s with "eq" => varsCoqEq | _ => fun _ _ _ _ _ => fail (String.append "Unknown connective " s) end.
    Definition findVarsTerm : termFinderVars := fun fuel t fUVT => match t with (tApp qMu (k::nil)) => ret nil | _ => fail "Fail" end.
    Definition reifyTerm : termFinderReifier := fun tct qff fuel t envTerm env fTR => match t with tApp qMu (k::nil) => ret (tApp qMergeTermNum (k::nil), tApp qMergeNum (envTerm::k::nil)) | _ => fail "Fail" end.
  End ReflectionExtension.
  (* If we want to extend the capabilities, we define an extension point instance *)
  Instance PA_reflector_ext : tarski_reflector_extensions PA_reflector := {| (*Cannot define instance in section because they are dropped afterwards *)
    baseLogicConnHelper := Some (reifyBLC);
    baseLogicVarHelper := Some (varsBLC);
    termReifierVarHelper := Some (findVarsTerm);
    termReifierReifyHelper := Some (reifyTerm);
    formReifierVarHelper := None;
    formReifierReifyHelper := None
  |}.
  (* We can now use = in our terms, and automatically find the proper representative. This also works for num *)

  (* PA induction lemma: like the usual one for nat, but P has to be representable as a first-order term *)
  Lemma PA_induction (P:D -> Prop): representableP 1 P -> P iO -> (forall d:D, P d -> P (iσ d)) -> forall d:D, P d.
  Proof.
  intros [phi [rho Prf]] H0 HS d.
  pose (@D_fulfills _ rho (PAeq_induction phi)) as Hind.
  cbn in Prf. cbn in Hind. rewrite Prf.
  apply Hind.
  - rewrite sat_comp. erewrite (@sat_ext _ _ _ _ _ _ (iO .: rho)).
    + rewrite <- Prf. apply H0.
    + now intros [|n].
  - intros d' IH. rewrite sat_comp. erewrite (@sat_ext _ _ _ _ _ _ (iσ d' .: rho)).
    + rewrite <- Prf. apply HS. rewrite Prf. apply IH.
    + now intros [|n].
  Qed.

  Lemma discriminate (x:D) : x = iO \/ exists y, x = iσ y.
  Proof.
  generalize x. apply PA_induction.
  - represent.
  - now left.
  - intros d IH. right.
    now exists d.
  Qed.

  Lemma add_succ_l a b : (iσ a) i⊕ b = iσ (a i⊕ b).
  Proof.
  rewrite <- D_ext.
  specialize (@D_fulfills ax_add_rec emptyEnv). cbn in D_fulfills.
  apply D_fulfills.
  apply (@PAeq_FA ax_add_rec). do 7 right. now left.
  Qed.

  Lemma add_zero_l b : iO i⊕ b = b.
  Proof.
  rewrite <- D_ext.
  specialize (@D_fulfills ax_add_zero emptyEnv). cbn in D_fulfills.
  apply D_fulfills.
  apply (PAeq_FA). do 6 right. now left.
  Qed.

  Lemma add_zero_r a : a i⊕ iO = a.
  Proof.
  elim a using PA_induction.
  - represent.
  - apply add_zero_l.
  - intros d IH.
    rewrite add_succ_l. now rewrite IH.
  Qed.

  Lemma add_succ_r a b : a i⊕ (iσ b) = iσ (a i⊕ b).
  Proof.
  elim a using PA_induction.
  - represent.
  - now rewrite ! add_zero_l.
  - intros d IH. now rewrite ! add_succ_l, IH.
  Qed.

  Lemma add_comm a b : a i⊕ b = b i⊕ a.
  Proof.
  elim a using PA_induction.
  - represent.
  - now rewrite add_zero_l, add_zero_r.
  - intros a' IH. now rewrite add_succ_l, add_succ_r.
  Qed.

  Lemma add_assoc a b c : a i⊕ (b i⊕ c) = (a i⊕ b) i⊕ c.
  Proof.
  elim a using PA_induction.
  - represent.
  - now rewrite ! add_zero_l.
  - intros a' IH.
    now rewrite ! add_succ_l, IH.
  Qed.

  Lemma mul_zero_l a : iO i⊗ a = iO.
  Proof.
  rewrite <- D_ext.
  apply (@D_fulfills ax_mult_zero (fun _ => iO)). apply PAeq_FA. do 8 right. now left.
  Qed.

  Lemma mul_succ_l a b : iσ a i⊗ b = b i⊕ a i⊗ b.
  Proof.
  rewrite <- D_ext.
  apply (@D_fulfills ax_mult_rec (fun _ => iO)). apply PAeq_FA. do 9 right. now left.
  Qed.

  Lemma mul_zero_r a : a i⊗ iO = iO.
  Proof.
  elim a using PA_induction.
  - represent.
  - apply mul_zero_l.
  - intros d IH. now rewrite mul_succ_l, add_zero_l, IH.
  Qed.

  Lemma mul_succ_r a b : a i⊗ iσ b = a i⊕ a i⊗ b.
  Proof.
  elim a using PA_induction.
  - represent.
  - now rewrite ! mul_zero_l, add_zero_l.
  - intros d IH.
    rewrite ! mul_succ_l, ! add_succ_l. do 2 f_equal.
    rewrite IH. rewrite ! add_assoc.
    now rewrite (add_comm b d).
  Qed.

  Lemma mul_comm a b : a i⊗ b = b i⊗ a.
  Proof.
  elim a using PA_induction.
  - represent.
  - now rewrite mul_zero_l, mul_zero_r.
  - intros a' IH. now rewrite mul_succ_l, mul_succ_r.
  Qed.

  Definition test : representableP 0 (inum 5 = iσ (iσ (iσ (iσ (iσ iO))))).
  Proof. represent. Defined.
  Definition proj1 {X:Type} {Y:X->Type} (H:{x:X&Y x}) : X := match H with existT x y => x end.
  (* Eval cbn in (proj1 test). *)

End ReificationExample.


From Coq Require Import List Bool Arith ssreflect ssrbool Morphisms Lia.
From MetaCoq.Template Require Import MCPrelude MCReflect MCList MCRelations MCProd MCOption.
From Equations Require Import Equations.

Definition predA {A} (p q : pred A) : pred A := (fun i => p i ==> q i).

(*
Definition orP (p q : nat -> bool) (n : nat) : bool :=
  p n || q n.

Definition conjP (p q : nat -> bool) (n : nat) : bool :=
  p n && q n.

Definition implP (p q : nat -> bool) (n : nat) : bool :=
  p n ==> q n. *)

#[global] Instance orP_Proper {A} : Proper (`=1` ==> `=1` ==> `=1`) (@predU A).
Proof.
  intros f g Hfg f' g' Hfg' i; rewrite /predU /=.
  now rewrite Hfg Hfg'.
Qed.

#[global] Instance andP_Proper A : Proper (`=1` ==> `=1` ==> `=1`) (@predI A).
Proof.
  intros f g Hfg f' g' Hfg' i; rewrite /predI /=.
  now rewrite Hfg Hfg'.
Qed.

#[global] Instance implP_Proper {A} : Proper (`=1` ==> `=1` ==> `=1`) (@predA A).
Proof.
  intros f g Hfg f' g' Hfg' i; rewrite /predA /=.
  now rewrite Hfg Hfg'.
Qed.

Lemma orPL (p q : nat -> bool) : predA p (predU p q) =1 xpredT.
Proof.
  intros i. rewrite /predA /predU /=.
  rewrite (ssrbool.implybE (p i)).
  destruct (p i) => //.
Qed.

Lemma orPR (p q : nat -> bool) i : q i -> (predU p q) i.
Proof.
  rewrite /predU /= => ->; rewrite orb_true_r //.
Qed.


(******************************************************************************)
(** Lifting of relations to partial equivalence classes                       *)
(******************************************************************************)

Require Import HahnBase HahnSets HahnRelationsBasic.
Require Import Setoid HahnEquational.

Set Implicit Arguments.

Definition rel_classes T (eqv : relation T) (X : T -> Prop) :=
  exists x, X ≡₁ eqv x.

Definition rel_lift T (eqv r : relation T) (X Y : T -> Prop) :=
  exists x y, r x y /\ X ≡₁ eqv x /\ Y ≡₁ eqv y.

Definition rel_delift T (eqv : relation T) (r : relation (T -> Prop)) x y :=
  r (eqv x) (eqv y) /\ eqv x x /\ eqv y y.

Global Hint Unfold rel_classes rel_lift rel_delift : unfolderDb.

Add Parametric Morphism A : (@rel_lift A) with signature
  same_relation ==> same_relation ==> same_relation as rel_lift_more.
Proof.
  autounfold with unfolderDb in *; splits; ins; desf;
    do 2 eexists; splits; ins; desf; eauto.
Qed.

Add Parametric Morphism A : (@rel_lift A) with signature
  eq ==> inclusion ==> inclusion as rel_lift_mori.
Proof.
  autounfold with unfolderDb in *; splits; ins; desf;
    do 2 eexists; splits; ins; desf; eauto.
Qed.

Add Parametric Morphism A : (@rel_delift A) with signature
  eq ==> same_relation ==> same_relation as rel_delift_more.
Proof.
  autounfold with unfolderDb in *; splits; ins; desf; eauto 10.
Qed.

Add Parametric Morphism A : (@rel_delift A) with signature
  eq ==> inclusion ==> inclusion as rel_delift_mori.
Proof.
  autounfold with unfolderDb in *; ins; desf; eauto 10.
Qed.

Section lift_lemmas.

Variable T : Type.
Variables eqv r : relation T.
Hypothesis REFL: forall x y, r x y \/ r y x -> eqv x x.
Hypothesis SYM: symmetric eqv.
Hypothesis TRAN: transitive eqv.

Local Ltac u :=
  autounfold with unfolderDb in *; desc.

Lemma eq_class_expand x y z (D: r x z \/ r z x \/ r y z \/ r z y) :
  eqv x ≡₁ eqv y <-> eqv x y.
Proof using REFL SYM TRAN.
  u; intuition; eauto.
Qed.

Lemma step_lift x y :
  r x y -> (rel_lift eqv r) (eqv x) (eqv y).
Proof using.
  u; eauto 10.
Qed.

Lemma step_lift_iff x y :
  (rel_lift eqv r) (eqv x) (eqv y) <-> (eqv ⨾ r ⨾ eqv) x y.
Proof using REFL SYM TRAN.
  u; split; induction 1; desf; eauto.
  { repeat eexists; try apply H; splits; eauto. }
  all: do 2 eexists; splits; try edone; ins; desf; eauto.
Qed.

Lemma ct_lift :
  (rel_lift eqv r)⁺ ≡ rel_lift eqv (r ⨾ eqv)⁺.
Proof using REFL SYM TRAN.
  split; red; ins.
  { u; induction H; desf; eauto.
    { do 2 eexists; splits; eauto 6 using t_step. }
    exists x1, y0; splits; try eapply t_trans with x0; eauto.
    apply ct_end in IHclos_trans1; u.
    apply ct_end; u; do 2 (eexists; split; eauto).
  }
  red in H; desf; generalize dependent x; generalize dependent y.
  apply clos_trans_t1n in H.
  induction H; ins; desf; red in H; desc.
    apply t_step; u; do 2 eexists; splits; eauto.
  eapply t_trans; eauto.
  eapply t_step; u; do 2 eexists; splits; eauto.
Qed.

Lemma acyclic_lift :
  acyclic (rel_lift eqv r) <-> acyclic (r ⨾ eqv).
Proof using REFL SYM TRAN.
  unfold acyclic; rewrite ct_lift.
  unfold rel_lift, irreflexive; split; ins; desc; eauto 6.
  apply (H x0), ct_end; apply ct_end in H0; u; eauto 10.
Qed.

Lemma delift_restr_classes rel :
  rel_delift eqv (restr_rel (rel_classes eqv) rel) ≡ rel_delift eqv rel.
Proof using.
  u; intuition; desf; splits; ins; eauto.
Qed.

Lemma delift_lift rel :
  rel_delift eqv (rel_lift eqv rel) ≡ eqv ⨾ rel ⨾ eqv.
Proof using SYM TRAN.
  u; splits; ins; desf; splits; ins; desf; eauto 8.
  do 2 eexists; splits; eauto.
Qed.

Lemma delift_ct_lift :
  rel_delift eqv (rel_lift eqv r)⁺ ≡ eqv ⨾ (r ⨾ eqv)⁺.
Proof using REFL SYM TRAN.
  rewrite ct_lift, delift_lift, ct_end, !seqA.
  do 3 (apply seq_more; ins).
  u; split; ins; desf; eauto.
Qed.

End lift_lemmas.