(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.MinMax.

(* Why3 assumption *)
Inductive list (a:Type) {a_WT:WhyType a} :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Axiom list_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (list a).
Existing Instance list_WhyType.
Implicit Arguments Nil [[a] [a_WT]].
Implicit Arguments Cons [[a] [a_WT]].

Axiom map : forall (a:Type) {a_WT:WhyType a} (b:Type) {b_WT:WhyType b}, Type.
Parameter map_WhyType : forall (a:Type) {a_WT:WhyType a}
  (b:Type) {b_WT:WhyType b}, WhyType (map a b).
Existing Instance map_WhyType.

Parameter get: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b.

Parameter set: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b -> (map a b).

Axiom Select_eq : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (m:(map a b)), forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) ->
  ((get (set m a1 b1) a2) = b1).

Axiom Select_neq : forall {a:Type} {a_WT:WhyType a}
  {b:Type} {b_WT:WhyType b}, forall (m:(map a b)), forall (a1:a) (a2:a),
  forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1) a2) = (get m a2)).

Parameter const: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  b -> (map a b).

Axiom Const : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (b1:b) (a1:a), ((get (const b1:(map a b)) a1) = b1).

(* Why3 assumption *)
Inductive datatype  :=
  | TYunit : datatype
  | TYint : datatype
  | TYbool : datatype .
Axiom datatype_WhyType : WhyType datatype.
Existing Instance datatype_WhyType.

(* Why3 assumption *)
Inductive value  :=
  | Vvoid : value
  | Vint : Z -> value
  | Vbool : bool -> value .
Axiom value_WhyType : WhyType value.
Existing Instance value_WhyType.

(* Why3 assumption *)
Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator
  | Ole : operator .
Axiom operator_WhyType : WhyType operator.
Existing Instance operator_WhyType.

Axiom mident : Type.
Parameter mident_WhyType : WhyType mident.
Existing Instance mident_WhyType.

(* Why3 assumption *)
Inductive ident  :=
  | mk_ident : Z -> ident .
Axiom ident_WhyType : WhyType ident.
Existing Instance ident_WhyType.

(* Why3 assumption *)
Definition ident_index(v:ident): Z := match v with
  | (mk_ident x) => x
  end.

(* Why3 assumption *)
Inductive term_node  :=
  | Tvalue : value -> term_node
  | Tvar : ident -> term_node
  | Tderef : mident -> term_node
  | Tbin : term -> operator -> term -> term_node
  with term  :=
  | mk_term : term_node -> Z -> term .
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

Axiom term_node_WhyType : WhyType term_node.
Existing Instance term_node_WhyType.

(* Why3 assumption *)
Definition term_maxvar(v:term): Z := match v with
  | (mk_term x x1) => x1
  end.

(* Why3 assumption *)
Definition term_node1(v:term): term_node :=
  match v with
  | (mk_term x x1) => x
  end.

(* Why3 assumption *)
Fixpoint var_occurs_in_term(x:ident) (t:term) {struct t}: Prop :=
  match t with
  | (mk_term (Tvalue _) _) => False
  | (mk_term (Tvar i) _) => (x = i)
  | (mk_term (Tderef _) _) => False
  | (mk_term (Tbin t1 _ t2) _) => (var_occurs_in_term x t1) \/
      (var_occurs_in_term x t2)
  end.

(* Why3 assumption *)
Definition term_inv(t:term): Prop := forall (x:ident), (var_occurs_in_term x
  t) -> ((ident_index x) <= (term_maxvar t))%Z.

(* Why3 assumption *)
Definition mk_tvalue(v:value): term := (mk_term (Tvalue v) (-1%Z)%Z).

Axiom mk_tvalue_inv : forall (v:value), (term_inv (mk_tvalue v)).

(* Why3 assumption *)
Definition mk_tvar(i:ident): term := (mk_term (Tvar i) (ident_index i)).

Axiom mk_tvar_inv : forall (i:ident), (term_inv (mk_tvar i)).

(* Why3 assumption *)
Definition mk_tderef(r:mident): term := (mk_term (Tderef r) (-1%Z)%Z).

Axiom mk_tderef_inv : forall (r:mident), (term_inv (mk_tderef r)).

(* Why3 assumption *)
Definition mk_tbin(t1:term) (o:operator) (t2:term): term := (mk_term (Tbin t1
  o t2) (Zmax (term_maxvar t1) (term_maxvar t2))).

Axiom mk_tbin_inv : forall (t1:term) (t2:term) (o:operator),
  ((term_inv t1) /\ (term_inv t2)) -> (term_inv (mk_tbin t1 o t2)).

(* Why3 assumption *)
Inductive fmla  :=
  | Fterm : term -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla
  | Flet : ident -> term -> fmla -> fmla
  | Fforall : ident -> datatype -> fmla -> fmla .
Axiom fmla_WhyType : WhyType fmla.
Existing Instance fmla_WhyType.

(* Why3 assumption *)
Inductive stmt  :=
  | Sskip : stmt
  | Sassign : mident -> term -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : term -> stmt -> stmt -> stmt
  | Sassert : fmla -> stmt
  | Swhile : term -> fmla -> stmt -> stmt .
Axiom stmt_WhyType : WhyType stmt.
Existing Instance stmt_WhyType.

(* Why3 assumption *)
Definition type_value(v:value): datatype :=
  match v with
  | Vvoid => TYunit
  | (Vint int) => TYint
  | (Vbool bool1) => TYbool
  end.

(* Why3 assumption *)
Inductive type_operator : operator -> datatype -> datatype
  -> datatype -> Prop :=
  | Type_plus : (type_operator Oplus TYint TYint TYint)
  | Type_minus : (type_operator Ominus TYint TYint TYint)
  | Type_mult : (type_operator Omult TYint TYint TYint)
  | Type_le : (type_operator Ole TYint TYint TYbool).

(* Why3 assumption *)
Definition type_stack  := (list (ident* datatype)%type).

Parameter get_vartype: ident -> (list (ident* datatype)%type) -> datatype.

Axiom get_vartype_def : forall (i:ident) (pi:(list (ident* datatype)%type)),
  match pi with
  | Nil => ((get_vartype i pi) = TYunit)
  | (Cons (x, ty) r) => ((x = i) -> ((get_vartype i pi) = ty)) /\
      ((~ (x = i)) -> ((get_vartype i pi) = (get_vartype i r)))
  end.

(* Why3 assumption *)
Definition type_env  := (map mident datatype).

(* Why3 assumption *)
Inductive type_term : (map mident datatype) -> (list (ident* datatype)%type)
  -> term -> datatype -> Prop :=
  | Type_value : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:value) (m:Z), (type_term sigma pi
      (mk_term (Tvalue v) m) (type_value v))
  | Type_var : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:ident) (m:Z) (ty:datatype), ((get_vartype v
      pi) = ty) -> (type_term sigma pi (mk_term (Tvar v) m) ty)
  | Type_deref : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:mident) (m:Z) (ty:datatype), ((get sigma
      v) = ty) -> (type_term sigma pi (mk_term (Tderef v) m) ty)
  | Type_bin : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t1:term) (t2:term) (op:operator) (m:Z) (ty1:datatype)
      (ty2:datatype) (ty:datatype), (type_term sigma pi t1 ty1) ->
      ((type_term sigma pi t2 ty2) -> ((type_operator op ty1 ty2 ty) ->
      (type_term sigma pi (mk_term (Tbin t1 op t2) m) ty))).

(* Why3 assumption *)
Inductive type_fmla : (map mident datatype) -> (list (ident* datatype)%type)
  -> fmla -> Prop :=
  | Type_term : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t:term), (type_term sigma pi t TYbool) ->
      (type_fmla sigma pi (Fterm t))
  | Type_conj : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f1:fmla) (f2:fmla), (type_fmla sigma pi f1) ->
      ((type_fmla sigma pi f2) -> (type_fmla sigma pi (Fand f1 f2)))
  | Type_neg : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f:fmla), (type_fmla sigma pi f) -> (type_fmla sigma
      pi (Fnot f))
  | Type_implies : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f1:fmla) (f2:fmla), (type_fmla sigma pi f1) ->
      ((type_fmla sigma pi f2) -> (type_fmla sigma pi (Fimplies f1 f2)))
  | Type_let : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (t:term) (f:fmla) (ty:datatype),
      (type_term sigma pi t ty) -> ((type_fmla sigma (Cons (x, ty) pi) f) ->
      (type_fmla sigma pi (Flet x t f)))
  | Type_forall1 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYint)
      pi) f) -> (type_fmla sigma pi (Fforall x TYint f))
  | Type_forall2 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYbool)
      pi) f) -> (type_fmla sigma pi (Fforall x TYbool f))
  | Type_forall3 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYunit)
      pi) f) -> (type_fmla sigma pi (Fforall x TYunit f)).

(* Why3 assumption *)
Inductive type_stmt : (map mident datatype) -> (list (ident* datatype)%type)
  -> stmt -> Prop :=
  | Type_skip : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)), (type_stmt sigma pi Sskip)
  | Type_seq : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (s1:stmt) (s2:stmt), (type_stmt sigma pi s1) ->
      ((type_stmt sigma pi s2) -> (type_stmt sigma pi (Sseq s1 s2)))
  | Type_assigns : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:mident) (t:term) (ty:datatype), ((get sigma
      x) = ty) -> ((type_term sigma pi t ty) -> (type_stmt sigma pi
      (Sassign x t)))
  | Type_if : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t:term) (s1:stmt) (s2:stmt), (type_term sigma pi t
      TYbool) -> ((type_stmt sigma pi s1) -> ((type_stmt sigma pi s2) ->
      (type_stmt sigma pi (Sif t s1 s2))))
  | Type_assert : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (p:fmla), (type_fmla sigma pi p) -> (type_stmt sigma
      pi (Sassert p))
  | Type_while : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (guard:term) (body:stmt) (inv:fmla), (type_fmla sigma
      pi inv) -> ((type_term sigma pi guard TYbool) -> ((type_stmt sigma pi
      body) -> (type_stmt sigma pi (Swhile guard inv body)))).

(* Why3 assumption *)
Definition env  := (map mident value).

(* Why3 assumption *)
Definition stack  := (list (ident* value)%type).

Parameter get_stack: ident -> (list (ident* value)%type) -> value.

Axiom get_stack_def : forall (i:ident) (pi:(list (ident* value)%type)),
  match pi with
  | Nil => ((get_stack i pi) = Vvoid)
  | (Cons (x, v) r) => ((x = i) -> ((get_stack i pi) = v)) /\ ((~ (x = i)) ->
      ((get_stack i pi) = (get_stack i r)))
  end.

Axiom get_stack_eq : forall (x:ident) (v:value) (r:(list (ident*
  value)%type)), ((get_stack x (Cons (x, v) r)) = v).

Axiom get_stack_neq : forall (x:ident) (i:ident) (v:value) (r:(list (ident*
  value)%type)), (~ (x = i)) -> ((get_stack i (Cons (x, v) r)) = (get_stack i
  r)).

Parameter eval_bin: value -> operator -> value -> value.

Axiom eval_bin_def : forall (x:value) (op:operator) (y:value), match (x,
  y) with
  | ((Vint x1), (Vint y1)) =>
      match op with
      | Oplus => ((eval_bin x op y) = (Vint (x1 + y1)%Z))
      | Ominus => ((eval_bin x op y) = (Vint (x1 - y1)%Z))
      | Omult => ((eval_bin x op y) = (Vint (x1 * y1)%Z))
      | Ole => ((x1 <= y1)%Z -> ((eval_bin x op y) = (Vbool true))) /\
          ((~ (x1 <= y1)%Z) -> ((eval_bin x op y) = (Vbool false)))
      end
  | (_, _) => ((eval_bin x op y) = Vvoid)
  end.

(* Why3 assumption *)
Fixpoint eval_term(sigma:(map mident value)) (pi:(list (ident* value)%type))
  (t:term) {struct t}: value :=
  match t with
  | (mk_term (Tvalue v) _) => v
  | (mk_term (Tvar id) _) => (get_stack id pi)
  | (mk_term (Tderef id) _) => (get sigma id)
  | (mk_term (Tbin t1 op t2) _) => (eval_bin (eval_term sigma pi t1) op
      (eval_term sigma pi t2))
  end.

(* Why3 assumption *)
Fixpoint eval_fmla(sigma:(map mident value)) (pi:(list (ident* value)%type))
  (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm t) => ((eval_term sigma pi t) = (Vbool true))
  | (Fand f1 f2) => (eval_fmla sigma pi f1) /\ (eval_fmla sigma pi f2)
  | (Fnot f1) => ~ (eval_fmla sigma pi f1)
  | (Fimplies f1 f2) => (eval_fmla sigma pi f1) -> (eval_fmla sigma pi f2)
  | (Flet x t f1) => (eval_fmla sigma (Cons (x, (eval_term sigma pi t)) pi)
      f1)
  | (Fforall x TYint f1) => forall (n:Z), (eval_fmla sigma (Cons (x,
      (Vint n)) pi) f1)
  | (Fforall x TYbool f1) => forall (b:bool), (eval_fmla sigma (Cons (x,
      (Vbool b)) pi) f1)
  | (Fforall x TYunit f1) => (eval_fmla sigma (Cons (x, Vvoid) pi) f1)
  end.

Parameter msubst_term: term -> mident -> ident -> term.

Axiom msubst_term_def : forall (t:term) (r:mident) (v:ident),
  match t with
  | (mk_term ((Tvalue _)|(Tvar _)) _) => ((msubst_term t r v) = t)
  | (mk_term (Tderef x) _) => ((r = x) -> ((msubst_term t r
      v) = (mk_tvar v))) /\ ((~ (r = x)) -> ((msubst_term t r v) = t))
  | (mk_term (Tbin t1 op t2) _) => ((msubst_term t r
      v) = (mk_tbin (msubst_term t1 r v) op (msubst_term t2 r v)))
  end.

Parameter subst_term: term -> ident -> ident -> term.

Axiom subst_term_def : forall (t:term) (r:ident) (v:ident),
  match t with
  | (mk_term ((Tvalue _)|(Tderef _)) _) => ((subst_term t r v) = t)
  | (mk_term (Tvar x) _) => ((r = x) -> ((subst_term t r
      v) = (mk_tvar v))) /\ ((~ (r = x)) -> ((subst_term t r v) = t))
  | (mk_term (Tbin t1 op t2) _) => ((subst_term t r
      v) = (mk_tbin (subst_term t1 r v) op (subst_term t2 r v)))
  end.

(* Why3 assumption *)
Definition fresh_in_term(id:ident) (t:term): Prop :=
  ((term_maxvar t) < (ident_index id))%Z.

Axiom eval_msubst_term : forall (sigma:(map mident value)) (pi:(list (ident*
  value)%type)) (e:term) (x:mident) (v:ident), (fresh_in_term v e) ->
  ((eval_term sigma pi (msubst_term e x v)) = (eval_term (set sigma x
  (get_stack v pi)) pi e)).

Axiom eval_subst_term : forall (sigma:(map mident value)) (pi:(list (ident*
  value)%type)) (e:term) (x:ident) (v:ident), (fresh_in_term v e) ->
  ((eval_term sigma pi (subst_term e x v)) = (eval_term sigma (Cons (x,
  (get_stack v pi)) pi) e)).

Axiom eval_term_change_free : forall (t:term) (sigma:(map mident value))
  (pi:(list (ident* value)%type)) (id:ident) (v:value), (fresh_in_term id
  t) -> ((eval_term sigma (Cons (id, v) pi) t) = (eval_term sigma pi t)).

(* Why3 assumption *)
Fixpoint fresh_in_fmla(id:ident) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => (fresh_in_term id e)
  | ((Fand f1 f2)|(Fimplies f1 f2)) => (fresh_in_fmla id f1) /\
      (fresh_in_fmla id f2)
  | (Fnot f1) => (fresh_in_fmla id f1)
  | (Flet y t f1) => (~ (id = y)) /\ ((fresh_in_term id t) /\
      (fresh_in_fmla id f1))
  | (Fforall y ty f1) => (~ (id = y)) /\ (fresh_in_fmla id f1)
  end.

(* Why3 assumption *)
Fixpoint subst(f:fmla) (x:ident) (v:ident) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_term e x v))
  | (Fand f1 f2) => (Fand (subst f1 x v) (subst f2 x v))
  | (Fnot f1) => (Fnot (subst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x v) (subst f2 x v))
  | (Flet y t f1) => (Flet y (subst_term t x v) (subst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (subst f1 x v))
  end.

(* Why3 assumption *)
Fixpoint msubst(f:fmla) (x:mident) (v:ident) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (msubst_term e x v))
  | (Fand f1 f2) => (Fand (msubst f1 x v) (msubst f2 x v))
  | (Fnot f1) => (Fnot (msubst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (msubst f1 x v) (msubst f2 x v))
  | (Flet y t f1) => (Flet y (msubst_term t x v) (msubst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (msubst f1 x v))
  end.

Axiom subst_fresh : forall (f:fmla) (x:ident) (v:ident), (fresh_in_fmla x
  f) -> ((subst f x v) = f).

Axiom let_subst : forall (t:term) (f:fmla) (x:ident) (id':ident) (id:mident),
  ((msubst (Flet x t f) id id') = (Flet x (msubst_term t id id') (msubst f id
  id'))).

Axiom eval_msubst : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (x:mident) (v:ident), (fresh_in_fmla v f) ->
  ((eval_fmla sigma pi (msubst f x v)) <-> (eval_fmla (set sigma x
  (get_stack v pi)) pi f)).

Axiom eval_subst : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (x:ident) (v:ident), (fresh_in_fmla v f) ->
  ((eval_fmla sigma pi (subst f x v)) <-> (eval_fmla sigma (Cons (x,
  (get_stack v pi)) pi) f)).

Axiom eval_swap : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (id1:ident) (id2:ident) (v1:value) (v2:value),
  (~ (id1 = id2)) -> ((eval_fmla sigma (Cons (id1, v1) (Cons (id2, v2) pi))
  f) <-> (eval_fmla sigma (Cons (id2, v2) (Cons (id1, v1) pi)) f)).

Axiom eval_same_var : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (id:ident) (v1:value) (v2:value), (eval_fmla sigma
  (Cons (id, v1) (Cons (id, v2) pi)) f) <-> (eval_fmla sigma (Cons (id, v1)
  pi) f).

Axiom eval_change_free : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (id:ident) (v:value), (fresh_in_fmla id f) ->
  ((eval_fmla sigma (Cons (id, v) pi) f) <-> (eval_fmla sigma pi f)).

(* Why3 assumption *)
Definition valid_fmla(p:fmla): Prop := forall (sigma:(map mident value))
  (pi:(list (ident* value)%type)), (eval_fmla sigma pi p).

Axiom let_equiv : forall (id:ident) (id':ident) (t:term) (f:fmla),
  forall (sigma:(map mident value)) (pi:(list (ident* value)%type)),
  (fresh_in_fmla id' f) -> ((eval_fmla sigma pi (Flet id' t (subst f id
  id'))) -> (eval_fmla sigma pi (Flet id t f))).

Axiom let_equiv2 : forall (id:ident) (id':ident) (t:term) (f:fmla),
  forall (sigma:(map mident value)) (pi:(list (ident* value)%type)),
  (fresh_in_fmla id' f) -> ((eval_fmla sigma pi (Flet id' t (subst f id
  id'))) -> (eval_fmla sigma pi (Flet id t f))).

Axiom let_implies : forall (id:ident) (t:term) (p:fmla) (q:fmla),
  (valid_fmla (Fimplies p q)) -> (valid_fmla (Fimplies (Flet id t p) (Flet id
  t q))).

(* Why3 assumption *)
Fixpoint fresh_in_stmt(id:ident) (s:stmt) {struct s}: Prop :=
  match s with
  | Sskip => True
  | (Sseq s1 s2) => (fresh_in_stmt id s1) /\ (fresh_in_stmt id s2)
  | (Sassign _ t) => (fresh_in_term id t)
  | (Sif t s1 s2) => (fresh_in_term id t) /\ ((fresh_in_stmt id s1) /\
      (fresh_in_stmt id s2))
  | (Sassert f) => (fresh_in_fmla id f)
  | (Swhile cond inv body) => (fresh_in_term id cond) /\ ((fresh_in_fmla id
      inv) /\ (fresh_in_stmt id body))
  end.

(* Why3 assumption *)
Inductive one_step : (map mident value) -> (list (ident* value)%type) -> stmt
  -> (map mident value) -> (list (ident* value)%type) -> stmt -> Prop :=
  | one_step_assign : forall (sigma:(map mident value)) (sigma':(map mident
      value)) (pi:(list (ident* value)%type)) (x:mident) (t:term),
      (sigma' = (set sigma x (eval_term sigma pi t))) -> (one_step sigma pi
      (Sassign x t) sigma' pi Sskip)
  | one_step_seq_noskip : forall (sigma:(map mident value)) (sigma':(map
      mident value)) (pi:(list (ident* value)%type)) (pi':(list (ident*
      value)%type)) (s1:stmt) (s1':stmt) (s2:stmt), (one_step sigma pi s1
      sigma' pi' s1') -> (one_step sigma pi (Sseq s1 s2) sigma' pi' (Sseq s1'
      s2))
  | one_step_seq_skip : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (s:stmt), (one_step sigma pi (Sseq Sskip s) sigma pi s)
  | one_step_if_true : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (t:term) (s1:stmt) (s2:stmt), ((eval_term sigma pi
      t) = (Vbool true)) -> (one_step sigma pi (Sif t s1 s2) sigma pi s1)
  | one_step_if_false : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (t:term) (s1:stmt) (s2:stmt), ((eval_term sigma pi
      t) = (Vbool false)) -> (one_step sigma pi (Sif t s1 s2) sigma pi s2)
  | one_step_assert : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (f:fmla), (eval_fmla sigma pi f) -> (one_step sigma pi
      (Sassert f) sigma pi Sskip)
  | one_step_while_true : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (cond:term) (inv:fmla) (body:stmt), (eval_fmla sigma pi
      inv) -> (((eval_term sigma pi cond) = (Vbool true)) -> (one_step sigma
      pi (Swhile cond inv body) sigma pi (Sseq body (Swhile cond inv body))))
  | one_step_while_falsee : forall (sigma:(map mident value)) (pi:(list
      (ident* value)%type)) (cond:term) (inv:fmla) (body:stmt),
      (eval_fmla sigma pi inv) -> (((eval_term sigma pi
      cond) = (Vbool false)) -> (one_step sigma pi (Swhile cond inv body)
      sigma pi Sskip)).

(* Why3 assumption *)
Inductive many_steps : (map mident value) -> (list (ident* value)%type)
  -> stmt -> (map mident value) -> (list (ident* value)%type) -> stmt
  -> Z -> Prop :=
  | many_steps_refl : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (s:stmt), (many_steps sigma pi s sigma pi s 0%Z)
  | many_steps_trans : forall (sigma1:(map mident value)) (sigma2:(map mident
      value)) (sigma3:(map mident value)) (pi1:(list (ident* value)%type))
      (pi2:(list (ident* value)%type)) (pi3:(list (ident* value)%type))
      (s1:stmt) (s2:stmt) (s3:stmt) (n:Z), (one_step sigma1 pi1 s1 sigma2 pi2
      s2) -> ((many_steps sigma2 pi2 s2 sigma3 pi3 s3 n) ->
      (many_steps sigma1 pi1 s1 sigma3 pi3 s3 (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (sigma1:(map mident value)) (sigma2:(map mident
  value)) (pi1:(list (ident* value)%type)) (pi2:(list (ident* value)%type))
  (s1:stmt) (s2:stmt) (n:Z), (many_steps sigma1 pi1 s1 sigma2 pi2 s2 n) ->
  (0%Z <= n)%Z.

Axiom many_steps_seq : forall (sigma1:(map mident value)) (sigma3:(map mident
  value)) (pi1:(list (ident* value)%type)) (pi3:(list (ident* value)%type))
  (s1:stmt) (s2:stmt) (n:Z), (many_steps sigma1 pi1 (Sseq s1 s2) sigma3 pi3
  Sskip n) -> exists sigma2:(map mident value), exists pi2:(list (ident*
  value)%type), exists n1:Z, exists n2:Z, (many_steps sigma1 pi1 s1 sigma2
  pi2 Sskip n1) /\ ((many_steps sigma2 pi2 s2 sigma3 pi3 Sskip n2) /\
  (n = ((1%Z + n1)%Z + n2)%Z)).

Axiom one_step_change_free : forall (s:stmt) (s':stmt) (sigma:(map mident
  value)) (sigma':(map mident value)) (pi:(list (ident* value)%type))
  (pi':(list (ident* value)%type)) (id:ident) (v:value), (fresh_in_stmt id
  s) -> ((one_step sigma (Cons (id, v) pi) s sigma' pi' s') ->
  (one_step sigma pi s sigma' pi' s')).

(* Why3 assumption *)
Definition valid_triple(p:fmla) (s:stmt) (q:fmla): Prop := forall (sigma:(map
  mident value)) (pi:(list (ident* value)%type)), (eval_fmla sigma pi p) ->
  forall (sigma':(map mident value)) (pi':(list (ident* value)%type)) (n:Z),
  (many_steps sigma pi s sigma' pi' Sskip n) -> (eval_fmla sigma' pi' q).

(* Why3 assumption *)
Definition total_valid_triple(p:fmla) (s:stmt) (q:fmla): Prop :=
  forall (sigma:(map mident value)) (pi:(list (ident* value)%type)),
  (eval_fmla sigma pi p) -> exists sigma':(map mident value),
  exists pi':(list (ident* value)%type), exists n:Z, (many_steps sigma pi s
  sigma' pi' Sskip n) /\ (eval_fmla sigma' pi' q).

Parameter x: ident.

Parameter y: mident.

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 3.

(* Why3 goal *)
Theorem Test55 : ((eval_term (const (Vint 0%Z):(map mident value)) (Cons (x,
  (Vint 42%Z)) (Nil :(list (ident* value)%type))) (mk_tbin (mk_tvar x) Oplus
  (mk_tvalue (Vint 13%Z)))) = (Vint 55%Z)).
simpl.
ae.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Defining type safety, page 67.

*)

Require Export LanguageModuleDef.
Require Export StaticSemantics.
Require Export DynamicSemanticsHeapObjects.
Require Export TacticNotations.

(* Bug, Miswrote theorem. I like the forall quantified version although
   I can naturally express this with exists.  *)
(* This is not the right induction just whacking a length on it. *)
(* I need to induct on path extension, perhaps reverse paths? *)

Functional Scheme rev_ind := Induction for rev Sort Prop.

Lemma A_11_Heap_Object_Safety_1:
  forall (v1 : E),
      forall (p : Path) (v2 : E) (v3 : E),
        get v1 p v2 ->
        get v1 p v3 ->
        v2 = v3.
Proof.
  intros v1.
  induction v1;
   try (intros p v2 v3 getv1pv2 getv1pv3;
        inversion getv1pv2;
        inversion getv1pv3;
        try reflexivity;
        crush).
  (* 1,2 should invert on getv1pv* why didn't it? *)
  specialize (IHv1_1 p0 v3 v2).
  apply IHv1_1 in H14.
  crush.
  assumption.

  specialize (IHv1_2 p0 v3 v2).
  apply IHv1_2 in H14.
  crush.
  assumption.

  specialize (IHv1 p0 v2 v3).
  apply IHv1 in H6.
  crush.
  assumption.
Qed.

Lemma A_11_Heap_Object_Safety_2:
  forall (v0 : E) (p1 : Path) (v1 : E),
    Value v0 ->
    Value v1 ->
    get v0 p1 v1 ->
    forall (p2 : Path) (v2 : E),
      Value v2 ->
      get v0 (p1 ++ p2) v2 ->
      get v1 p2 v2.
Proof.
  (* Try induction on the values. *)
  intros v0.
  (* Try to learn to get rid of silly goals. *)
  induction v0;
    try (
        intros p1 v1 val0 val1 getv0p1v1;
        inversion getv0p1v1;
        intros p2 v2 valv2;
        intros get;
        inversion get;
        crush).
  intros p1;
  induction p1 as [| pe1 p1'].
  Case "pair and p1=[]".
   intros v1 valpair valv1 getcpair p2 v2 valv2 getcpairnil.
   inversion getcpair.
   crush.

  (* A pair and a pack, nice strong induction hypotheses. *)
  Case "pair and pe1::p1".
    SCase "pe1= i which won't work".
    intros v1 valpair valv1 getcpair p2 v2 valv2 getcpairnil.
    destruct pe1; try destruct i.
    SSCase "pe1=zero_pe".
    inversion valpair; inversion getcpair; inversion getcpairnil; crush.
    specialize (IHv0_1 p1' v1 H1 H6 H10 p2 v2 H14 H18).
    assumption.
    SSCase "pe1=one_pe".
    inversion valpair.
    inversion getcpair.
    inversion getcpairnil.
    crush.
    specialize (IHv0_2 p1' v1 H2 H6  H10 p2 v2 H14 H18).
    assumption.
    SSCase "pe1=u_pe".
     inversion getcpair.
   Case "v0 is pack".
    intros p1 v1 valpack valv1.
    destruct p1.
    SCase "p1 is []".
    intros getpack p2 v2 valv2 getpackp2.
    rewrite app_nil_l in getpackp2.
    inversion valpack; inversion getpack; inversion getpackp2; crush.
    SCase "p1 is ".
     destruct p.
     intros integerpath.
     inversion integerpath.
     inversion valpack.
     intros getpacku p2 v2 valv2 step.
     inversion getpacku.
     crush.
     inversion step.
     crush.
     apply IHv0 with (p1:= p1); try assumption.
Qed.

Lemma A_11_Heap_Object_Safety_3:
  forall (h : Heap) (u : Upsilon) (g : Gamma)
         (x : EVar) (vhx v1 : E) (t1 t2: Tau)
         (p1 p2 : Path),
    Value v1 ->
    refp h u ->
    htyp u g h g ->
    H.map h x = Some vhx ->
    get vhx p1 v1 ->
    rtyp D.empty u g v1 t1 ->
    gettype u x p1 t1 p2 t2 ->
    (exists (v2 : E),
       get vhx (p1 ++ p2) v2 /\
       rtyp D.empty u g v2 t2) /\
    (forall (v2' : E),
       Value v2' ->
       (exists (v1' : E),
          Value v1' ->
          set v1 p2 v2' v1')).
Proof.
  intros h u g x vhx v1 t1 t2 p1 p2.
  intros valv1 refpder htypder getHder getder rtypder gettypeder.
  split.
  (* Try induction v1, p.
  induction v1; induction p2. 24 uncrushable goals. *)
  (* Try functional induction on get type, 12/24.*)
  gettype_ind_cases (induction gettypeder) Case;
    try inversion gettypeder;   (* 12/24 *)
    try (rewrite app_nil_r;
         apply ex_intro with (x:=v1);
         split;
         assumption;
         inversion gettypeder;
         assumption). (* 8/12 *)
  (* Well I chopped the goals down, but now is it actually provable? *)
  (* Scotch whisky society, 10.76, bunnahbin distilery,
     like smoking a hookah over oyster shells. *)
  crush.
(* Why can I not clear the bad goals with an inversion on rtypder? *)
(* destruct v1.  *)
(*  induction v1 *)
(* induction rtypder ? *)
  (* Have to get more in the context and then destruct v1. *)
  (* But it's an existential. *)
  (* assert (A: get v1 (i_pe zero_pe) v2). *)
  admit.
  admit.
  admit.
  admit.
  admit.
  admit.
  admit.
Admitted.

Lemma gettype_nil_path:
  forall (u : Upsilon) (x : EVar) (p : Path) (t1 t2 : Tau),
    gettype u x p t1 [] t2 ->
     t1 = t2.
Proof.
  intros u x p t1 t2.
  induction t1.
  crush.
  crush.
  crush.
  crush.
  crush.
  crush.
  intros.
Admitted.
(*
  destruct p0.
  compute in H.
  crush.
  compute in H.
  crush.
Qed.
*)
Lemma A_11_Heap_Object_Safety_3_induction_tests:
  forall (h : Heap) (u : Upsilon) (g : Gamma)
         (x : EVar) (vhx v1 : E) (t1 t2: Tau)
         (p1 p2 : Path),
    refp h u ->
    htyp u g h g ->
    H.map h x = Some vhx ->
    Value v1 ->
    get vhx p1 v1 ->
    rtyp D.empty u g v1 t1 ->
    gettype u x p1 t1 p2 t2 ->
    (exists (v2 : E),
       get vhx (p1 ++ p2) v2 /\
       rtyp D.empty u g v2 t2) /\
    (forall (v2' : E),
       Value v2' ->
       (exists (v1' : E),
          Value v1' ->
          set v1 p2 v2' v1')).
Proof.
Admitted.
(*
  intros h u g x vhx v1 t1 t2 p1 p2.
  intros refpder htypder valv1 H.mapder getder rtypder.
  induction p2; try destruct a; try destruct i.
  Case "p2=[]".
   intros gettypeder.
   apply gettype_nil_path in gettypeder.
   crush.
   apply ex_intro with (x:=v1).
   split.
   SCase "get".
    rewrite app_nil_r.
    assumption.
    assumption.
   SCase "set".
    apply ex_intro with (x:=v1).
    intros.
    assert (E: v1 = v2').
    admit. (* TODO apply both halves of the theorem in this goal. *)
    rewrite E.
    constructor.
    assumption.
    assumption.
  Case "p = zero_pe :: p2".
   intros gettypeder.
   destruct t1.
  (* Have to sequentially invert as this is unfolding some things we don't want.*)
  (* Just clearing meaningless goals. *)
   inversion gettypeder.
   inversion gettypeder.
   Focus 2.
   inversion gettypeder.
   Focus 2.
   inversion gettypeder.
   Focus 2.
   inversion gettypeder.
   (* Dan's one inversion is really three. *)
   destruct v1; inversion H.mapder; inversion rtypder.
   (* And crush is unfolding a gettypeder. *)
   apply A_10_Path_Extension_1_A with (v0:=v1_1 ) (v1:=v1_2) in getder.

   admit.
   admit.
   constructor; assumption.
   reflexivity.
  Case "p = one_pe :: p2".
   admit.
  Case "p = u_pe :: p2".
   admit.
Admitted.

Check A_11_Heap_Object_Safety_3.
*)

Lemma A_11_Heap_Object_Safety_3_Corollary :
  forall (h : Heap) (u : Upsilon) (g : Gamma)
         (x : EVar) (v1 : E) (t1 t2: Tau)
         (p2 : Path),
    Value v1 ->
    refp h u ->
    htyp u g h g ->
    H.map h x = Some v1 ->
    get v1 [] v1 ->
    rtyp D.empty u g v1 t1 ->
    gettype u x [] t1 p2 t2 ->
    (exists (v2 : E),
       get v1 ([] ++ p2) v2 /\
       rtyp D.empty u g v2 t2) /\
    (forall (v2' : E),
       Value v2' ->
       (exists (v1' : E),
          Value v1' ->
          set v1 p2 v2' v1')).
Proof.
  intros h u g x v1 t1 t2 p2.
  intros valv1 refpder htypder getHmapder getder rtypder gettypeder.
  apply A_11_Heap_Object_Safety_3 with (h:=h) (x:=x) (t1:=t1);
    try assumption;
    try constructor;
    try assumption.
Qed.

(*
Lemma A_11_Heap_Object_Safety_4:
  forall (h : Heap) (u : Upsilon) (g : Gamma)
         (x : EVar) (vhx v1 : E) (t1 t2: Tau)
         (p1 p2 : Path),
    Value v1 ->
    refp h u ->
    htyp u g h g ->
    H.map h x = Some vhx ->
    get vhx p1 v1 ->
    rtyp D.empty u g v1 t1 ->
    gettype u x p1 t1 p2 t2 ->
    (exists (v2 : E),
       get vhx (p1 ++ p2) v2 /\
       rtyp D.empty u g v2 t2) /\
    (forall (v2' : E),
       Value v2' ->
       (exists (v1' : E),
          Value v1' ->
          set v1 p2 v2' v1')) ->
    ASGN [] t2 ->
    forall (p':P),
      getU u x (p1++p2++p') = None.
Proof.
  (* By lemmas and case analysis on t2. *)
  intros h u g x vhx v1 t1 t2 p1 p2.
  intros valv1 refpder htypder H.mapder getder rtypder gettypeder.
  intros big.
  intros asgnder.
  intros p'.
  induction t2.
  Case "t2 = tvar t".
   inversion asgnder.
   assert (H1': getD [] t = None).
   apply getD_from_nil_None.
   rewrite H1 in H1'.
   inversion H1'.
  Case "t2 = cint".
   admit.
  Case "t2 = cross".
   admit.
  Case "t2 = arrow".
   admit.
  Case "t2 = ptype".
   admit.
  Case "t2 = utype".
   admit.
  Case "t2 = etype".
   admit.
Admitted.

(* TODO
Lemma A_11_Heap_Object_Safety_5.
Admitted.
Lemma A_11_Heap_Object_Safety_5_Corollary.
Admitted.
*)

*)


Require Export Structure.
Require Export Categories.Typ.

Module Topology.

Module obj.

Structure mixin_of T := Mixin {
  open: (T -> Prop) -> Prop;
  open_all: open (fun _ => True);
  open_union {I} (F: I -> T -> Prop): (forall i, open (F i)) -> open (fun x => exists i, F i x);
  open_and (A B: T -> Prop): open A -> open B -> open (fun x => A x /\ B x);
}.

Lemma mixin_eq {T} (c d: mixin_of T): c = d <-> (forall P, open T c P <-> open T d P).
Proof.
  split.
  now intros [].
  destruct c as [c c1 c2 c3], d as [d d1 d2 d3]; simpl.
  intros H.
  enough (c = d); [subst d|].
  f_equal; apply proof_irrelevance.
  extensionality P.
  apply propositional_extensionality.
  apply H.
Qed.

Structure type := Pack { sort: Type; _: mixin_of sort }.

Notation class_of := mixin_of (only parsing).

Section ClassDef.
Local Coercion sort: type >-> Sortclass.

Variable (T: type).
Definition class := match T return mixin_of T with Pack _ c => c end.

Let xT := match T with Pack T _ => T end.
Notation xclass := (class: mixin_of xT).

End ClassDef.

Module Exports.
Coercion sort: type >-> Sortclass.

Definition open (T: type): (T -> Prop) -> Prop := @open T (class T).
Definition open_all (T: type): open T (fun _ => True) := @open_all T (class T).
Definition open_union (T: type): forall {I} (F: I -> T -> Prop), (forall i, open T (F i)) -> open T (fun x => exists i, F i x) := @open_union T (class T).
Definition open_and (T: type): forall (A B: T -> Prop), open T A -> open T B -> open T (fun x => A x /\ B x) := @open_and T (class T).

Lemma open_all' (T: type) (P: T -> Prop): (forall x, P x) -> open T P.
Proof.
  intros H.
  replace P with (fun _: T => True).
  apply open_all.
  extensionality x.
  now apply propositional_extensionality.
Qed.

Lemma open_never' (T: type) (P: T -> Prop): (forall x, ~P x) -> open T P.
Proof.
  intros H.
  replace P with (fun x: T => exists i: False, (fun _ _ => True) i x).
  now apply open_union.
  extensionality x.
  apply propositional_extensionality.
  split.
  intros [[] _].
  intros Hx.
  now specialize (H x).
Qed.

Lemma open_never (T: type): open T (fun _ => False).
Proof. now apply open_never'. Qed.

Lemma open_or (T: type) (A B: T -> Prop): open T A -> open T B -> open T (fun x => A x \/ B x).
Proof.
  intros HA HB.
  cut (open T (fun x => exists b, (fun b: bool => if b then A else B) b x)).
  change (?P -> ?Q) with (impl P Q).
  f_equiv.
  extensionality x.
  apply propositional_extensionality.
  split.
  + intros [[] Hx].
    all: now [> left | right].
  + intros [Hx | Hx].
    now exists true.
    now exists false.
  + apply open_union.
    now intros [].
Qed.

Lemma open_filter (T: type) (P: Prop) (A: T -> Prop): (P -> open T A) -> open T (fun x => P /\ A x).
Proof.
  intros HA.
  destruct (classic P).
  specialize (HA H).
  revert HA.
  change (?P -> ?Q) with (impl P Q).
  f_equiv.
  extensionality x.
  now apply propositional_extensionality.
  now apply open_never'.
Qed.

Lemma open_union' (T: type) (F: (T -> Prop) -> Prop): (forall P, F P -> open T P) -> open T (fun x => exists P, F P /\ P x).
Proof.
  intros H.
  specialize (fun P => H (proj1_sig P) (proj2_sig P)).
  apply open_union in H.
  revert H.
  change (?P -> ?Q) with (impl P Q).
  f_equiv.
  extensionality x.
  apply propositional_extensionality.
  split.
  + intros [[P HP] Hx].
    now exists P.
  + intros [P [HP Hx]].
    now exists (exist _ P HP).
Qed.

Instance open_iff (T: type): Proper (pointwise_relation T iff ==> iff) (open T).
Proof.
  intros P Q H.
  f_equiv.
  extensionality x.
  now apply propositional_extensionality.
Qed.

End Exports.
End obj.
Export obj.Exports.
Notation obj := obj.type.

Structure hom (X Y: obj) := Hom {
  map: X -> Y;
  continue (P: Y -> Prop): open Y P -> open X (fun x => P (map x));
}.

Arguments map {X Y} h x.
Arguments continue {X Y} h P H.

Coercion map: hom >-> Funclass.

Lemma hom_eq {X Y: obj} (f g: hom X Y): f = g <-> forall x, f x = g x.
Proof.
  split.
  now intros [].
  destruct f as [f Hf], g as [g Hg]; simpl.
  intros H.
  enough (f = g); [subst g|].
  f_equal; apply proof_irrelevance.
  now extensionality x.
Qed.

Program Definition cat_mixin := Category.Mixin obj hom
  (fun X => {|
    map x := x;
    continue P H := H;
  |})
  (fun X Y Z f g => {|
    map x := f (g x);
    continue P H := continue g _ (continue f P H);
  |})
  _ _ _.
Next Obligation.
  now destruct f.
Qed.
Next Obligation.
  now destruct f.
Qed.

Canonical cat := Category.Pack obj cat_mixin.

Class Basis {I T} (F: I -> T -> Prop) :=
  basis: (forall x, exists i, F i x) /\
  (forall i j x, F i x -> F j x -> exists k, F k x /\ (forall x, F k x -> F i x /\ F j x)).

Program Definition basis_mixin {I T} (F: I -> T -> Prop) (H: Basis F) := obj.Mixin T (fun P => exists G: I -> Prop, (fun x => exists i, G i /\ F i x) = P) _ _ _.
Next Obligation.
  exists (fun _ => True).
  extensionality x.
  apply propositional_extensionality.
  split; intros _.
  constructor.
  destruct (proj1 H x) as [i Hi].
  now exists i.
Qed.
Next Obligation.
  rename I0 into J.
  apply ex_forall in H0.
  destruct H0 as [G HG].
  apply functional_extensionality_dep in HG.
  subst F0.
  exists (fun i => exists j, G j i).
  extensionality x.
  apply propositional_extensionality.
  split.
  + intros [i [[j Hj] Hi]].
    now exists j, i.
  + intros [j [i [Hj Hi]]].
    exists i; split.
    now exists j.
    exact Hi.
Qed.
Next Obligation.
  rename H0 into L, H1 into R.
  exists (fun i => exists l r, (L l /\ R r) /\ forall x, F i x -> F l x /\ F r x).
  extensionality x.
  apply propositional_extensionality.
  split.
  + intros [i [[l [r [[Hl Hr] Hi]]] Hx]].
    apply Hi in Hx.
    split.
    now exists l.
    now exists r.
  + intros [[l [Hl H1]] [r [Hr H2]]].
    destruct (proj2 H l r x H1 H2) as [i [Hx Hi]].
    exists i; split.
    now exists l, r.
    exact Hx.
Qed.

Lemma basis_open {I T} (F: I -> T -> Prop) (HF: Basis F) (P: T -> Prop): (exists i, forall x, F i x <-> P x) -> obj.open T (basis_mixin F HF) P.
Proof.
  intros [i Hi].
  exists (eq i).
  extensionality x.
  apply propositional_extensionality.
  rewrite <- Hi.
  split.
  now intros [_ [[] Hx]].
  intros Hx.
  now exists i.
Qed.

Lemma basis_continue {S: obj} {I T} (F: I -> T -> Prop) (HF: Basis F) (f: S -> T): (forall P: T -> Prop, obj.open T (basis_mixin F HF) P -> open S (fun x => P (f x))) <-> (forall i, open S (fun x => F i (f x))).
Proof.
  split.
  + intros H i.
    apply H, basis_open.
    now exists i.
  + intros H _ [P []].
    apply open_union.
    intros i.
    now apply open_filter.
Qed.

Instance open_basis (T: obj): Basis (fun P x => open T P /\ P x).
Proof.
  split.
  + intros x.
    exists (fun _ => True); split.
    apply open_all.
    exact I.
  + intros L R x [HL Lx] [HR Rx].
    exists (fun x => L x /\ R x); split.
    split.
    now apply open_and.
    all: easy.
Qed.

Lemma open_basis_eq (T: obj): basis_mixin (fun P x => open T P /\ P x) _ = obj.class T.
Proof.
  apply obj.mixin_eq.
  intros P.
  split.
  + revert P.
    apply basis_continue.
    intros i.
    now apply open_filter.
  + intros HP.
    apply basis_open.
    now exists P.
Qed.

Program Definition sig_mixin {T: obj} (P: T -> Prop) := basis_mixin (fun Q (x: sig P) => open T Q /\ Q (proj1_sig x)) _.
Next Obligation.
  split.
  + intros x.
    exists (fun _ => True); split.
    apply open_all.
    exact I.
  + intros L R x Lx Rx.
    exists (fun x => L x /\ R x); split.
    split.
    now apply open_and.
    all: easy.
Qed.

Canonical sig {T: obj} (P: T -> Prop) := obj.Pack (sig P) (sig_mixin P).

Program Canonical proj1_sig {T: obj} {P: T -> Prop} := {|
  map := @proj1_sig T P;
|}.
Next Obligation.
  apply basis_open.
  now exists P0.
Qed.

Module Open.

Structure obj (T: obj) := Obj {
  class: T -> Prop;
  class_open: open T class;
}.

Arguments class {T} o t.
Arguments class_open {T} o.
Coercion class: obj >-> Funclass.

Definition hom {T} (X Y: obj T) := forall x, X x -> Y x.

Lemma obj_eq {T} (X Y: obj T): X = Y <-> forall x, X x <-> Y x.
Proof.
  split.
  now intros [].
  destruct X as [X HX], Y as [Y HY]; simpl.
  intros H.
  enough (X = Y); [subst Y|].
  f_equiv; apply proof_irrelevance.
  extensionality x.
  apply propositional_extensionality.
  apply H.
Qed.

Lemma hom_eq {T} {X Y: obj T} (f g: hom X Y): f = g.
Proof. apply proof_irrelevance. Qed.

Program Definition cat_mixin T := Category.Mixin (obj T) hom
  (fun X x H => H)
  (fun X Y Z f g x H => f x (g x H))
  _ _ _.

Canonical cat T := Category.Pack (obj T) (cat_mixin T).

Program Definition Proj {T} := {|
  fobj (U: cat T) := sig U;
  fmap U V f := {|
    map x := exist _ (proj1_sig x) (f (proj1_sig x) (proj2_sig x));
  |};
|}.
Next Obligation.
  revert P H.
  apply basis_continue.
  intros P; simpl.
  apply basis_open.
  now exists P.
Qed.
Next Obligation.
  apply Topology.hom_eq; simpl.
  now intros [x Hx].
Qed.
Next Obligation.
  now apply Topology.hom_eq.
Qed.

Definition preimg {S T} (f: T ~> S) (X: obj S): obj T := {|
  class x := X (f x);
  class_open := continue f X (class_open X);
|}.

Definition preimg_inc {S T} (f: T ~> S) (X Y: obj S): X ~> Y -> preimg f X ~> preimg f Y.
Proof.
  intros H x.
  exact (H (f x)).
Qed.

Program Canonical Preimg {S T} (f: T ~> S): Functor (cat S) (cat T) := {|
  fobj := preimg f;
  fmap := preimg_inc f;
|}.
Next Obligation.
  apply hom_eq.
Qed.
Next Obligation.
  apply hom_eq.
Qed.

Program Definition img {S T} (f: S ~> T) (X: obj S): obj T := {|
  class y := exists Y, hom (preimg f Y) X /\ Y y;
|}.
Next Obligation.
  apply open_union.
  intros Y.
  destruct (classic (hom (preimg f Y) X)).
  generalize (class_open Y).
  change (?P -> ?Q) with (impl P Q).
  f_equiv.
  extensionality y.
  now apply propositional_extensionality.
  now apply open_never'.
Qed.

Definition img_inc {S T} (f: S ~> T) (X Y: obj S): X ~> Y -> img f X ~> img f Y.
Proof.
  intros H y [Z [HZ Hy]].
  exists Z; split.
  intros z Hz.
  apply H, HZ, Hz.
  exact Hy.
Qed.

Program Canonical Img {S T} (f: S ~> T): Functor (cat S) (cat T) := {|
  fobj := img f;
  fmap := img_inc f;
|}.
Next Obligation.
  apply hom_eq.
Qed.
Next Obligation.
  apply hom_eq.
Qed.

Lemma img_unit {S T} (f: S ~> T) (X: obj T): X ~> Img f (Preimg f X).
Proof.
  intros x Hx.
  exists X; split.
  2: exact Hx.
  intros y Hy.
  exact Hy.
Qed.

Program Canonical imgU {S T} (f: S ~> T): id (cat T) ~> Img f ∘ Preimg f := {|
  transform := img_unit f;
|}.
Next Obligation.
  apply hom_eq.
Qed.

Lemma img_counit {S T} (f: S ~> T) (X: obj S): Preimg f (Img f X) ~> X.
Proof.
  intros x [Y [H Hx]].
  apply H, Hx.
Qed.

Program Canonical imgCU {S T} (f: S ~> T): Preimg f ∘ Img f ~> id (cat S) := {|
  transform := img_counit f;
|}.
Next Obligation.
  apply hom_eq.
Qed.

Lemma img_adjoint_by {S T} (f: S ~> T): adjoint_by (Preimg f) (Img f) (imgU f) (imgCU f).
Proof.
  apply adjoint_by_alt; split.
  all: intros X.
  all: apply hom_eq.
Qed.

Program Definition top_mixin T := TopCategory.Mixin (cat T)
  {|
    class _ := True;
    class_open := open_all T;
  |}
  (fun _ _ _ => I)
  _.
Next Obligation.
  apply hom_eq.
Qed.

Canonical top T := TopCategory.Pack (cat T) (top_mixin T).

Program Definition prod_mixin T := ProdCategory.Mixin (cat T)
  (fun X Y => {|
    class x := X x /\ Y x;
  |})
  (fun X Y Z f g x H => conj (f x H) (g x H))
  (fun X Y x => @proj1 _ _)
  (fun X Y x => @proj2 _ _)
  _.
Next Obligation.
  apply open_and.
  all: apply class_open.
Qed.
Next Obligation.
  repeat split; intros.
  all: apply hom_eq.
Qed.

Canonical prod T := ProdCategory.Pack (cat T) (prod_mixin T).

Lemma preimg_prod {S T} (f: T ~> S) (X Y: obj S): preimg f (X × Y) = preimg f X × preimg f Y.
Proof. now apply obj_eq. Qed.

Lemma img_prod {S T} (f: S ~> T) (X Y: obj S): img f (X × Y) = img f X × img f Y.
Proof.
  apply obj_eq.
  intros x.
  split.
  + intros [Z [HZ Hx]].
    split.
    all: exists Z; split.
    2, 4: exact Hx.
    all: intros z Hz.
    all: apply HZ, Hz.
  + intros [[L [HL Lx]] [R [HR Rx]]].
    exists (L × R); split.
    2: now split.
    intros z Hz; split.
    apply HL, Hz.
    apply HR, Hz.
Qed.

Program Definition coprod_mixin T := CoprodCategory.Mixin (cat T)
  (fun X Y => {|
    class x := X x \/ Y x;
  |})
  (fun X Y Z f g x H =>
    match H with
    | or_introl H => f x H
    | or_intror H => g x H
    end
  )
  (fun X Y x => @or_introl _ _)
  (fun X Y x => @or_intror _ _)
  _.
Next Obligation.
  apply open_or.
  all: apply class_open.
Qed.
Next Obligation.
  repeat split; intros.
  all: apply hom_eq.
Qed.

Canonical coprod T := CoprodCategory.Pack (cat T) (coprod_mixin T).

Program Definition scoprod_mixin T := SCoprodCategory.Mixin (cat T)
  (fun I F => {|
    class x := exists i, F i x;
  |})
  _ _ _.
Next Obligation.
  apply open_union.
  intros i.
  apply class_open.
Qed.
Next Obligation.
  intros x [i H].
  exact (X0 i x H).
Qed.
Next Obligation.
  intros x H; simpl.
  now exists i.
Qed.
Next Obligation.
  split; intros.
  all: apply hom_eq.
Qed.

Canonical scoprod T := SCoprodCategory.Pack (cat T) (scoprod_mixin T).

Lemma preimg_scoprod {I S T} (f: T ~> S) (F: I -> obj S): preimg f (∑ i, F i) = ∑ i, preimg f (F i).
Proof. now apply obj_eq. Qed.

Lemma img_scoprod {I S T} (f: S ~> T) (F: I -> obj S): ∑ i, img f (F i) ~> img f (∑ i, F i).
Proof.
  intros y [i [Y [HY Hy]]].
  exists Y; split.
  2: exact Hy.
  intros x H.
  exists i.
  apply HY, H.
Qed.

End Open.

Notation Open := Open.cat.

Module OpenN.
Import Open.

Structure obj (T: Topology.obj) (x: T) := Obj {
  forget: Open.obj T;
  class_point: forget x;
}.

Arguments forget {T x} o.
Arguments class_point {T x} o.
Coercion forget: obj >-> Open.obj.

Definition hom {T x} (X Y: obj T x) := Open.hom X Y.

Lemma obj_eq {T x} (X Y: obj T x): X = Y <-> forall x, X x <-> Y x.
Proof.
  rewrite <- Open.obj_eq.
  split.
  now intros [].
  destruct X as [X HX], Y as [Y HY]; simpl.
  intros H.
  subst Y.
  f_equiv; apply proof_irrelevance.
Qed.

Lemma hom_eq {T x} {X Y: obj T x} (f g: hom X Y): f = g.
Proof. apply proof_irrelevance. Qed.

Program Definition cat_mixin T x := Category.Mixin (obj T x) hom
  (fun X x H => H)
  (fun X Y Z f g x H => f x (g x H))
  _ _ _.

Canonical cat T x := Category.Pack (obj T x) (cat_mixin T x).

Program Definition top_mixin T x := TopCategory.Mixin (cat T x)
  {|
    forget := 1;
    class_point := I;
  |}
  (fun _ _ _ => I)
  _.
Next Obligation.
  apply hom_eq.
Qed.

Canonical top T x := TopCategory.Pack (cat T x) (top_mixin T x).

Program Definition prod_mixin T x := ProdCategory.Mixin (cat T x)
  (fun X Y => {|
    forget := forget X × Y;
    class_point := conj (class_point X) (class_point Y);
  |})
  (fun X Y Z f g x H => conj (f x H) (g x H))
  (fun X Y x => @proj1 _ _)
  (fun X Y x => @proj2 _ _)
  _.
Next Obligation.
  repeat split; intros.
  all: apply hom_eq.
Qed.

Canonical prod T x := ProdCategory.Pack (cat T x) (prod_mixin T x).

Program Definition coprod_mixin T x := CoprodCategory.Mixin (cat T x)
  (fun X Y => {|
    forget := forget X + Y;
  |})
  (fun X Y Z f g x H =>
    match H with
    | or_introl H => f x H
    | or_intror H => g x H
    end
  )
  (fun X Y x => @or_introl _ _)
  (fun X Y x => @or_intror _ _)
  _.
Next Obligation.
  left.
  apply class_point.
Qed.
Next Obligation.
  repeat split; intros.
  all: apply hom_eq.
Qed.

Canonical coprod T x := CoprodCategory.Pack (cat T x) (coprod_mixin T x).

Definition forget_inc {T x} (X Y: obj T x) (H: hom X Y): Open.hom (forget X) (forget Y) := H.

Program Canonical Forget {T x}: Functor (cat T x) (Open T) := {|
  fobj := @forget T x;
  fmap := forget_inc;
|}.

End OpenN.

Notation OpenN := OpenN.cat.

Program Definition empty_mixin := obj.Mixin Empty_set (fun _ => True) _ _ _.
Canonical empty := obj.Pack Empty_set empty_mixin.

Program Definition botCat_mixin := BotCategory.Mixin cat
  empty
  (fun T => {|
    map := Empty_set_rect (fun _ => T);
    continue P _ := I;
  |})
  _.
Next Obligation.
  now apply hom_eq.
Qed.
Canonical botCat := BotCategory.Pack cat botCat_mixin.

Program Definition unit_mixin := obj.Mixin unit (fun _ => True) _ _ _.
Canonical unit := obj.Pack unit unit_mixin.

Program Definition topCat_mixin := TopCategory.Mixin cat
  unit
  (fun T => {|
    map _ := tt;
  |})
  _.
Next Obligation.
  destruct (classic (P tt)).
  now apply open_all'.
  now apply open_never'.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  intros x.
  now destruct (f x).
Qed.
Canonical topCat := TopCategory.Pack cat topCat_mixin.

Program Definition sum_mixin (T U: obj) := obj.Mixin (T + U) (fun P => open T (fun x => P (inl x)) /\ open U (fun x => P (inr x))) _ _ _.
Next Obligation.
  split; apply open_all.
Qed.
Next Obligation.
  split; apply open_union.
  all: intros i; apply H.
Qed.
Next Obligation.
  now split; apply open_and.
Qed.
Canonical sum (T U: obj) := obj.Pack (T + U) (sum_mixin T U).

Program Canonical inl {T U: obj} := {|
  map := @inl T U;
|}.
Next Obligation.
  apply H.
Qed.

Program Canonical inr {T U: obj} := {|
  map := @inr T U;
|}.
Next Obligation.
  apply H.
Qed.

Program Definition coprodCat_mixin := CoprodCategory.Mixin cat sum
  (fun L R T f g => {|
    map x := match x with Datatypes.inl x => f x | Datatypes.inr x => g x end;
  |})
  (@inl) (@inr)
  _.
Next Obligation.
  now split; apply continue.
Qed.
Next Obligation.
  split.
  + intros H.
    subst h.
    now split; apply hom_eq.
  + intros [].
    subst f g.
    apply hom_eq; simpl.
    now intros [].
Qed.
Canonical coprodCat := CoprodCategory.Pack cat coprodCat_mixin.

Program Definition prod_mixin (T U: obj) := basis_mixin (fun (P: (T -> Prop) * (U -> Prop)) p => (open T (fst P) /\ open U (snd P)) /\ fst P (fst p) /\ snd P (snd p)) _.
Next Obligation.
  split.
  + intros [x y].
    exists (fun _ => True, fun _ => True); split.
    split; apply open_all.
    now split.
  + intros [L1 R1] [L2 R2] p [H1 Hp1] [H2 Hp2]; simpl in *.
    exists (fun x => L1 x /\ L2 x, fun y => R1 y /\ R2 y); split.
    split.
    now split; apply open_and.
    now split.
    clear p Hp1 Hp2.
    now intros p [_]; simpl in *.
Qed.
Canonical prod (T U: obj) := obj.Pack (T * U) (prod_mixin T U).

Program Canonical fst {T U: obj} := {|
  map := @fst T U;
|}.
Next Obligation.
  apply basis_open.
  exists (P, (fun _ => True)); simpl.
  intros p; split.
  easy.
  intros Hp.
  do 2 split.
  exact H.
  apply open_all.
  exact Hp.
  exact I.
Qed.

Program Canonical snd {T U: obj} := {|
  map := @snd T U;
|}.
Next Obligation.
  apply basis_open.
  exists ((fun _ => True), P); simpl.
  intros p; split.
  easy.
  intros Hp.
  do 2 split.
  apply open_all.
  exact H.
  exact I.
  exact Hp.
Qed.

Program Definition prodCat_mixin := ProdCategory.Mixin cat prod
  (fun L R T f g => {|
    map x := (f x, g x);
  |})
  (@fst) (@snd)
  _.
Next Obligation.
  revert P H.
  apply basis_continue.
  intros [P Q]; simpl.
  apply open_filter.
  intros [HP HQ].
  apply open_and.
  all: now apply continue.
Qed.
Next Obligation.
  split.
  + intros H.
    subst h.
    now split; apply hom_eq.
  + intros [].
    subst f g.
    apply hom_eq; simpl.
    intros x.
    now destruct (h x).
Qed.
Canonical prodCat := ProdCategory.Pack cat prodCat_mixin.

Program Definition sigT_mixin {I} (F: I -> obj) := obj.Mixin (sigT F) (fun P => forall i, open (F i) (fun x => P (existT F i x))) _ _ _.
Next Obligation.
  apply open_all.
Qed.
Next Obligation.
  now apply open_union.
Qed.
Next Obligation.
  now apply open_and.
Qed.
Canonical sigT {I} (F: I -> obj) := obj.Pack (sigT F) (sigT_mixin F).

Program Canonical existT {I} (F: I -> obj) (i: I) := {|
  map := existT F i;
|}.

Program Canonical sigT_map {I T F} (f: forall i: I, hom (F i) T) := {|
  map := sigT_rect (fun _ => T) f;
|}.
Next Obligation.
  intros i; simpl.
  now apply continue.
Qed.

Program Definition scoprodCat_mixin := SCoprodCategory.Mixin cat (@sigT)
  (@sigT_map) (@existT) _.
Next Obligation.
  split.
  + intros H.
    subst g.
    intros i.
    now apply hom_eq.
  + intros H.
    apply functional_extensionality_dep in H.
    subst f.
    apply hom_eq; simpl.
    now intros [].
Qed.
Canonical scoprodCat := SCoprodCategory.Pack cat scoprodCat_mixin.

Program Definition Prod_mixin {I} (F: I -> obj) := basis_mixin (fun l (f: forall i, F i) => List.Forall (fun P => (exists i (Q: F i -> Prop), open (F i) Q /\ (fun f => Q (f i)) = P) /\ P f) l) _.
Next Obligation.
  split.
  + intros f.
    now exists nil.
  + intros l r f Hl Hr.
    exists (l ++ r)%list; split.
    now apply List_Forall_app.
    clear f Hl Hr.
    intros f.
    apply List_Forall_app.
Qed.

Definition Prod {I} (F: I -> obj) := obj.Pack (forall i, F i) (Prod_mixin F).

Program Definition sprodCat_mixin := SProdCategory.Mixin cat (@Prod)
  (fun I T F f => {|
    map x i := f i x;
  |})
  (fun I F i => {|
    map f := f i;
  |}) _.
Next Obligation.
  revert P H.
  apply basis_continue.
  intros l.
  setoid_rewrite List_Forall_and.
  apply open_filter.
  intros Hl.
  induction Hl.
  now apply open_all'.
  setoid_rewrite List_Forall_cons.
  apply open_and, IHHl.
  destruct H as [i [Q [HQ Hx]]].
  subst x.
  now apply continue.
Qed.
Next Obligation.
  apply basis_open.
  exists ((fun f => P (f i)) :: nil)%list.
  intros f.
  rewrite List_Forall_cons.
  split.
  now intros [[_ Hi] _].
  intros Hi.
  repeat split; [..|easy].
  now exists i, P.
  exact Hi.
Qed.
Next Obligation.
  split.
  + intros H.
    subst g.
    intros i.
    now apply hom_eq.
  + intros H.
    apply functional_extensionality_dep in H.
    subst f.
    now apply hom_eq.
Qed.
Canonical sprodCat := SProdCategory.Pack cat sprodCat_mixin.

Program Definition Pull_mixin {X Y Z: obj} (f: X ~> Z) (g: Y ~> Z) := basis_mixin (fun (P: ((X -> Prop) * (Y -> Prop))) (p: PullTyp f g) => (open X (Datatypes.fst P) /\ open Y (Datatypes.snd P)) /\ Datatypes.fst P (pfst p) /\ Datatypes.snd P (psnd p)) _.
Next Obligation.
  split.
  + intros p.
    exists (fun _ => True, fun _ => True); split.
    split; apply open_all.
    split; exact I.
  + intros [L1 R1] [L2 R2] p [H1 Hp1] [H2 Hp2]; simpl in *.
    exists (fun x => L1 x /\ L2 x, fun y => R1 y /\ R2 y); split.
    split.
    now split; apply open_and.
    now split.
    clear p Hp1 Hp2.
    now intros p [_ [Hp1 Hp2]]; simpl in *.
Qed.
Canonical Pull {X Y Z: obj} (f: X ~> Z) (g: Y ~> Z) := obj.Pack (PullTyp f g) (Pull_mixin f g).

Program Canonical pfst {X Y Z: obj} {f: X ~> Z} {g: Y ~> Z} := {|
  map := @pfst X Y Z f g;
|}.
Next Obligation.
  apply basis_open.
  exists (P, fun _ => True).
  intros p; split; simpl.
  now intros [_ [Hp _]].
  intros Hp; repeat split.
  exact H.
  apply open_all.
  exact Hp.
Qed.

Program Canonical psnd {X Y Z: obj} {f: X ~> Z} {g: Y ~> Z} := {|
  map := @psnd X Y Z f g;
|}.
Next Obligation.
  apply basis_open.
  exists (fun _ => True, P).
  intros p; split; simpl.
  now intros [_ [_ Hp]].
  intros Hp; repeat split.
  apply open_all.
  exact H.
  exact Hp.
Qed.

Program Definition pullCat_mixin := PullCategory.Mixin cat (@Pull)
  (@pfst) (@psnd)
  _
  (fun X Y Z V f g p1 p2 H => {|
    map x := {|
      PullTyp.pfst := p1 x;
      PullTyp.psnd := p2 x;
      PullTyp.comm := f_equal (fun f => map f x) H;
    |};
  |}) _ _ _.
Next Obligation.
  apply hom_eq, PullTyp.comm.
Qed.
Next Obligation.
  revert P H0.
  apply basis_continue.
  intros [L R]; simpl.
  apply open_filter.
  intros [HL HR].
  apply open_and.
  all: now apply continue.
Qed.
Next Obligation.
  now apply hom_eq.
Qed.
Next Obligation.
  now apply hom_eq.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  intros e.
  now apply PullTyp.t_eq.
Qed.

Canonical pullCat := PullCategory.Pack cat pullCat_mixin.

Program Canonical Forget: Functor cat Typ := {|
  fobj := obj.sort;
  fmap := @map;
|}.

Program Definition discrete_mixin T := obj.Mixin T (fun _ => True) _ _ _.
Definition discrete T := obj.Pack T (discrete_mixin T).

Program Definition discrete_map {S T} (f: S -> T): discrete S ~> discrete T := {|
  map := f;
|}.

Program Canonical Discrete: Functor Typ cat := {|
  fobj := discrete;
  fmap := @discrete_map;
|}.

Program Definition discreteU: id Typ ~> Forget ∘ Discrete := {|
  transform T x := x;
|}.

Program Definition discrete_unit (T: obj): discrete T ~> T := {|
  map x := x;
  continue P H := I;
|}.

Program Canonical discreteCU: Discrete ∘ Forget ~> id cat := {|
  transform := discrete_unit;
|}.

Lemma discrete_adjoint: adjoint_by Discrete Forget discreteU discreteCU.
Proof.
  apply adjoint_by_alt.
  split.
  + intros T.
    now apply hom_eq.
  + intros T.
    now extensionality x.
Qed.

Program Definition indiscrete_mixin T := obj.Mixin T (fun P => (fun _ => False) = P \/ (fun _ => True) = P) _ _ _.
Next Obligation.
  destruct (classic (forall i, (fun _ => False) = F i)).
  apply functional_extensionality_dep in H0.
  subst F.
  left.
  extensionality x.
  apply propositional_extensionality.
  split.
  intros [].
  intros [_ []].
  apply not_all_ex_not in H0.
  destruct H0 as [i Hi].
  destruct (H i).
  contradiction.
  right.
  extensionality x.
  apply propositional_extensionality.
  split; intros _.
  exists i.
  now rewrite <- H0.
  constructor.
Qed.
Next Obligation.
  destruct H, H0.
  all: subst A B.
  all: [> left..| right].
  all: extensionality x.
  all: now apply propositional_extensionality.
Qed.
Definition indiscrete T := obj.Pack T (indiscrete_mixin T).

Program Definition indiscrete_map {S T} (f: S -> T): indiscrete S ~> indiscrete T := {|
  map := f;
|}.
Next Obligation.
  destruct H; subst P.
  apply open_never.
  apply open_all.
Qed.

Program Canonical Indiscrete: Functor Typ cat := {|
  fobj := indiscrete;
  fmap := @indiscrete_map;
|}.
Next Obligation.
  now apply hom_eq.
Qed.
Next Obligation.
  now apply hom_eq.
Qed.

Program Definition indiscrete_unit (T: obj): T ~> indiscrete T := {|
  map x := x;
|}.
Next Obligation.
  destruct H; subst P.
  apply open_never.
  apply open_all.
Qed.

Program Canonical indiscreteU: id cat ~> Indiscrete ∘ Forget := {|
  transform := indiscrete_unit;
|}.
Next Obligation.
  now apply hom_eq.
Qed.

Program Definition indiscreteCU: Forget ∘ Indiscrete ~> id Typ := {|
  transform T x := x;
|}.

Lemma indiscrete_adjoint: adjoint_by Forget Indiscrete indiscreteU indiscreteCU.
Proof.
  apply adjoint_by_alt.
  split.
  + intros T.
    now extensionality x.
  + intros T.
    now apply hom_eq.
Qed.

End Topology.

Export Topology.obj.Exports.
Coercion Topology.map: Topology.hom >-> Funclass.
Canonical Topology.Open.Preimg.
Canonical Topology.Open.Img.
Canonical Topology.Open.imgU.
Canonical Topology.Open.imgCU.
Canonical Topology.Open.cat.
Canonical Topology.Open.prod.
Canonical Topology.Open.coprod.
Canonical Topology.Open.scoprod.
Coercion Topology.Open.class: Topology.Open.obj >-> Funclass.
Canonical Topology.OpenN.cat.
Canonical Topology.OpenN.prod.
Canonical Topology.OpenN.coprod.
Canonical Topology.OpenN.Forget.
Coercion Topology.OpenN.forget: Topology.OpenN.obj >-> Topology.Open.obj.
Canonical Topology.sig.
Canonical Topology.empty.
Canonical Topology.unit.
Canonical Topology.sum.
Canonical Topology.prod.
Canonical Topology.inl.
Canonical Topology.inr.
Canonical Topology.fst.
Canonical Topology.snd.
Canonical Topology.sigT.
Canonical Topology.existT.
Canonical Topology.cat.
Canonical Topology.botCat.
Canonical Topology.topCat.
Canonical Topology.coprodCat.
Canonical Topology.prodCat.
Canonical Topology.scoprodCat.
Canonical Topology.sprodCat.
Canonical Topology.Forget.
Canonical Topology.Discrete.
Canonical Topology.discreteCU.
Canonical Topology.Indiscrete.
Canonical Topology.indiscreteU.
Notation Topology := Topology.cat.


Require Import Coq.Lists.List.
Require Import Relations RelationClasses.
Require Import ExtLib.Core.Type.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Proper.
Require Import ExtLib.Data.SigT.
Require Import ExtLib.Data.Member.
Require Import ExtLib.Data.ListNth.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Tactics.
Require Import Coq.Classes.Morphisms.

Set Implicit Arguments.
Set Strict Implicit.
Set Asymmetric Patterns.
Set Universe Polymorphism.
Set Printing Universes.

Lemma app_ass_trans@{X}
: forall {T : Type@{X} } (a b c : list T), (a ++ b) ++ c = a ++ b ++ c.
Proof.
  induction a; simpl.
  reflexivity.
  intros. destruct (IHa b c). reflexivity.
Defined.

Lemma app_nil_r_trans : forall {T : Type} (a : list T), a ++ nil = a.
Proof.
  induction a; simpl.
  reflexivity.
  refine match IHa in _ = X return _ = _ :: X with
         | eq_refl => eq_refl
         end.
Defined.

Monomorphic Universe hlist_large.

(** Core Type and Functions **)
Section hlist.
  Polymorphic Universe Ui Uv.

  Context {iT : Type@{Ui}}.
  Variable F : iT -> Type@{Uv}.

  Inductive hlist : list iT -> Type :=
  | Hnil  : hlist nil
  | Hcons : forall l ls, F l -> hlist ls -> hlist (l :: ls).

  Definition hlist_hd {a b} (hl : hlist (a :: b)) : F a :=
    match hl in hlist x return match x return Type@{Uv} with
                               | nil => unit
                               | l :: _ => F l
                               end with
    | Hnil => tt
    | Hcons _ _ x _ => x
    end.

  Definition hlist_tl {a b} (hl : hlist (a :: b)) : hlist b :=
    match hl in hlist x return match x return Type@{hlist_large} with
                                 | nil => unit
                                 | _ :: ls => hlist ls
                               end with
      | Hnil => tt
      | Hcons _ _ _ x => x
    end.

  Lemma hlist_eta : forall ls (h : hlist ls),
    h = match ls as ls return hlist ls -> hlist ls with
        | nil => fun _ => Hnil
        | a :: b => fun h => Hcons (hlist_hd h) (hlist_tl h)
        end h.
  Proof.
    intros. destruct h; auto.
  Qed.

  Fixpoint hlist_app ll lr (h : hlist ll) : hlist lr -> hlist (ll ++ lr) :=
    match h in hlist ll return hlist lr -> hlist (ll ++ lr) with
    | Hnil => fun x => x
    | Hcons _ _ hd tl => fun r => Hcons hd (hlist_app tl r)
    end.

  Lemma hlist_app_nil_r
  : forall ls (h : hlist ls),
      hlist_app h Hnil =
      match eq_sym (app_nil_r_trans ls) in _ = t return hlist t with
      | eq_refl => h
      end.
  Proof.
    induction h; simpl; intros; auto.
    rewrite IHh at 1.
    unfold eq_trans. unfold f_equal. unfold eq_sym.
    clear. revert h.
    generalize dependent (app_nil_r_trans ls).
    destruct e. reflexivity.
  Qed.

  Fixpoint hlist_rev' ls ls' (h : hlist ls) : hlist ls' -> hlist (rev ls ++ ls') :=
    match h in hlist ls return hlist ls' -> hlist (rev ls ++ ls') with
    | Hnil => fun h => h
    | Hcons l ls0 x h' => fun hacc =>
      match app_ass_trans (rev ls0) (l :: nil) ls' in _ = t
            return hlist t -> hlist _
      with
      | eq_refl => fun x => x
      end (@hlist_rev' _ (l :: ls') h' (Hcons x hacc))
    end.

  Definition hlist_rev ls (h : hlist ls) : hlist (rev ls) :=
    match app_nil_r_trans (rev ls) in _ = t return hlist t with
      | eq_refl => hlist_rev' h Hnil
    end.

  Lemma hlist_rev_nil : hlist_rev Hnil = Hnil.
  Proof.
    reflexivity.
  Qed.

  (** TODO: I need hlist_rev_cons **)

  (** Equivalence **)
  (** TODO: This should change to relations **)
  Section equiv.
    Variable eqv : forall x, relation (F x).

    Inductive equiv_hlist : forall ls, hlist ls -> hlist ls -> Prop :=
    | hlist_eqv_nil : equiv_hlist Hnil Hnil
    | hlist_eqv_cons : forall l ls x y h1 h2, eqv x y -> equiv_hlist h1 h2 ->
      @equiv_hlist (l :: ls) (Hcons x h1) (Hcons y h2).

    Global Instance Reflexive_equiv_hlist (R : forall t, Reflexive (@eqv t)) ls
    : Reflexive (@equiv_hlist ls).
    Proof.
      red. induction x; constructor; auto. reflexivity.
    Qed.

    Global Instance Symmetric_equiv_hlist (R : forall t, Symmetric (@eqv t)) ls
    : Symmetric (@equiv_hlist ls).
    Proof.
      red. induction 1.
      { constructor. }
      { constructor. symmetry. assumption. auto. }
    Qed.

    Global Instance Transitive_equiv_hlist (R : forall t, Transitive (@eqv t)) ls
    : Transitive (@equiv_hlist ls).
    Proof.
      red. induction 1.
      { intro; assumption. }
      { rewrite (hlist_eta z).
        refine
          (fun H' =>
             match H' in @equiv_hlist ls X Y
                   return
                   match ls as ls return hlist ls -> hlist ls -> Prop with
                     | nil => fun _ _ : hlist nil => True
                     | l :: ls => fun (X Y : hlist (l :: ls)) =>
                                    forall Z x xs,
                                      eqv (hlist_hd Z) (hlist_hd X) ->
                                      equiv_hlist xs (hlist_tl X) ->
                                      (forall z : hlist ls,
                                         equiv_hlist (hlist_tl X) z ->
                                         equiv_hlist (hlist_tl Z) z) ->
                                      @equiv_hlist (l :: ls) Z Y
                   end X Y
             with
               | hlist_eqv_nil => I
               | hlist_eqv_cons l ls x y h1 h2 pf pf' => _
             end (Hcons x h1) x _ H H0 (@IHequiv_hlist)).
        intros. rewrite (hlist_eta Z).
        constructor. simpl in *. etransitivity. eassumption. eassumption.
        eapply H3. simpl in *. eassumption. }
    Qed.

    Lemma equiv_hlist_Hcons
    : forall ls i a b (c : hlist ls) d,
        equiv_hlist (Hcons a c) (@Hcons i ls b d) ->
        (@eqv i a b /\ equiv_hlist c d).
    Proof.
      clear. intros.
      refine
        match H in @equiv_hlist ls' l r
              return match ls' as ls' return hlist ls' -> hlist ls' -> _ with
                       | nil => fun _ _ => True
                       | l :: ls => fun l r =>
                                      eqv (hlist_hd l) (hlist_hd r) /\
                                      equiv_hlist (hlist_tl l) (hlist_tl r)
                     end l r
        with
          | hlist_eqv_nil => I
          | hlist_eqv_cons _ _ _ _ _ _ pf pf' => conj pf pf'
        end.
    Defined.

    Lemma equiv_hlist_app
    : forall a b (c c' : hlist a)  (d d' : hlist b),
        (equiv_hlist c c' /\ equiv_hlist d d')
        <->
        equiv_hlist (hlist_app c d) (hlist_app c' d').
    Proof.
      clear. split.
      - destruct 1.
        induction H.
        + assumption.
        + simpl. constructor; auto.
      - induction c.
        + rewrite (hlist_eta c').
          simpl; intros; split; auto. constructor.
        + rewrite (hlist_eta c'); simpl.
          specialize (IHc (hlist_tl c')).
          intro.
          eapply equiv_hlist_Hcons in H. intuition.
          constructor; auto.
    Qed.

    Global Instance Injection_equiv_hlist_cons ls i a b (c : hlist ls) d
    : Injective (equiv_hlist (Hcons a c) (@Hcons i ls b d)) :=
    { result := @eqv i a b /\ equiv_hlist c d
    ; injection := @equiv_hlist_Hcons _ _ _ _ _ _ }.

    Global Instance Injection_equiv_hlist_app a b (c c' : hlist a) (d d' : hlist b)
    : Injective (equiv_hlist (hlist_app c d) (hlist_app c' d')) :=
    { result := equiv_hlist c c' /\ equiv_hlist d d'
    ; injection := fun x => proj2 (@equiv_hlist_app _ _ _ _ _ _) x }.

  End equiv.

  Lemma hlist_nil_eta : forall (h : hlist nil), h = Hnil.
  Proof.
    intros; rewrite (hlist_eta h); reflexivity.
  Qed.

  Lemma hlist_cons_eta : forall a b (h : hlist (a :: b)),
    h = Hcons (hlist_hd h) (hlist_tl h).
  Proof.
    intros; rewrite (hlist_eta h); reflexivity.
  Qed.

  Lemma Hcons_inv
  : forall l ls a b c d,
      @eq (hlist (l :: ls)) (Hcons a b) (Hcons c d) ->
      a = c /\ b = d.
  Proof.
    intros.
    refine (
        match H as K in _ = Z
              return match Z in hlist LS
                           return match LS with
                                    | nil => Prop
                                    | l :: ls => F l -> hlist ls -> Prop
                                  end
                     with
                       | Hcons X Y x y => fun a b => a = x /\ b = y
                       | Hnil => True
                     end a b
        with
          | eq_refl => conj eq_refl eq_refl
        end).
  Qed.

  Global Instance Injection_hlist_cons ls t (a : F t) (b : hlist ls) c d
  : Injective (Hcons a b = Hcons c d) :=
    { result := a = c /\ b = d
    ; injection := @Hcons_inv t ls a b c d
    }.

  Theorem equiv_eq_eq : forall ls (x y : hlist ls),
                          equiv_hlist (fun x => @eq _) x y <-> x = y.
  Proof.
    induction x; simpl; intros.
    { split. inversion 1. rewrite hlist_nil_eta. reflexivity.
      intros; subst; constructor. }
    { split.
      { intro. rewrite (hlist_eta y).
        specialize (IHx (hlist_tl y)).
        refine (match H in @equiv_hlist _ LS X Y
                      return match X in hlist LS
                                   return F match LS with
                                              | nil => l
                                              | l :: _ => l
                                            end ->
                                          hlist match LS with
                                                  | nil => ls
                                                  | _ :: ls => ls
                                                end ->
                                          Prop
                             with
                               | Hnil => fun _ _ => True
                               | Hcons a b c d => fun x y =>
                                                    (equiv_hlist (fun x0 : iT => eq) d y <-> d = y) ->
                                                    @Hcons a b c d = Hcons x y
                             end (match LS as LS return hlist LS -> F match LS with
                                                                        | nil => l
                                                                        | l :: _ => l
                                                                      end
                                  with
                                    | nil => fun _ => f
                                    | l :: ls => hlist_hd
                                  end Y)
                                 (match LS as LS return hlist LS -> hlist match LS with
                                                                            | nil => ls
                                                                            | _ :: ls => ls
                                                                          end
                                  with
                                    | nil => fun _ => x
                                    | l :: ls => hlist_tl
                                  end Y)
                with
                  | hlist_eqv_nil => I
                  | hlist_eqv_cons l ls x y h1 h2 pf1 pf2 => _
                end IHx).
        simpl.
        subst. intros.
        f_equal. apply H0. assumption. }
      { intros; subst. constructor; auto.
        reflexivity. } }
  Qed.

  Fixpoint hlist_get ls a (m : member a ls) : hlist ls -> F a :=
    match m in member _ ls return hlist ls -> F a with
      | MZ _ => hlist_hd
      | MN _ _ r => fun hl => hlist_get r (hlist_tl hl)
    end.

  Fixpoint hlist_nth_error {ls} (hs : hlist ls) (n : nat)
    : option (match nth_error ls n with
                | None => unit
                | Some x => F x
              end) :=
    match hs in hlist ls return option (match nth_error ls n with
                                          | None => unit
                                          | Some x => F x
                                        end)
      with
      | Hnil => None
      | Hcons l ls h hs =>
        match n as n return option (match nth_error (l :: ls) n with
                                      | None => unit
                                      | Some x => F x
                                    end)
          with
          | 0 => Some h
          | S n => hlist_nth_error hs n
        end
    end.

  Polymorphic Fixpoint hlist_nth ls (h : hlist ls) (n : nat) :
    match nth_error ls n return Type with
      | None => unit
      | Some t => F t
    end :=
    match h in hlist ls , n as n
      return match nth_error ls n with
               | None => unit
               | Some t => F t
             end
      with
      | Hnil , 0 => tt
      | Hnil , S _ => tt
      | Hcons _ _ x _ , 0 => x
      | Hcons _ _ _ h , S n => hlist_nth h n
    end.

  Fixpoint nth_error_hlist_nth ls (n : nat)
  : option (hlist ls -> match nth_error ls n with
                          | None => Empty_set
                          | Some x => F x
                        end) :=
    match ls as ls
          return option (hlist ls -> match nth_error ls n with
                                       | None => Empty_set
                                       | Some x => F x
                                     end)
    with
      | nil => None
      | l :: ls =>
        match n as n
              return option (hlist (l :: ls) -> match nth_error (l :: ls) n with
                                                  | None => Empty_set
                                                  | Some x => F x
                                                end)
        with
          | 0 => Some hlist_hd
          | S n =>
            match nth_error_hlist_nth ls n with
              | None => None
              | Some f => Some (fun h => f (hlist_tl h))
            end
        end
    end.

  Definition cast1 T l
  : forall (l' : list T) n v,
      nth_error l n = Some v -> Some v = nth_error (l ++ l') n.
  Proof.
    induction l. intros.
    { exfalso. destruct n; inversion H. }
    { destruct n; simpl; intros; auto. }
  Defined.

  Definition cast2 T l
  : forall (l' : list T) n,
      nth_error l n = None ->
      nth_error l' (n - length l) = nth_error (l ++ l') n.
  Proof.
    induction l; simpl.
    { destruct n; simpl; auto. }
    { destruct n; simpl; auto.
      inversion 1. }
  Defined.

  Theorem hlist_nth_hlist_app
  : forall l l' (h : hlist l) (h' : hlist l') n,
    hlist_nth (hlist_app h h') n =
    match nth_error l n as k
      return nth_error l n = k ->
      match nth_error (l ++ l') n return Type with
        | None => unit
        | Some t => F t
      end
    with
      | Some _ => fun pf =>
        match
          cast1 _ _ _ pf in _ = z ,
          eq_sym pf in _ = w
          return match w return Type with
                   | None => unit
                   | Some t => F t
                 end ->
                 match z return Type with
                   | None => unit
                   | Some t => F t
                 end
        with
          | eq_refl , eq_refl => fun x => x
        end (hlist_nth h n)
      | None => fun pf =>
        match cast2 _ _ _ pf in _ = z
          return match z with
                   | Some t => F t
                   | None => unit
                 end
        with
          | eq_refl => hlist_nth h' (n - length l)
        end
    end eq_refl.
  Proof.
    induction h; simpl; intros.
    { destruct n; simpl in *; reflexivity. }
    { destruct n; simpl.
      { reflexivity. }
      { rewrite IHh. reflexivity. } }
  Qed.

  Section type.
    Variable eqv : forall x, type (F x).

    Global Instance type_hlist (ls : list iT): type (hlist ls) :=
    { equal := @equiv_hlist (fun x => @equal _ (eqv x)) ls
    ; proper :=
      (fix recur ls (h : hlist ls) : Prop :=
        match h with
          | Hnil => True
          | Hcons _ _ x y => proper x /\ recur _ y
        end) ls
    }.

    Variable eqvOk : forall x, typeOk (eqv x).

    Global Instance typeOk_hlist (ls : list iT): typeOk (type_hlist ls).
    Proof.
      constructor.
      { induction ls; intros.
        { rewrite (hlist_eta x) in *. rewrite (hlist_eta y) in *.
          clear. compute; auto. }
        { rewrite (hlist_eta x) in *. rewrite (hlist_eta y) in *.
          simpl in H.
          inv_all. eapply IHls in H1.
          eapply only_proper in H0; eauto.
          simpl; tauto. } }
      { intro. induction ls; simpl.
        { rewrite (hlist_eta x); intros; constructor. }
        { rewrite (hlist_eta x); intros; intuition; constructor.
          eapply preflexive; [ | eauto with typeclass_instances ].
          eauto with typeclass_instances.
          eapply IHls; eauto. } }
      { red. induction 1.
        { constructor. }
        { constructor. symmetry. assumption. assumption. } }
      { red. induction 1.
        { auto. }
        { intro H1.
          etransitivity; [ | eassumption ].
          constructor; eauto. } }
    Qed.

    Global Instance proper_hlist_app l l' : proper (@hlist_app l l').
    Proof.
      do 6 red. induction 1; simpl; auto.
      { intros. constructor; eauto.
        eapply IHequiv_hlist. exact H1. }
    Qed.

    Lemma hlist_app_assoc : forall ls ls' ls''
                                 (a : hlist ls) (b : hlist ls') (c : hlist ls''),
      hlist_app (hlist_app a b) c =
      match eq_sym (app_ass_trans ls ls' ls'') in _ = t return hlist t with
        | eq_refl => hlist_app a (hlist_app b c)
      end.
    Proof.
      intros ls ls' ls''.
      generalize (eq_sym (app_assoc_reverse ls ls' ls'')).
      induction ls; simpl; intros.
      { rewrite (hlist_eta a); simpl.
        reflexivity. }
      { rewrite (hlist_eta a0). simpl.
        inversion H.
        erewrite (IHls H1).
        unfold f_equal. unfold eq_trans. unfold eq_sym.
        generalize (app_ass_trans ls ls' ls'').
        rewrite <- H1.
        clear. intro.
        generalize dependent (hlist_app (hlist_tl a0) (hlist_app b c)).
        destruct e. reflexivity. }
    Qed.

    Lemma hlist_app_assoc'
      : forall (ls ls' ls'' : list iT)
               (a : hlist ls) (b : hlist ls') (c : hlist ls''),
        hlist_app a (hlist_app b c) =
        match
          app_ass_trans ls ls' ls'' in (_ = t) return (hlist t)
        with
        | eq_refl => hlist_app (hlist_app a b) c
        end.
    Proof.
      clear. intros.
      generalize (hlist_app_assoc a b c).
      generalize (hlist_app (hlist_app a b) c).
      generalize (hlist_app a (hlist_app b c)).
      destruct (app_ass_trans ls ls' ls'').
      simpl. auto.
    Qed.

    Fixpoint hlist_split ls ls' : hlist (ls ++ ls') -> hlist ls * hlist ls' :=
      match ls as ls return hlist (ls ++ ls') -> hlist ls * hlist ls' with
        | nil => fun h => (Hnil, h)
        | l :: ls => fun h =>
                       let (a,b) := @hlist_split ls ls' (hlist_tl h) in
                       (Hcons (hlist_hd h) a, b)
      end.

    Lemma hlist_app_hlist_split : forall ls' ls (h : hlist (ls ++ ls')),
      hlist_app (fst (hlist_split ls ls' h)) (snd (hlist_split ls ls' h)) = h.
    Proof.
      induction ls; simpl; intros; auto.
      rewrite (hlist_eta h); simpl.
      specialize (IHls (hlist_tl h)).
      destruct (hlist_split ls ls' (hlist_tl h)); simpl in *; auto.
      f_equal. auto.
    Qed.

    Lemma hlist_split_hlist_app : forall ls' ls (h : hlist ls) (h' : hlist ls'),
      hlist_split _ _ (hlist_app h h') = (h,h').
    Proof.
      induction ls; simpl; intros.
      { rewrite (hlist_eta h); simpl; auto. }
      { rewrite (hlist_eta h); simpl.
        rewrite IHls. reflexivity. }
    Qed.

  End type.

  Lemma hlist_hd_fst_hlist_split
  : forall t (xs ys : list _) (h : hlist (t :: xs ++ ys)),
      hlist_hd (fst (hlist_split (t :: xs) ys h)) = hlist_hd h.
  Proof.
    simpl. intros.
    match goal with
    | |- context [ match ?X with _ => _ end ] =>
      destruct X
    end. reflexivity.
  Qed.

  Lemma hlist_tl_fst_hlist_split
  : forall t (xs ys : list _) (h : hlist (t :: xs ++ ys)),
      hlist_tl (fst (hlist_split (t :: xs) ys h)) =
      fst (hlist_split xs ys (hlist_tl h)).
  Proof.
    simpl. intros.
    match goal with
    | |- context [ match ?X with _ => _ end ] =>
      remember X
    end. destruct p. simpl.
    change h0 with (fst (h0, h1)).
    f_equal; trivial.
  Qed.

  Lemma hlist_tl_snd_hlist_split
  : forall t (xs ys : list _) (h : hlist (t :: xs ++ ys)),
      snd (hlist_split xs ys (hlist_tl h)) =
      snd (hlist_split (t :: xs) ys h).
  Proof.
    simpl. intros.
    match goal with
    | |- context [ match ?X with _ => _ end ] =>
      remember X
    end. destruct p.
    simpl.
    change h1 with (snd (h0, h1)).
    rewrite Heqp. reflexivity.
  Qed.

  Polymorphic Fixpoint nth_error_get_hlist_nth (ls : list iT) (n : nat) {struct ls} :
    option {t : iT & hlist ls -> F t} :=
    match
      ls as ls0
      return option {t : iT & hlist ls0 -> F t}
    with
      | nil => None
      | l :: ls0 =>
        match
          n as n0
          return option {t : iT & hlist (l :: ls0) -> F t}
        with
          | 0 =>
            Some (@existT _ (fun t => hlist (l :: ls0) -> F t)
                          l (@hlist_hd _ _))
          | S n0 =>
            match nth_error_get_hlist_nth ls0 n0 with
              | Some (existT x f) =>
                Some (@existT _ (fun t => hlist _ -> F t)
                              x (fun h : hlist (l :: ls0) => f (hlist_tl h)))
              | None => None
            end
        end
    end.

  Theorem nth_error_get_hlist_nth_Some
    : forall ls n s,
      nth_error_get_hlist_nth ls n = Some s ->
      exists pf : nth_error ls n = Some (projT1 s),
      forall h, projT2 s h = match pf in _ = t
                                   return match t return Type with
                                            | Some t => F t
                                            | None => unit
                                          end
                             with
                               | eq_refl => hlist_nth h n
                             end.
  Proof.
    induction ls; simpl; intros; try congruence.
    { destruct n.
      { inv_all; subst; simpl.
        exists (eq_refl).
        intros. rewrite (hlist_eta h). reflexivity. }
      { forward. inv_all; subst.
        destruct (IHls _ _ H0); clear IHls.
        simpl in *. exists x0.
        intros.
        rewrite (hlist_eta h). simpl. auto. } }
  Qed.

  Theorem nth_error_get_hlist_nth_None
  : forall ls n,
      nth_error_get_hlist_nth ls n = None <->
      nth_error ls n = None.
  Proof.
    induction ls; simpl; intros; try congruence.
    { destruct n; intuition. }
    { destruct n; simpl; try solve [ intuition congruence ].
      specialize (IHls n). forward. }
  Qed.

  Lemma nth_error_get_hlist_nth_weaken
  : forall ls ls' n x,
      nth_error_get_hlist_nth ls n = Some x ->
      exists z,
        nth_error_get_hlist_nth (ls ++ ls') n =
        Some (@existT iT (fun t => hlist (ls ++ ls') -> F t) (projT1 x) z)
        /\ forall h h', projT2 x h = z (hlist_app h h').
  Proof.
    intros ls ls'. revert ls.
    induction ls; simpl; intros; try congruence.
    { destruct n; inv_all; subst.
      { simpl. eexists; split; eauto.
        intros. rewrite (hlist_eta h). reflexivity. }
      { forward. inv_all; subst. simpl.
        apply IHls in H0. forward_reason.
        rewrite H. eexists; split; eauto.
        intros. rewrite (hlist_eta h). simpl in *.
        auto. } }
  Qed.

  Lemma nth_error_get_hlist_nth_appL
  : forall tvs' tvs n,
      n < length tvs ->
      exists x,
        nth_error_get_hlist_nth (tvs ++ tvs') n = Some x /\
        exists y,
          nth_error_get_hlist_nth tvs n = Some (@existT _ _ (projT1 x) y) /\
          forall vs vs',
            (projT2 x) (hlist_app vs vs') = y vs.
  Proof.
    clear. induction tvs; simpl; intros.
    { exfalso; inversion H. }
    { destruct n.
      { clear H IHtvs.
        eexists; split; eauto. eexists; split; eauto.
        simpl. intros. rewrite (hlist_eta vs). reflexivity. }
      { apply Lt.lt_S_n in H.
        { specialize (IHtvs _ H).
          forward_reason.
          rewrite H0. rewrite H1.
          forward. subst. simpl in *.
          eexists; split; eauto.
          eexists; split; eauto. simpl.
          intros. rewrite (hlist_eta vs). simpl. auto. } } }
  Qed.

  Lemma nth_error_get_hlist_nth_appR
  : forall tvs' tvs n x,
      n >= length tvs ->
      nth_error_get_hlist_nth (tvs ++ tvs') n = Some x ->
      exists y,
        nth_error_get_hlist_nth tvs' (n - length tvs) = Some (@existT _ _ (projT1 x) y) /\
        forall vs vs',
          (projT2 x) (hlist_app vs vs') = y vs'.
  Proof.
    clear. induction tvs; simpl; intros.
    { rewrite <- Minus.minus_n_O.
      rewrite H0. destruct x. simpl.
      eexists; split; eauto. intros.
      rewrite (hlist_eta vs). reflexivity. }
    { destruct n.
      { inversion H. }
      { assert (n >= length tvs) by (eapply le_S_n; eassumption). clear H.
        { forward. inv_all; subst. simpl in *.
          specialize (IHtvs _ _ H1 H0).
          simpl in *.
          forward_reason.
          rewrite H.
          eexists; split; eauto.
          intros. rewrite (hlist_eta vs). simpl. auto. } } }
  Qed.

End hlist.

Arguments Hnil {_ _}.
Arguments Hcons {_ _ _ _} _ _.
Arguments equiv_hlist {_ F} R {_} _ _ : rename.

(** Weak Map
 ** This is weak because it does not change the key type
 **)
Section hlist_map.
  Variable A : Type.
  Variables F G : A -> Type.
  Variable ff : forall x, F x -> G x.

  Fixpoint hlist_map (ls : list A) (hl : hlist F ls) {struct hl} : hlist G ls :=
    match hl in @hlist _ _ ls return hlist G ls with
      | Hnil => Hnil
      | Hcons _ _ hd tl =>
        Hcons (ff hd) (hlist_map tl)
    end.

  Theorem hlist_app_hlist_map
    : forall ls ls' (a : hlist F ls) (b : hlist F ls'),
      hlist_map (hlist_app a b) =
      hlist_app (hlist_map a) (hlist_map b).
  Proof.
    induction a. simpl; auto.
    simpl. intros. f_equal. auto.
  Qed.

End hlist_map.

Arguments hlist_map {_ _ _} _ {_} _.

Section hlist_map_rules.
  Variable A : Type.
  Variables F G G' : A -> Type.
  Variable ff : forall x, F x -> G x.
  Variable gg : forall x, G x -> G' x.

  Theorem hlist_map_hlist_map : forall ls (hl : hlist F ls),
      hlist_map gg (hlist_map ff hl) = hlist_map (fun _ x => gg (ff x)) hl.
  Proof.
    induction hl; simpl; f_equal. assumption.
  Defined.

  Theorem hlist_get_hlist_map : forall ls t (hl : hlist F ls) (m : member t ls),
      hlist_get m (hlist_map ff hl) = ff (hlist_get m hl).
  Proof.
    induction m; simpl.
    { rewrite (hlist_eta hl). reflexivity. }
    { rewrite (hlist_eta hl). simpl. auto. }
  Defined.

  Lemma hlist_map_ext : forall (ff gg : forall x, F x -> G x),
      (forall x t, ff x t = gg x t) ->
      forall ls (hl : hlist F ls),
        hlist_map ff hl = hlist_map gg hl.
  Proof.
    induction hl; simpl; auto.
    intros. f_equal; auto.
  Defined.

End hlist_map_rules.

Lemma equiv_hlist_map
: forall T U (F : T -> Type) (R : forall t, F t -> F t -> Prop)
         (R' : forall t, U t -> U t -> Prop)
         (f g : forall t, F t -> U t),
    (forall t (x y : F t), R t x y -> R' t (f t x) (g t y)) ->
    forall  ls (a b : hlist F ls),
      equiv_hlist R a b ->
      equiv_hlist R' (hlist_map f a) (hlist_map g b).
Proof.
  clear. induction 2; simpl; intros.
  - constructor.
  - constructor; eauto.
Qed.

(** Linking Heterogeneous Lists and Lists **)

Section hlist_gen.
  Variable A : Type.
  Variable F : A -> Type.
  Variable f : forall a, F a.

  Fixpoint hlist_gen ls : hlist F ls :=
    match ls with
    | nil => Hnil
    | cons x ls' => Hcons (f x) (hlist_gen ls')
    end.

  Lemma hlist_get_hlist_gen : forall ls t (m : member t ls),
    hlist_get m (hlist_gen ls) = f t.
  Proof.
    induction m; simpl; auto.
  Qed.

  (** This function is a generalisation of [hlist_gen] in which the function [f]
    takes the additional parameter [member a ls]. **)
  Fixpoint hlist_gen_member ls : (forall a, member a ls -> F a) -> hlist F ls :=
    match ls as ls return ((forall a : A, member a ls -> F a) -> hlist F ls) with
    | nil => fun _ => Hnil
    | a :: ls' => fun fm =>
        Hcons (fm a (MZ a ls'))
          (hlist_gen_member (fun a' (M : member a' ls') => fm a' (MN a M)))
    end.

  Lemma hlist_gen_member_hlist_gen : forall ls,
    hlist_gen_member (fun a _ => f a) = hlist_gen ls.
  Proof.
    induction ls; simpl; f_equal; auto.
  Qed.

  Lemma hlist_gen_member_ext : forall ls (f g : forall a, member a ls -> F a),
    (forall x M, f x M = g x M) ->
    hlist_gen_member f = hlist_gen_member g.
  Proof.
    intros. induction ls; simpl; f_equal; auto.
  Qed.

End hlist_gen.

Arguments hlist_gen {A F} f ls.

Lemma hlist_gen_member_hlist_map : forall A (F G : A -> Type) (ff : forall t, F t -> G t) ls f,
  hlist_map ff (hlist_gen_member F (ls := ls) f) = hlist_gen_member G (fun a M => ff _ (f _ M)).
Proof.
  intros. induction ls; simpl; f_equal; auto.
Qed.

Lemma hlist_gen_hlist_map : forall A (F G : A -> Type) (ff : forall t, F t -> G t) f ls,
  hlist_map ff (hlist_gen f ls) = hlist_gen (fun a => ff _ (f a)) ls.
Proof.
  intros. do 2 rewrite <- hlist_gen_member_hlist_gen. apply hlist_gen_member_hlist_map.
Qed.

Lemma hlist_gen_ext : forall A F (f g : forall a, F a),
  (forall x, f x = g x) ->
  forall ls : list A, hlist_gen f ls = hlist_gen g ls.
Proof.
  intros. do 2 rewrite <- hlist_gen_member_hlist_gen. apply hlist_gen_member_ext. auto.
Qed.

Global Instance Proper_hlist_gen : forall A F,
  Proper (forall_relation (fun _ => eq) ==> forall_relation (fun _ => eq))
         (@hlist_gen A F).
Proof.
  repeat intro. apply hlist_gen_ext. auto.
Qed.

Lemma equiv_hlist_gen : forall T (F : T -> Type) (f : forall t, F t) f'
    (R : forall t, F t -> F t -> Prop),
  (forall t, R t (f t) (f' t)) ->
  forall ls,
    equiv_hlist R (hlist_gen f ls) (hlist_gen f' ls).
Proof.
  induction ls; simpl; constructor; auto.
Qed.

Global Instance Proper_equiv_hlist_gen : forall A (F : A -> Type) R,
  Proper (forall_relation R ==> forall_relation (@equiv_hlist _ _ R))
         (@hlist_gen A F).
Proof.
  repeat intro. apply equiv_hlist_gen. auto.
Qed.

Fixpoint hlist_erase {A B} {ls : list A} (hs : hlist (fun _ => B) ls) : list B :=
  match hs with
  | Hnil => nil
  | Hcons _ _ x hs' => cons x (hlist_erase hs')
  end.

Lemma hlist_erase_hlist_gen : forall A B ls (f : A -> B),
  hlist_erase (hlist_gen f ls) = map f ls.
Proof.
  induction ls; simpl; intros; f_equal; auto.
Qed.

(** Linking Heterogeneous Lists and Predicates **)

Section hlist_Forall.
  Variable A : Type.
  Variable P : A -> Prop.

  Fixpoint hlist_Forall ls (hs : hlist P ls) : Forall P ls :=
    match hs with
    | Hnil => Forall_nil _
    | Hcons _ _ H hs' => Forall_cons _ H (hlist_Forall hs')
    end.

End hlist_Forall.

(** Heterogeneous Relations **)
Section hlist_rel.
  Variable A : Type.
  Variables F G : A -> Type.
  Variable R : forall x : A, F x -> G x -> Prop.

  Inductive hlist_hrel : forall ls, hlist F ls -> hlist G ls -> Prop :=
  | hrel_Hnil : hlist_hrel Hnil Hnil
  | hrel_Hcons : forall t ts x y xs ys, @R t x y -> @hlist_hrel ts xs ys ->
                                        @hlist_hrel (t :: ts) (Hcons x xs) (Hcons y ys).

End hlist_rel.

Section hlist_rel_map.
  Variable A : Type.
  Variables F G F' G' : A -> Type.
  Variable R : forall x : A, F x -> G x -> Prop.
  Variable R' : forall x : A, F' x -> G' x -> Prop.
  Variable ff : forall x : A, F x -> F' x.
  Variable gg : forall x : A, G x -> G' x.

  Hypothesis R_ff_R' :
    forall t x y, @R t x y ->
                  @R' t (ff x) (gg y).

  Theorem hlist_hrel_map
  : forall ls xs ys,
      @hlist_hrel A F G R ls xs ys ->
      @hlist_hrel A F' G' R' ls (hlist_map ff xs) (hlist_map gg ys).
  Proof.
    induction 1; simpl; constructor; eauto.
  Qed.

  Theorem hlist_hrel_cons
  : forall l ls x xs y ys,
      @hlist_hrel A F G R (l :: ls) (Hcons x xs) (Hcons y ys) ->
      @R l x y /\ @hlist_hrel A F G R ls xs ys.
  Proof.
    intros.
    refine
      match H in @hlist_hrel _ _ _ _ ls' xs' ys'
            return
            match ls' as ls' return hlist F ls' -> hlist G ls' -> Prop with
              | nil => fun _ _ => True
              | l' :: ls' => fun x y =>
                   R (hlist_hd x) (hlist_hd y)
                /\ hlist_hrel R (hlist_tl x) (hlist_tl y)
            end xs' ys'
      with
        | hrel_Hnil => I
        | hrel_Hcons _ _ _ _ _ _ pf pf' => conj pf pf'
      end.
  Qed.

  Theorem hlist_hrel_app
  : forall l ls x xs y ys,
      @hlist_hrel A F G R (l ++ ls) (hlist_app x xs) (hlist_app y ys) ->
      @hlist_hrel A F G R l x y /\ @hlist_hrel A F G R ls xs ys.
  Proof.
    induction x.
    + intros xs y ys. rewrite (hlist_eta y).
      simpl; intros; split; auto. constructor.
    + intros xs y ys. rewrite (hlist_eta y).
      intros. eapply hlist_hrel_cons in H.
      destruct H.
      apply IHx in H0.
      intuition. constructor; auto.
  Qed.

End hlist_rel_map.

Theorem hlist_hrel_equiv
: forall T (F : T -> Type) (R : forall t, F t -> F t -> Prop) ls (h h' : hlist F ls),
    hlist_hrel R h h' ->
    equiv_hlist R h h'.
Proof.
  induction 1; constructor; auto.
Qed.

Theorem hlist_hrel_flip
: forall T (F G : T -> Type) (R : forall t, F t -> G t -> Prop) ls
         (h : hlist F ls) (h' : hlist G ls),
    hlist_hrel R h h' ->
    hlist_hrel (fun t a b => R t b a) h' h.
Proof.
  induction 1; constructor; auto.
Qed.


(* [mono_nat] must go first otherwise the default scope becomes nat. *)
From iris.base_logic Require Import mono_nat.
From Perennial.program_proof Require Import
     mvcc_prelude mvcc_ghost mvcc_inv
     txnmgr_repr txnmgr_mk txnmgr_new txnmgr_activate_gc
     txn_repr txn_get txn_put txn_delete txn_do_txn.
From Goose.github_com.mit_pdos.go_mvcc Require Import examples.
From Perennial.goose_lang Require Import grove_ffi_adequacy.

Section program.
Context `{!heapGS Σ, !mvcc_ghostG Σ}.

Definition P_Hello (r : dbmap) := ∃ v, r = {[ (U64 0) := v ]}.
Definition Q_Hello (r w : dbmap) := w = {[ (U64 0) := Nil ]}.

Theorem wp_hello txn tid r γ τ :
  {{{ own_txn txn tid r γ τ ∗ ⌜P_Hello r⌝ ∗ txnmap_ptstos τ r }}}
    hello #txn
  {{{ (ok : bool), RET #ok;
      own_txn txn tid r γ τ ∗
      if ok
      then ∃ w, ⌜Q_Hello r w ∧ dom r = dom w⌝ ∗
                txnmap_ptstos τ w
      else True
  }}}.
Proof.
  iIntros (Φ) "(Htxn & %HP & Hpt) HΦ".
  wp_call.
  unfold txnmap_ptstos.
  destruct HP as [v HP].
  rewrite HP.
  rewrite big_sepM_singleton.

  (***********************************************************)
  (* txn.Put(0, "hello")                                     *)
  (* txn.Get(0)                                              *)
  (* txn.Delete(0)                                           *)
  (* return true                                             *)
  (***********************************************************)
  wp_apply (wp_txn__Put with "[$Htxn $Hpt]").
  iIntros "[Htxn Hpt]".
  wp_apply (wp_txn__Get with "[$Htxn $Hpt]").
  iIntros (u found) "[Htxn [Hpt %Hu]]".
  wp_pures.
  wp_apply (wp_txn__Delete with "[$Htxn $Hpt]").
  iIntros (ok) "[Htxn Hpt]".
  wp_pures.
  iApply "HΦ".
  iFrame.
  iModIntro.
  iExists {[ (U64 0) := Nil ]}.
  rewrite big_sepM_singleton.
  iFrame.
  iPureIntro.
  unfold Q_Hello.
  set_solver.
Qed.

Theorem wp_Hello (txn : loc) γ :
  ⊢ {{{ own_txn_uninit txn γ }}}
    <<< ∀∀ (v : dbval), dbmap_ptsto γ (U64 0) 1 v >>>
      Hello #txn @ ↑mvccN
    <<< ∃∃ (ok : bool), if ok then dbmap_ptsto γ (U64 0) 1 Nil else dbmap_ptsto γ (U64 0) 1 v >>>
    {{{ RET #(); own_txn_uninit txn γ }}}.
Proof.
  iIntros "!>".
  iIntros (Φ) "Htxn HAU".
  wp_call.

  (***********************************************************)
  (* body := func(txn *txn.Txn) bool {                       *)
  (*     return hello(txn)                                   *)
  (* }                                                       *)
  (* ok := t.DoTxn(body)                                     *)
  (***********************************************************)
  wp_apply (wp_txn__DoTxn_xres _ _ P_Hello Q_Hello with "[$Htxn]").
  { unfold Q_Hello. apply _. }
  { unfold spec_body_xres.
    clear Φ.
    iIntros (tid r τ Φ) "(Htxn & %HP & Htxnpt) HΦ".
    wp_pures.
    wp_apply (wp_hello with "[$Htxn $Htxnpt]"); first done.
    iApply "HΦ".
  }
  iMod "HAU".
  iModIntro.
  iDestruct "HAU" as (v) "[Hdbpt HAU]".
  iExists {[ (U64 0) := v ]}.
  iSplitL "Hdbpt".
  { unfold dbmap_ptstos.
    rewrite big_sepM_singleton.
    iFrame.
    iPureIntro.
    unfold P_Hello.
    by eauto.
  }
  iIntros (ok w) "Hdbpt".
  iFrame.
  destruct ok eqn:E.
  { (* Case COMMIT. *)
    unfold Q_Hello.
    iDestruct "Hdbpt" as "[%HQ Hdbpt]".
    rewrite HQ /dbmap_ptstos big_sepM_singleton.
    iMod ("HAU" $! true with "Hdbpt") as "HΦ".
    iIntros "!> Htxn".
    wp_pures.
    by iApply "HΦ".
  }
  { (* Case ABORT. *)
    rewrite /dbmap_ptstos big_sepM_singleton.
    iMod ("HAU" $! false with "Hdbpt") as "HΦ".
    iIntros "!> Htxn".
    wp_pures.
    by iApply "HΦ".
  }
Qed.

Theorem wp_CallHello :
  {{{ True }}}
    CallHello #()
  {{{ RET #(); True }}}.
Proof using heapGS0 mvcc_ghostG0 Σ.
  iIntros (Φ) "_ HΦ".
  wp_call.

  (***********************************************************)
  (* db := txn.MkTxnMgr()                                    *)
  (* db.ActivateGC()                                         *)
  (* txn := db.New()                                         *)
  (* Hello(txn)                                              *)
  (***********************************************************)
  wp_apply wp_MkTxnMgr.
  iIntros (γ mgr) "[#Hmgr Hdbpts]".
  wp_pures.
  wp_apply (wp_txnMgr__ActivateGC with "Hmgr").
  wp_pures.
  wp_apply (wp_txnMgr__New with "Hmgr").
  iIntros (txn) "Htxn".
  wp_pures.
  wp_apply (wp_Hello with "Htxn").
  iApply ncfupd_mask_intro; first set_solver.
  iIntros "Hmask".
  iDestruct (big_sepM_lookup _ _ (U64 0) with "Hdbpts") as "Hdbpt".
  { rewrite lookup_gset_to_gmap_Some.
    split; [set_solver | reflexivity].
  }
  iExists Nil.
  iFrame.
  iIntros (ok) "Hdbpt".
  iMod "Hmask" as "_".
  iIntros "!> Htxn".
  wp_pures.
  by iApply "HΦ".
Qed.

End program.

Module closed_proof.

  Import adequacy.

  Definition helloΣ := #[heapΣ; mvcc_ghostΣ].

  Lemma hello_adequate σ g :
    σ.(world).(grove_node_files) = ∅ →
    g.(global_world).(grove_net) = ∅ →
    recovery_adequacy.adequate_failstop (CallHello #()) σ g (λ v _ _, v = #()).
  Proof.
    intros Hfiles Hnet. eapply (grove_ffi_single_node_adequacy_failstop helloΣ).
    { rewrite Hnet. done. }
    { rewrite Hfiles. done. }
    iIntros (hHeap) "_ _ !>". iApply wp_CallHello; auto.
  Qed.
End closed_proof.