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


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj8eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 (Succ lv1)) (Succ (plus lv1 lv0))).
Admitted.
QuickChick conj8eqsynthconj2.


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.