(** * Poly: Polymorphism and Higher-Order Functions *)

(* Final reminder: Please do not put solutions to the exercises in
   publicly accessible places.  Thank you!! *)

(* Suppress some annoying warnings from Coq: *)
Set Warnings "-notation-overridden,-parsing".
From LF Require Export Lists.

(* ################################################################# *)
(** * Polymorphism *)

(** 在本章中，我们会继续发展函数式编程的基本概念，其中最关键的新概念就是 多态
   （在所处理的数据类型上抽象出函数）和高阶函数（函数作为数据）。 *)

(* ================================================================= *)
(** ** Polymorphic Lists *)

(** 在前几章中，我们只是使用了数的列表。很明显，有趣的程序还需要能够处理其它元素类型的列表，
    如字符串列表、布尔值列表、 列表的列表等等。我们可以分别为它们定义新的归纳数据类型，例如...*)

Inductive boollist : Type :=
  | bool_nil
  | bool_cons (b : bool) (l : boollist).

(** ...不过这样很快就会变得乏味。 部分原因在于我们必须为每种数据类型都定义不同的构造子，
    然而主因还是我们必须为每种数据类型再重新定义一遍所有的列表处理函数 （如 length、rev 等）。*)

(** 为避免这些重复，Coq 支持定义多态归纳类型。 例如，以下就是多态列表数据类型。 *)

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

(** 这和上一章中 [natlist] 的定义基本一样，只是将 [cons] 构造子的 [nat] 参数换成了任意的类型
     [X]，定义的头部添加了 [X] 的绑定， 而构造子类型中的 [natlist] 则换成了 [list X]。（我们
     可以重用构造子名 [nil] 和 [cons]，因为之前定义的 [natlist] 在当前作用之外的一个
      [Module] 中。）

      [list] 本身又是什么类型？一种不错的思路就是把 [list] 当做从 [Type] 类型到 [Inductive]
      归纳定义的函数；或者换种思路，即 [list] 是个从 [Type] 类型到 [Type] 类型的函数。对于任何
      特定的类型 [X]， 类型 [list X] 是一个 [Inductive] 归纳定义的，元素类型为 [X] 的列表的
      集合。 *)

Check list.
(* ===> list : Type -> Type *)

(** The parameter [X] in the definition of [list] automatically
    becomes a parameter to the constructors [nil] and [cons] -- that
    is, [nil] and [cons] are now polymorphic constructors; when we use
    them, we must now provide a first argument that is the type of the
    list they are building. For example, [nil nat] constructs the
    empty list of type [nat]. *)

Check (nil nat).
(* ===> nil nat : list nat *)

(** [cons nat] 与此类似，它将类型为 [nat] 的元素添加到类型为 [list nat] 的列表中。
    以下示例构造了一个只包含自然数 3 的列表： *)

Check (cons nat 3 (nil nat)).
(* ===> cons nat 3 (nil nat) : list nat *)

(** [nil] 的类型可能是什么？我们可以从定义中看到 [list X] 的类型， 它忽略了 [list] 的
    形参 [X] 的绑定。[Type → list X] 并没有解释 [X] 的含义，[(X : Type) → list X] 则
    比较接近。Coq 对这种情况的记法为 [forall X : Type, list X]. *)

Check nil.
(* ===> nil : forall X : Type, list X *)

(** 类似地，定义中 [cons] 看起来像 [X → list X → list X] 然而以此约定来解释
    [X] 的含义则是类型 [forall X, X → list X → list X]. *)

Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

(** （关于记法的附注：在 .v 文件中，量词 "forall" 会写成字母的形式， 而在生成的
     HTML 和一些设置了显示控制的 IDE 中，[forall] 通常会渲染成一般的 "∀" 数学符号，
     虽然你偶尔还是会看到英文拼写的 "forall"。这只是排版上的效果，它们的含义没有任何区别。）*)

(** 如果在每次使用列表构造子时，都要为它提供类型参数，那样会很麻烦。 不过我们很快
    就会看到如何省去这种麻烦。 *)

Check (cons nat 2 (cons nat 1 (nil nat))).

(** （这里显式地写出了 [nil] 和 [cons]，因为我们还没为新版本的列表定义 [[]] 和 [::] 记法。
      我们待会儿再干。)
      现在我们可以回过头来定义之前写下的列表处理函数的多态版本了。 例如 [repeat]： *)

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

(** 同 [nil] 与 [cons] 一样，我们可以通过将 [repeat] 应用到一个类型、
    一个该类型的元素以及一个数字来使用它：*)

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity.  Qed.

(** 要用 [repeat] 构造其它种类的列表， 我们只需通过对应类型的参数将它实例化即可：*)

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity.  Qed.

(** **** Exercise: 2 stars, standard (mumble_grumble)

    Consider the following two inductively defined types. *)

Module MumbleGrumble.

Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.

Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?  (Add YES or NO to each line.)
      - [d (b a 5)] "NO"
      - [d mumble (b a 5)] "YES"
      - [d bool (b a 5)] "YES"
      - [e bool true] "YES"
      - [e mumble (b c 0)] "NO"
      - [e bool (b c 0)] "NO"
      - [c] "YES" *)
(* FILL IN HERE *)
Eval compute in d mumble (b a 5).
Eval compute in d bool (b a 5).
Eval compute in e bool true.
Eval compute in c.
End MumbleGrumble.

(* Do not modify the following line: *)
Definition manual_grade_for_mumble_grumble : option (nat*string) := None.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Type Annotation Inference *)

(** 我们再写一遍 [repeat] 的定义，不过这次不指定任何参数的类型。 Coq 还会接受它么？ *)

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

(** I当然会。我们来看看 Coq 赋予了 [repeat'] 什么类型： *)

Check repeat'.
(* ===> forall X : Type, X -> nat -> list X *)
Check repeat.
(* ===> forall X : Type, X -> nat -> list X *)

(** 它与 [repeat] 的类型完全一致。Coq 可以使用类型推断 基于它们的使用方式来推出 [X]、[x]
    和 [count] 一定是什么类型。例如， 由于 [X] 是作为 [cons] 的参数使用的，因此它必定是个
    [Type] 类型， 因为 [cons] 期望一个 [Type] 作为其第一个参数，而用 [0] 和 [S] 来匹配
     [count] 意味着它必须是个 [nat]，诸如此类。

    这种强大的功能意味着我们不必总是在任何地方都显式地写出类型标注， 不过显式的类型标注对于
    文档和完整性检查来说仍然非常有用， 因此我们仍会继续使用它。你应当在代码中把握好使用
    类型标注的平衡点， 太多导致混乱并分散注意力，太少则会迫使读者为理解你的代码
    而在大脑中进行类型推断。*)

(* ----------------------------------------------------------------- *)
(** *** Type Argument Synthesis *)

(** 要使用多态函数，我们需要为其参数再额外传入一个或更多类型。 例如，前面 [repeat]
    函数体中的递归调用必须传递类型 [X]。不过由于 [repeat] 的第二个参数为 [X] 类型
    的元素，第一个参数明显只能是 X， 既然如此，我们何必显式地写出它呢？

    Fortunately, Coq permits us to avoid this kind of redundancy.  In
    place of any type argument we can write a "hole" [_], which can be
    read as "Please try to figure out for yourself what belongs here."
    More precisely, when Coq encounters a [_], it will attempt to
    _unify_ all locally available information -- the type of the
    function being applied, the types of the other arguments, and the
    type expected by the context in which the application appears --
    to determine what concrete type should replace the [_].

    这听起来很像类型标注推断。实际上，这两种个过程依赖于同样的底层机制。
    除了简单地忽略函数中某些参数的类型：

      repeat' X x count : list X :=

    我们还可以将类型换成 [_]：

      repeat' (X : _) (x : _) (count : _) : list X :=

    以此来告诉 Coq 要尝试推断出缺少的信息。

    Using holes, the [repeat] function can be written like this: *)

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

(** 在此例中，我们写出 [_] 并没有省略多少 [X]。然而在很多情况下，
    这对减少击键次数和提高可读性还是很有效的。例如，假设我们要写下
    一个包含数字 1、2 和 3 的列表，此时不必写成这样： *)

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

(** ...we can use holes to write this: *)

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

(* ----------------------------------------------------------------- *)
(** *** Implicit Arguments *)

(** 我们甚至可以通过告诉 Coq 总是推断给定函数的类型参数来避免 [_]。

    [Arguments] 用于指令指定函数或构造子的名字并列出其参数名， 花括号中的
    任何参数都会被视作隐式参数。（如果定义中的某个参数没有名字， 那么它可以
    用通配模式 [_] 来标记。这种情况常见于构造子中。 *)

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

(** 现在我们再也不必提供类型参数了： *)

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

(** 此外，我们还可以在定义函数时声明隐式参数， 只是需要将它放在花括号内而非圆括号中。例如： *)

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

(** (注意我们现在甚至不必在 [repeat'''] 的递归调用中提供类型参数了，
    实际上提供了反而是无效的！)

    我们会尽可能使用最后一种风格，不过还会继续在 Inductive 构造子中
    使用显式的 Argument 声明。原因在于如果将归纳类型的形参标为隐式的话，
    不仅构造子的类型会变成隐式的，类型本身也会变成隐式的。例如， 考虑
    以下 list 类型的另一种定义：*)

Inductive list' {X:Type} : Type :=
  | nil'
  | cons' (x : X) (l : list').

(** 由于 [X] 在包括 [list'] 本身的整个归纳定义中都是隐式声明的，
    因此当我们讨论数值、布尔值或其它任何类型的列表时，都只能写 [list']，
    而写不了 [list' nat]、[list' bool] 或其它的了，这样就跑得有点太远了。 *)

(** 作为本节的收尾，我们为新的多态列表重新实现几个其它的标准列表函数... *)

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. simpl. reflexivity.  Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Supplying Type Arguments Explicitly *)

(** 用 [Implicit] 将参数声明为隐式的会有个小问题：Coq 偶尔会没有足够的
    局部信息来确定类型参数。此时，我们需要告诉 Coq 这次我们会显示地给出参数。
    例如，假设我们写了如下定义：*)

Fail Definition mynil := nil.

(** （[Definition] 前面的 [Fail] 限定符可用于 _任何_ 指令， 它的作用是确保该指令
    在执行时确实会失败。如果该指令失败了，Coq 就会打印出相应的错误信息，不过之后会
    继续处理文件中剩下的部分。）

    在这里，Coq 给出了一条错误信息，因为它不知道应该为 [nil] 提供何种类型。 我们
    可以为它提供个显式的类型声明来帮助它，这样 Coq 在"应用" [nil] 时就有更多可用的信息了：*)

Definition mynil : list nat := nil.

(** 此外，我们还可以在函数名前加上前缀 [@] 来强制将隐式参数变成显式的：*)

Check @nil.

Definition mynil' := @nil nat.

(** 使用参数推断和隐式参数，我们可以为列表定义和前面一样的简便记法。
    由于我们让构造子的的类型参数变成了隐式的，因此 Coq 就知道在我们
    使用该记法时自动推断它们了。
 *)

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** 现在列表就能写成我们希望的方式了： *)

Definition list123''' := [1; 2; 3].

(* ----------------------------------------------------------------- *)
(** *** Exercises *)

(** **** Exercise: 2 stars, standard, optional (poly_exercises)

    Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Complete the proofs below. *)

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros.
  induction l as [| n l'].
  - reflexivity.
  - simpl. rewrite -> IHl'. reflexivity. Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros.
  induction l as [| n1 l1' IHl1'].
  - reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity. Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros.
  induction l1 as [| n2 l2' IHl2'].
  - reflexivity.
  - simpl. rewrite -> IHl2'. reflexivity. Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (more_poly_exercises)

    Here are some slightly more interesting ones... *)

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros.
  induction l1 as [| n l' IHl'].
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IHl'. rewrite -> app_assoc. reflexivity. Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros.
  induction l as [| n l'].
  - simpl. reflexivity.
  - simpl. rewrite -> rev_app_distr. rewrite -> IHl'. reflexivity. Qed.
(** [] *)

(* ================================================================= *)
(** ** Polymorphic Pairs *)

(** 按照相同的模式，我们在上一章中给出的数值序对的定义可被推广为_多态序对_（Polymorphic
    Pairs），它通常叫做_积_（Products）：*)

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).

Arguments pair {X} {Y} _ _.

(** 和列表一样，我们也可以将类型参数定义成隐式的， 并以此定义类似的具体记法：*)

Notation "( x , y )" := (pair x y).

(** 我们也可以使用 [Notation] 来定义标准的_积类型_（Product Types）记法：*)

Notation "X * Y" := (prod X Y) : type_scope.

(** （标注 [: type_scope] 会告诉 Coq 该缩写只能在解析类型时使用。
    这避免了与乘法符号的冲突。)*)

(** 一开始会很容易混淆 [(x,y)] 和 [X*Y]。不过要记住 [(x,y)] 是一个值，
    它由两个其它的值构造得来；而 [X*Y] 是一个类型， 它由两个其它的类型
    构造得来。如果 [x] 的类型为 [X] 而 [y] 的类型为 [Y]， 那么 [(x,y)]
    的类型就是 [X*Y]。*)

(** 第一元（first）和第二元（second）的射影函数（Projection Functions）
    现在看起来和其它函数式编程语言中的很像了：*)

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

(** 以下函数接受两个列表，并将它们结合成一个序对的列表。 在其它函数式语言中，
    它通常被称作 [zip]。我们为了与 Coq 的标准库保持一致， 将它命名为 [combine]。*)

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

(** **** Exercise: 1 star, standard, optional (combine_checks)

    Try answering the following questions on paper and
    checking your answers in Coq:
    - What is the type of [combine] (i.e., what does [Check
      @combine] print?)
    - What does

        Compute (combine [1;2] [false;false;true;true]).

      print?

    [] *)
Check @combine.
(* forall X Y : Type, list X -> list Y -> list (X * Y) *)
Compute (combine [1;2] [false;false;true;true]).
(* [(1, false); (2, false)] *)
(* forall X Y : Type, list X -> list Y -> list (X * Y) *)
(** **** Exercise: 2 stars, standard, recommended (split)

    The function [split] is the right inverse of [combine]: it takes a
    list of pairs and returns a pair of lists.  In many functional
    languages, it is called [unzip].

    Fill in the definition of [split] below.  Make sure it passes the
    given unit test. *)

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
    | [] => ([], [])
    | (x, y)::l' => (x::(fst (split l')), y::(snd (split l')))
 end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.
(** [] *)

(* ================================================================= *)
(** ** Polymorphic Options *)

(** 现在介绍最后一种多态类型：多态候选（Polymorphic Options）, 它推广了上一章中的
    [natoption]. (We put the definition inside a module because the
    standard library already defines [option] and it's this one that
    we want to use below.) *)

Module OptionPlayground.

Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.

Arguments Some {X} _.
Arguments None {X}.

End OptionPlayground.

(** 现在我们可以重写 [nth_error] 函数来让它适用于任何类型的列表了。*)

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if n =? O then Some a else nth_error l' (pred n)
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, standard, optional (hd_error_poly)

    Complete the definition of a polymorphic version of the
    [hd_error] function from the last chapter. Be sure that it
    passes the unit tests below. *)

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
    | nil    => None
    | h :: _ => Some h
end.

(** Once again, to force the implicit arguments to be explicit,
    we can use [@] before the name of the function. *)

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
Proof. reflexivity. Qed.
(** [] *)

(* ################################################################# *)
(** * Functions as Data *)

(** 和其它现代编程语言，包括所有函数式语言（ML、Haskell、 Scheme、Scala、Clojure 等）
    一样，Coq 也将函数视作“一等公民（First-Class Citizens）”， 即允许将它们作为参数
    传入其它函数、作为结果返回、以及存储在数据结构中等等。*)

(* ================================================================= *)
(** ** Higher-Order Functions *)

(** F用于操作其它函数的函数通常叫做_高阶函数_。以下是简单的示例：*)

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

(** 这里的参数 [f] 本身也是个（从 [X] 到 [X] 的）函数， [doit3times] 的函数体
    将 [f] 对某个值 [n] 应用三次。*)

Check @doit3times.
(* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity.  Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity.  Qed.

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

(** 下面是个更有用的高阶函数，它接受一个元素类型为 [X] 的列表和一个 [X] 的谓词
   （即一个从 [X] 到 [bool] 的函数），然后"过滤"此列表并返回一个新列表， 其中
   仅包含对该谓词返回 [true] 的元素。*)

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | []     => []
  | h :: t => if test h then h :: (filter test t)
                        else       filter test t
  end.

(** 例如，如果我们将 [filter] 应用到 predicate [evenb] 和
    一个数值列表 [l] 上，那么它就会返回一个只包含 [l] 中偶数的列表。*)

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity.  Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(** 我们可以使用 [filter] 给出 [Lists] 章节中 [countoddmembers] 函数的简洁的版本。*)

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1:countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity.  Qed.
Example test_countoddmembers'2:countoddmembers' [0;2;4] = 0.
Proof. reflexivity.  Qed.
Example test_countoddmembers'3:countoddmembers' nil = 0.
Proof. reflexivity.  Qed.

(* ================================================================= *)
(** ** Anonymous Functions *)

(** 在上面这个例子中，我们不得不定义一个名为 [length_is_1] 的函数， 以便让它能够
    作为参数传入到 [filter] 中，由于该函数可能再也用不到了， 这有点令人沮丧。
    我们经常需要传入"一次性"的函数作为参数，之后不会再用， 而为每个函数取名是十分无聊的。
    幸运的是，有一种更好的方法。我们可以按需随时构造函数而不必在顶层中声明它或给它取名 *)

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity.  Qed.

(** 表达式 [(fun n => n * n)] 可读作"一个给定 [n] 并返回 [n * n] 的函数。" *)

(** 以下为使用匿名函数重写的 [filter] 示例：*)

Example test_filter2':
    filter (fun l => (length l) =? 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(** **** Exercise: 2 stars, standard (filter_even_gt7)

    Use [filter] (instead of [Fixpoint]) to write a Coq function
    [filter_even_gt7] that takes a list of natural numbers as input
    and returns a list of just those that are even and greater than
    7. *)

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => (evenb n) && (leb 7 n)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.
(** [] *)

(** **** Exercise: 3 stars, standard (partition)

    Use [filter] to write a Coq function [partition]:

      partition : forall X : Type,
                  (X -> bool) -> list X -> list X * list X

   Given a set [X], a test function of type [X -> bool] and a [list
   X], [partition] should return a pair of lists.  The first member of
   the pair is the sublist of the original list containing the
   elements that satisfy the test, and the second is the sublist
   containing those that fail the test.  The order of elements in the
   two sublists should be the same as their order in the original
   list. *)

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
  (filter test l, filter (fun n => negb (test n)) l).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.
(** [] *)

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

(** 另一个方便的高阶函数叫做 [map]. *)

Fixpoint map {X Y: Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

(** 它接受一个函数 [f] 和一个列表 [l = [n1, n2, n3, ...]] 并返回列表
    [[f n1, f n2, f n3,...]] ，其中 [f] 可分别应用于 [l] 中的每一个元素。例如： *)

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** 输入列表和输出列表的元素类型不必相同，因为 [map] 会接受_两个_类型参数 [X] 和 [Y]，
    因此它可以应用到一个数值的列表和一个从数值到布尔值的函数， 并产生一个布尔值列表：*)

Example test_map2:
  map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity.  Qed.

(** 它甚至可以应用到一个数值的列表和一个从数值到布尔值列表的函数，
    并产生一个布尔值的_列表的列表_： *)

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Exercises *)

(** **** Exercise: 3 stars, standard (map_rev)

    Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Lemma app_map : forall (X Y : Type) (f : X -> Y) (l : list X) (x : X),
  app (map f l) [f x] = map f (app l [x]).
Proof.
  intros.
  induction l.
  - reflexivity.
  - simpl. rewrite -> IHl. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l as [|x l'].
  - (* l = nil *)
    reflexivity.
  - (* l = n :: l' *)
    simpl. rewrite <- IHl'. simpl.
    rewrite -> app_map. reflexivity.
Qed.

Lemma map_app : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = map f l1 ++ (map f l2).
Proof.
  intros.
  induction l1 as [| h1 t1 IH1].
  - reflexivity.
  - simpl. rewrite -> IH1. reflexivity.
Qed.

Theorem map_rev' : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros.
  induction l as [| h t IH].
  - reflexivity.
  - simpl. rewrite -> map_app.
    simpl. rewrite -> IH.
    reflexivity.
Qed.

(** [] *)

(** **** Exercise: 2 stars, standard, recommended (flat_map)

    The function [map] maps a [list X] to a [list Y] using a function
    of type [X -> Y].  We can define a similar function, [flat_map],
    which maps a [list X] to a [list Y] using a function [f] of type
    [X -> list Y].  Your definition should work by 'flattening' the
    results of [f], like so:

        flat_map (fun n => [n;n+1;n+2]) [1;5;10]
      = [1; 2; 3; 5; 6; 7; 10; 11; 12].
*)

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : (list Y) :=
  match l with
    | [] => []
    | h :: t => (f h) ++ (flat_map f t)
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.
(** [] *)

(** Lists are not the only inductive type for which [map] makes sense.
    Here is a [map] for the [option] type: *)

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

(** **** Exercise: 2 stars, standard, optional (implicit_args)

    The definitions and uses of [filter] and [map] use implicit
    arguments in many places.  Replace the curly braces around the
    implicit arguments with parentheses, and then fill in explicit
    type parameters where necessary and use Coq to check that you've
    done so correctly.  (This exercise is not to be turned in; it is
    probably easiest to do it on a _copy_ of this file that you can
    throw away afterwards.)

    [] *)

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

(** 一个更加强大的高阶函数叫做 [fold]。本函数启发自"reduce"归约操作，
    它是 Google 的 map/reduce 分布式编程框架的核心。*)

Fixpoint fold {X Y: Type} (f: X->Y->Y) (l: list X) (b: Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

(** 直观上来说，[fold] 操作的行为就是将给定的二元操作符 [f] 插入到给定列表的每一对元素之间。
    例如， [fold plus [1;2;3;4]] 直观上的意思是 [1+2+3+4]。为了让它更精确，我们还需要一个
    "起始元素" 作为 f 初始的第二个输入。因此，例如

       fold plus [1;2;3;4] 0

    就会产生

       1 + (2 + (3 + (4 + 0))).

    更多例子: *)

Check (fold andb).
(* ===> fold andb : list bool -> bool -> bool *)

Example fold_example1 :
  fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 :
  fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 :
  fold app  [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, advanced (fold_types_different)

    Observe that the type of [fold] is parameterized by _two_ type
    variables, [X] and [Y], and the parameter [f] is a binary operator
    that takes an [X] and a [Y] and returns a [Y].  Can you think of a
    situation where it would be useful for [X] and [Y] to be
    different? *)

Definition flat_map' {X : Type} (l : list (list X)) : list X
  := fold app l [].

(* Do not modify the following line: *)
Definition manual_grade_for_fold_types_different : option (nat*string) := None.
(** [] *)

(* ================================================================= *)
(** ** Functions That Construct Functions *)

(** 目前我们讨论过的大部分高阶函数都是接受函数作为参数的。 现在我们来看一些将函数
    作为其它函数的_结果_返回的例子。 首先，下面是一个接受值 [x]（由某个类型 [X] 刻画）
    并返回一个从 [nat] 到 [X] 的函数，当它被调用时总是产生 [x] 并忽略其 [nat] 参数。*)

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

(** 实际上，我们已经见过的多参函数也是讲函数作为数据传入的例子。
    为了理解为什么，请回想 [plus] 的类型。*)

Check plus.
(* ==> nat -> nat -> nat *)

(** 该表达式中的每个 [->] 实际上都是一个类型上的二元操作符。 该操作符是_右结合_的，
    因此 [plus] 的类型其实是 [nat -> (nat -> nat)] 的简写，即，它可以读作
    "[plus] 是一个单参数函数，它接受一个 [nat] 并返回另一个函数，该函数接受另一个
    [nat] 并返回一个[nat]"。 在上面的例子中，我们总是将 [plus]一次同时应用到两个参数上
    不过如果我们喜欢，也可以一次只提供一个参数，这叫做_偏应用_（Partial Application）*)

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 :    plus3 4 = 7.
Proof. reflexivity.  Qed.
Example test_plus3' :   doit3times plus3 0 = 9.
Proof. reflexivity.  Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9.
Proof. reflexivity.  Qed.

(* ################################################################# *)
(** * Additional Exercises *)

Module Exercises.

(** **** Exercise: 2 stars, standard (fold_length)

    Many common functions on lists can be implemented in terms of
    [fold].  For example, here is an alternative definition of [length]: *)

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

(** Prove the correctness of [fold_length].  (Hint: It may help to
    know that [reflexivity] simplifies expressions a bit more
    aggressively than [simpl] does -- i.e., you may find yourself in a
    situation where [simpl] does nothing but [reflexivity] solves the
    goal.) *)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros.
  induction l as [| x l' IHl'].
  - reflexivity.
  - simpl. rewrite <- IHl'. simpl. reflexivity. Qed.
(** [] *)

(** **** Exercise: 3 stars, standard (fold_map)

    We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y :=
  fold (fun x l => cons (f x) l) l [].
(** Write down a theorem [fold_map_correct] in Coq stating that
   [fold_map] is correct, and prove it.  (Hint: again, remember that
   [reflexivity] simplifies expressions a bit more aggressively than
   [simpl].) *)

Theorem fold_map_correct : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f l = fold_map f l.
Proof.
  intros X Y f l.
  induction l as [|x l'].
  - reflexivity.
  - simpl. rewrite -> IHl'. simpl. reflexivity. Qed.

(* Do not modify the following line: *)
Definition manual_grade_for_fold_map : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, advanced (currying)

    In Coq, a function [f : A -> B -> C] really has the type [A
    -> (B -> C)].  That is, if you give [f] a value of type [A], it
    will give you function [f' : B -> C].  If you then give [f'] a
    value of type [B], it will return a value of type [C].  This
    allows for partial application, as in [plus3].  Processing a list
    of arguments with functions that return functions is called
    _currying_, in honor of the logician Haskell Curry.

    Conversely, we can reinterpret the type [A -> B -> C] as [(A *
    B) -> C].  This is called _uncurrying_.  With an uncurried binary
    function, both arguments must be given at once as a pair; there is
    no partial application. *)

(** We can define currying as follows: *)

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

(** As an exercise, define its inverse, [prod_uncurry].  Then prove
    the theorems below to show that the two are inverses. *)

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z := f (fst p) (snd p).

(** As a (trivial) example of the usefulness of currying, we can use it
    to shorten one of the examples that we saw above: *)

Example test_map1': map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** Thought exercise: before running the following commands, can you
    calculate the types of [prod_curry] and [prod_uncurry]? *)

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof. reflexivity. Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros.
  unfold prod_uncurry. unfold prod_curry. destruct p. reflexivity. Qed.
(** [] *)

(** **** Exercise: 2 stars, advanced (nth_error_informal)

    Recall the definition of the [nth_error] function:

   Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
     match l with
     | [] => None
     | a :: l' => if n =? O then Some a else nth_error l' (pred n)
     end.

   Write an informal proof of the following theorem:

   forall X n l, length l = n -> @nth_error X l n = None
*)
(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_informal_proof : option (nat*string) := None.
(** [] *)

(** The following exercises explore an alternative way of defining
    natural numbers, using the so-called _Church numerals_, named
    after mathematician Alonzo Church.  We can represent a natural
    number [n] as a function that takes a function [f] as a parameter
    and returns [f] iterated [n] times. *)

Module Church.
Definition cnat := forall X : Type, (X -> X) -> X -> X.

(** Let's see how to write some numbers with this notation. Iterating
    a function once should be the same as just applying it.  Thus: *)

Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

(** Similarly, [two] should apply [f] twice to its argument: *)

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

(** Defining [zero] is somewhat trickier: how can we "apply a function
    zero times"?  The answer is actually simple: just return the
    argument untouched. *)

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

(** More generally, a number [n] can be written as [fun X f x => f (f
    ... (f x) ...)], with [n] occurrences of [f].  Notice in
    particular how the [doit3times] function we've defined previously
    is actually just the Church representation of [3]. *)

Definition three : cnat := @doit3times.

(** Complete the definitions of the following functions. Make sure
    that the corresponding unit tests pass by proving them with
    [reflexivity]. *)

(** **** Exercise: 1 star, advanced (church_succ)  *)

(** Successor of a natural number: given a Church numeral [n],
    the successor [succ n] is a function that iterates its
    argument once more than [n]. *)
Definition succ (n : cnat) : cnat := fun (X : Type) (f : X -> X) (x : X) => f (n X f x).

Example succ_1 : succ zero = one.
Proof. reflexivity. Qed.

Example succ_2 : succ one = two.
Proof. reflexivity. Qed.

Example succ_3 : succ two = three.
Proof. reflexivity. Qed.

(** [] *)

(** **** Exercise: 1 star, advanced (church_plus)  *)

(** Addition of two natural numbers: *)
Definition plus (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => n X f (m X f x).

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.

Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

(** [] *)

(** **** Exercise: 2 stars, advanced (church_mult)  *)

(** Multiplication: *)
Definition mult (n m : cnat) : cnat  := fun (X : Type) (f : X -> X) => m X (n X f).

Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.

Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.

Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

(** [] *)

(** **** Exercise: 2 stars, advanced (church_exp)  *)

(** Exponentiation: *)

(** (_Hint_: Polymorphism plays a crucial role here.  However,
    choosing the right type to iterate over can be tricky.  If you hit
    a "Universe inconsistency" error, try iterating over a different
    type.  Iterating over [cnat] itself is usually problematic.) *)

Definition exp (n m : cnat) : cnat := fun (X : Type) => m (X -> X) (n X).

Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.

Example exp_2 : exp three zero = one.
Proof. reflexivity. Qed.

Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.

(** [] *)

End Church.

End Exercises.

(* Wed Aug 28 14:52 EST 2019 *)


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma lshift_inj (m n : nat) : injective (@lshift m n).
Proof. by move=> x y /(f_equal val) /= /val_inj. Qed.

Lemma rshift_inj (m n : nat) : injective (@rshift m n).
Proof. by move=> x y /(f_equal val) /addnI /val_inj. Qed.

Lemma lshift_rshift_neq (m n : nat) i j : lshift m i != rshift n j.
Proof. by rewrite eqE /= neq_ltn ltn_addr. Qed.

Lemma rshift_lshift_neq (m n : nat) i j : rshift n j != lshift m i.
Proof. by rewrite eq_sym; exact: lshift_rshift_neq. Qed.

Lemma enum_rank_in_inj
      (T : finType) (x0 y0 : T) A (Ax0 : x0 \in A) (Ay0 : y0 \in A) :
  {in A &, forall x y, enum_rank_in Ax0 x = enum_rank_in Ay0 y -> x = y}.
Proof. by move=> x y xA yA /(congr1 enum_val); rewrite !enum_rankK_in. Qed.

Lemma all_allpairsP
      (S : eqType) (T : S -> eqType) (R : Type)
      (g : pred R) (f : forall i : S, T i -> R)
      (s : seq S) (t : forall i : S, seq (T i)) :
  reflect (forall (i : S) (j : T i), i \in s -> j \in t i -> g (f i j))
          (all g [seq f i j | i <- s, j <- t i]).
Proof.
elim: s => [|x s IHs]; first by constructor.
rewrite /= all_cat all_map /preim.
apply/(iffP andP)=> [[/allP /= ? ? x' y x'_in_xs]|p_xs_t].
  by move: x'_in_xs y; rewrite inE => /predU1P [-> //|? ?]; exact: IHs.
split; first by apply/allP => ?; exact/p_xs_t/mem_head.
by apply/IHs => x' y x'_in_s; apply: p_xs_t; rewrite inE x'_in_s orbT.
Qed.

Lemma all_pmap S T (p : pred T) (f : S -> option T) xs :
  all p (pmap f xs) = all (fun i => oapp p true (f i)) xs.
Proof. by elim: xs => //= x xs <-; case: (f x). Qed.

Lemma all_filter S (p q : pred S) xs :
  all p (filter q xs) = all (fun i => q i ==> p i) xs.
Proof. by elim: xs => //= x xs <-; case: (q x). Qed.

Lemma all_enum (T : finType) (P : pred T) : all P (enum T) = [forall i, P i].
Proof.
apply/allP/forallP => H x; move: (H x); rewrite mem_enum inE //; exact.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) : natural := plus x (plus Zero y).


(** * Maps: Total and Partial Maps *)

(** _Maps_ (or _dictionaries_) are ubiquitous data structures both
    generally and in the theory of programming languages in
    particular; we're going to need them in many places in the coming
    chapters.  They also make a nice case study using ideas we've seen
    in previous chapters, including building data structures out of
    higher-order functions (from [Basics] and [Poly]) and the use of
    reflection to streamline proofs (from [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** One small digression before we begin...

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Export Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Lists.List.
Import ListNotations.

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/.

    The [Search] command is a good way to look for theorems involving
    objects of specific types.  Take a minute now to experiment with it. *)

(* ################################################################# *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
    maps.  For this purpose, we will simply use plain [string]s. *)

(** To compare strings, we define the function [beq_string], which
    internally uses the function [string_dec] from Coq's string library.
    We then establish its fundamental properties. *)

Definition beq_string x y :=
  if string_dec x y then true else false.

(** (The function [string_dec] comes from Coq's string library.
    If you check the result type of [string_dec], you'll see that it
    does not actually return a [bool], but rather a type that looks
    like [{x = y} + {x <> y}], called a [sumbool], which can be
    thought of as an "evidence-carrying boolean."  Formally, an
    element of [sumbool] is either a proof that two things are equal
    or a proof that they are unequal, together with a tag indicating
    which.  But for present purposes you can think of it as just a
    fancy [bool].) *)

Theorem beq_string_refl : forall s, true = beq_string s s.
Proof. intros s. unfold beq_string. destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.

(** The following useful property of [beq_string] follows from an
    analogous lemma about strings: *)

Theorem beq_string_true_iff : forall x y : string,
  beq_string x y = true <-> x = y.
Proof.
   intros x y.
   unfold beq_string.
   destruct (string_dec x y) as [|Hs].
   - subst. split. reflexivity. reflexivity.
   - split.
     + intros contra. inversion contra.
     + intros H. inversion H. subst. destruct Hs. reflexivity.
Qed.

(** Similarly: *)

Theorem beq_string_false_iff : forall x y : string,
  beq_string x y = false
  <-> x <> y.
Proof.
  intros x y. rewrite <- beq_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** This useful variant follows just by rewriting: *)

Theorem false_beq_string : forall x y : string,
   x <> y -> beq_string x y = false.
Proof.
  intros x y. rewrite beq_string_false_iff.
  intros H. apply H. Qed.

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about its behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the very same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps. *)

(** We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A:Type) := string -> A.

(** Intuitively, a total map over an element type [A] is just a
    function that can be used to look up [string]s, yielding [A]s. *)

(** The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any string. *)

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A:Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if beq_string x x' then v else m x'.

(** This definition is a nice example of higher-order programming:
    [t_update] takes a _function_ [m] and yields a new function
    [fun x' => ...] that behaves like the desired map. *)

(** For example, we can build a map taking [string]s to [bool]s, where
    ["foo"] and ["bar"] are mapped to [true] and every other key is
    mapped to [false], like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

(** Next, let's introduce some new notations to facilitate working
    with maps. *)

(** First, we will use the following notation to create an empty total map
    with a default value. *)
Notation "{ --> d }" := (t_empty d) (at level 0).

(** We then introduce a convenient notation for extending an existing
    map with some bindings. *)

(** (The definition of the notation is a bit ugly, but because the
    notation mechanism of Coq is not very well suited for recursive
    notations, it's the best we can do.) *)

Notation "m '&' { a --> x }" :=
  (t_update m a x) (at level 20).
Notation "m '&' { a --> x ; b --> y }" :=
  (t_update (m & { a --> x }) b y) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z }" :=
  (t_update (m & { a --> x ; b --> y }) c z) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z }) d t) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t ; e --> u }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z ; d --> t }) e u) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z ; d --> t ; e --> u }) f v) (at level 20).

(** The [examplemap] above can now be defined as follows: *)

Definition examplemap' :=
  { --> false } & { "foo" --> true ; "bar" --> true }.

(** This completes the definition of total maps.  Note that we
    don't need to define a [find] operation because it is just
    function application! *)

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave. *)

(** Even if you don't work the following exercises, make sure
    you thoroughly understand the statements of the lemmas! *)

(** (Some of the proofs require the functional extensionality axiom,
    which is discussed in the [Logic] chapter.) *)

(** **** Exercise: 1 star, optional (t_apply_empty)  *)
(** First, the empty map returns its default element for all keys: *)

Lemma t_apply_empty:  forall (A:Type) (x: string) (v: A), { --> v } x = v.
Proof.
  intros. reflexivity. Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_eq)  *)
(** Next, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall A (m: total_map A) x v,
  (m & {x --> v}) x = v.
Proof.
  intros A m x v. unfold t_update. rewrite <- beq_string_refl. reflexivity. Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (t_update_neq)  *)
(** On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (m & {x1 --> v}) x2 = m x2.
Proof.
  intros X v x1 x2 m H0. unfold t_update. apply beq_string_false_iff in H0.
  rewrite H0. reflexivity. Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (t_update_shadow)  *)
(** If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    m & {x --> v1 ; x --> v2} = m & {x --> v2}.
Proof.
  intros A m v1 v2 x. unfold t_update. apply functional_extensionality.
  intros x0. destruct (beq_string x x0) eqn : Hbeq.
  - reflexivity.
  - reflexivity. Qed.

(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on [id]s with the boolean function [beq_id]. *)

(** **** Exercise: 2 stars, optional (beq_stringP)  *)
(** Use the proof of [beq_natP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma beq_stringP : forall x y, reflect (x = y) (beq_string x y).
Proof.
  intros x y. destruct (beq_string x y) eqn : Hbeq.
  - apply beq_string_true_iff in Hbeq. apply ReflectT. apply Hbeq.
  - apply beq_string_false_iff in Hbeq. apply ReflectF. apply Hbeq. Qed.

(** [] *)

(** Now, given [string]s [x1] and [x2], we can use the [destruct (beq_stringP
    x1 x2)] to simultaneously perform case analysis on the result of
    [beq_string x1 x2] and generate hypotheses about the equality (in the
    sense of [=]) of [x1] and [x2]. *)

(** **** Exercise: 2 stars (t_update_same)  *)
(** With the example in chapter [IndProp] as a template, use
    [beq_stringP] to prove the following theorem, which states that if we
    update a map to assign key [x] the same value as it already has in
    [m], then the result is equal to [m]: *)

Theorem t_update_same : forall X x (m : total_map X),
    m & { x --> m x } = m.
Proof.
  intros X x m. unfold t_update. apply functional_extensionality.
  intros x0. destruct (beq_string x x0) eqn : Hbeq.
  - apply beq_string_true_iff in Hbeq. rewrite Hbeq. reflexivity.
  - reflexivity. Qed.

(** [] *)

(** **** Exercise: 3 stars, recommended (t_update_permute)  *)
(** Use [beq_stringP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
  m & { x2 --> v2 ; x1 --> v1 }
  =  m & { x1 --> v1 ; x2 --> v2 }.
Proof.
  intros X v1 v2 x1 x2 m H0. unfold t_update. apply functional_extensionality.
  intros x. destruct (beq_string x1 x) eqn : Hbeq1.
  - destruct (beq_string x2 x) eqn : Hbeq2.
    + apply beq_string_true_iff in Hbeq1. apply beq_string_true_iff in Hbeq2.
      rewrite <- Hbeq1 in Hbeq2. contradiction.
    + reflexivity.
  - reflexivity. Qed.

(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
           (x : string) (v : A) :=
  m & { x --> (Some v) }.

(** We introduce a similar notation for partial maps, using double
    curly-brackets.  **)

Notation "m '&' {{ a --> x }}" :=
  (update m a x) (at level 20).
Notation "m '&' {{ a --> x ; b --> y }}" :=
  (update (m & {{ a --> x }}) b y) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z }}" :=
  (update (m & {{ a --> x ; b --> y }}) c z) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z }}) d t) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z ; d --> t }}) e u) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }}) f v) (at level 20).

(** We now straightforwardly lift all of the basic lemmas about total
    maps to partial maps.  *)

Lemma apply_empty : forall (A: Type) (x: string),  @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
    (m & {{ x --> v }}) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (m & {{ x2 --> v }}) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
    m & {{ x --> v1 ; x --> v2 }} = m & {{x --> v2}}.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  m & {{x --> v}} = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                           (m : partial_map X),
  x2 <> x1 ->
  m & {{x2 --> v2 ; x1 --> v1}}
  = m & {{x1 --> v1 ; x2 --> v2}}.
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (lf1 : natural) : natural := plus lf1 lf2.


Require Import Algebra.Groups.Group.
Require Import Algebra.Groups.Subgroup.
Require Import WildCat.

(** * Kernels of group homomorphisms *)

Local Open Scope mc_scope.
Local Open Scope mc_mult_scope.

Definition grp_kernel {A B : Group} (f : GroupHomomorphism A B) : NormalSubgroup A.
Proof.
  snrapply Build_NormalSubgroup.
  - srapply (Build_Subgroup' (fun x => f x = group_unit)).
    1: apply grp_homo_unit.
    intros x y p q; cbn in p, q; cbn.
    refine (grp_homo_op _ _ _ @ ap011 _ p _ @ _).
    1: apply grp_homo_inv.
    rewrite q; apply right_inverse.
  - intros x y; cbn.
    rewrite 2 grp_homo_op.
    rewrite 2 grp_homo_inv.
    refine (_^-1 oE grp_moveL_M1).
    refine (_ oE equiv_path_inverse _ _).
    apply grp_moveR_1M.
  Defined.

(** ** Corecursion principle for group kernels *)

Proposition grp_kernel_corec {A B G : Group} {f : A $-> B} (g : G $-> A)
            (h : f $o g == grp_homo_const) : G $-> grp_kernel f.
Proof.
  snrapply Build_GroupHomomorphism.
  - exact (fun x:G => (g x; h x)).
  - intros x x'.
    apply path_sigma_hprop; cbn.
    apply grp_homo_op.
Defined.

Theorem equiv_grp_kernel_corec `{Funext} {A B G : Group} {f : A $-> B}
  : (G $-> grp_kernel f) <~> (exists g : G $-> A, f $o g == grp_homo_const).
Proof.
  srapply equiv_adjointify.
  - intro k.
    srefine (_ $o k; _).
    1: apply subgroup_incl.
    intro x; cbn.
    exact (k x).2.
  - intros [g p].
    exact (grp_kernel_corec _ p).
  - intros [g p].
    apply path_sigma_hprop; unfold pr1.
    apply equiv_path_grouphomomorphism; intro; reflexivity.
  - intro k.
    apply equiv_path_grouphomomorphism; intro x.
    apply path_sigma_hprop; reflexivity.
Defined.

(** ** Characterisation of group embeddings *)
Proposition equiv_kernel_isembedding `{Univalence} {A B : Group} (f : A $-> B)
  : (grp_kernel f = trivial_subgroup :> Subgroup A) <~> IsEmbedding f.
Proof.
  refine (_ oE (equiv_path_subgroup' _ _)^-1%equiv).
  apply equiv_iff_hprop_uncurried.
  refine (iff_compose _ (isembedding_grouphomomorphism f)); split.
  - intros E ? ?.
    by apply E.
  - intros e a; split.
    + apply e.
    + intro p.
      exact (ap _ p @ grp_homo_unit f).
Defined.


From Topology Require Export TopologicalSpaces WeakTopology FilterLimits Compactness.
From Coq Require Import FunctionalExtensionality.
From ZornsLemma Require Import DependentTypeChoice EnsembleProduct FiniteIntersections.

Section product_topology.

Variable A:Type.
Variable X:forall a:A, TopologicalSpace.

Definition product_space_point_set : Type :=
  forall a:A, X a.
Definition product_space_proj (a:A) :
  product_space_point_set -> X a :=
  fun (x:product_space_point_set) => x a.

Definition ProductTopology : TopologicalSpace :=
  WeakTopology product_space_proj.

Lemma product_space_proj_continuous: forall a:A,
  continuous (product_space_proj a) (X:=ProductTopology).
Proof.
apply weak_topology_makes_continuous_funcs.
Qed.

Lemma product_net_limit: forall (I:DirectedSet)
  (x:Net I ProductTopology) (x0:ProductTopology),
  inhabited (DS_set I) ->
  (forall a:A, net_limit (fun i:DS_set I => x i a) (x0 a)) ->
  net_limit x x0.
Proof.
intros.
now apply net_limit_in_projections_impl_net_limit_in_weak_topology.
Qed.

Lemma product_filter_limit:
  forall (F:Filter ProductTopology)
    (x0:ProductTopology),
  (forall a:A, filter_limit (filter_direct_image
                     (product_space_proj a) F) (x0 a)) ->
  filter_limit F x0.
Proof.
intros.
assert (subbasis
  (weak_topology_subbasis product_space_proj)
  (X:=ProductTopology)) by
  apply Build_TopologicalSpace_from_subbasis_subbasis.
red. intros.
red. intros U ?.
destruct H1.
destruct H1 as [U' []].
cut (In (filter_family F) U').
- intro.
  apply filter_upward_closed with U'; trivial.
- destruct H1.
  destruct (subbasis_cover _ _ H0 _ _ H3 H1) as
    [B [? [V [? []]]]].
  cut (In (filter_family F) (IndexedIntersection V)).
  + intro.
    eapply filter_upward_closed;
      eassumption.
  + apply filter_finite_indexed_intersection;
      trivial.
    intro b.
    pose proof (H5 b).
    inversion H8.
    apply H.
    constructor.
    apply open_neighborhood_is_neighborhood.
    constructor; trivial.
    destruct H6.
    pose proof (H6 b).
    rewrite <- H9 in H11.
    now destruct H11.
Qed.

Theorem TychonoffProductTheorem:
  (forall a:A, compact (X a)) -> compact ProductTopology.
Proof.
intro.
apply ultrafilter_limit_impl_compact.
intros.
destruct (choice_on_dependent_type (fun (a:A) (x:X a) =>
  filter_limit (filter_direct_image (product_space_proj a) U) x))
  as [choice_fun].
- intro.
  destruct (compact_impl_filter_cluster_point _ (H a)
    (filter_direct_image (product_space_proj a) U)) as [xa].
  exists xa.
  apply ultrafilter_cluster_point_is_limit; trivial.
  red. intros.
  now destruct (H0 (inverse_image (product_space_proj a) S));
    [left | right];
    constructor;
    [ | rewrite inverse_image_complement ].
- exists choice_fun.
  now apply product_filter_limit.
Qed.

End product_topology.

Arguments ProductTopology {A}.
Arguments product_space_proj {A} {X}.

Lemma product_map_continuous: forall {A:Type}
  (X:TopologicalSpace) (Y:A->TopologicalSpace)
  (f:forall a:A, X -> Y a) (x:X),
  (forall a:A, continuous_at (f a) x) ->
  continuous_at (fun x:X => (fun a:A => f a x)) x
    (Y:=ProductTopology Y).
Proof.
intros.
apply func_preserving_net_limits_is_continuous.
intros.
apply product_net_limit.
- destruct (H0 Full_set) as [i].
  + apply open_full.
  + constructor.
  + now exists.
- intros.
  now apply continuous_func_preserves_net_limits.
Qed.

Section product_topology2.

(* we provide a version of the product topology on [X] and [Y]
   whose underlying set is [point_set X * point_set Y], for
   more convenience as compared with the general definition *)
Variable X Y:TopologicalSpace.

Inductive twoT := | twoT_1 | twoT_2.
Let prod2_fun (i:twoT) := match i with
  | twoT_1 => X | twoT_2 => Y end.
Let prod2 := ProductTopology prod2_fun.

Let prod2_conv1 (p:prod2) : X * Y :=
  (p twoT_1, p twoT_2).
Let prod2_conv2 (p : X * Y) : prod2 :=
  let (x,y):=p in fun i:twoT => match i with
    | twoT_1 => x | twoT_2 => y
  end.

Lemma prod2_comp1: forall p:prod2,
  prod2_conv2 (prod2_conv1 p) = p.
Proof.
intros.
extensionality i.
now destruct i.
Qed.

Lemma prod2_comp2: forall p:X * Y,
  prod2_conv1 (prod2_conv2 p) = p.
Proof.
now intros [? ?].
Qed.

Let prod2_proj := fun i:twoT =>
  match i return (X * Y -> (prod2_fun i)) with
  | twoT_1 => @fst X Y
  | twoT_2 => @snd X Y
  end.

Definition ProductTopology2 : TopologicalSpace :=
  WeakTopology prod2_proj.

Lemma prod2_conv1_cont: continuous prod2_conv1 (Y:=ProductTopology2).
Proof.
apply pointwise_continuity.
intros p.
apply func_preserving_net_limits_is_continuous.
intros.
apply net_limit_in_projections_impl_net_limit_in_weak_topology.
- destruct (H Full_set).
  + apply open_full.
  + constructor.
  + exact (inhabits x0).
- destruct a;
    simpl.
  + now apply net_limit_in_weak_topology_impl_net_limit_in_projections
      with (a:=twoT_1) in H.
  + now apply net_limit_in_weak_topology_impl_net_limit_in_projections
      with (a:=twoT_2) in H.
Qed.

Lemma prod2_conv2_cont: continuous prod2_conv2 (X:=ProductTopology2).
Proof.
apply pointwise_continuity.
destruct x as [x y].
apply func_preserving_net_limits_is_continuous.
intros.
apply net_limit_in_projections_impl_net_limit_in_weak_topology.
- destruct (H Full_set).
  + apply open_full.
  + constructor.
  + exact (inhabits x1).
- destruct a.
  + unfold product_space_proj.
    simpl.
    replace (fun i => prod2_conv2 (x0 i) twoT_1) with
      (fun i => fst (x0 i)).
    * now apply net_limit_in_weak_topology_impl_net_limit_in_projections
        with (a:=twoT_1) in H.
    * extensionality i.
      now destruct (x0 i).
  + unfold product_space_proj.
    simpl.
    replace (fun i:DS_set I => prod2_conv2 (x0 i) twoT_2) with
      (fun i:DS_set I => snd (x0 i)).
    * now apply net_limit_in_weak_topology_impl_net_limit_in_projections
        with (a:=twoT_2) in H.
    * extensionality i.
      now destruct (x0 i).
Qed.

Lemma product2_fst_continuous:
  continuous (@fst X Y)
    (X:=ProductTopology2).
Proof.
exact (weak_topology_makes_continuous_funcs
  _ _ _ prod2_proj twoT_1).
Qed.

Lemma product2_snd_continuous:
  continuous (@snd X Y)
    (X:=ProductTopology2).
Proof.
exact (weak_topology_makes_continuous_funcs
  _ _ _ prod2_proj twoT_2).
Qed.

Lemma product2_map_continuous_at: forall (W:TopologicalSpace)
  (f:W -> X) (g:W -> Y) (w:W),
  continuous_at f w -> continuous_at g w ->
  continuous_at (fun w:W => (f w, g w)) w (Y:=ProductTopology2).
Proof.
intros.
replace (fun w:W => (f w, g w)) with
  (fun w:W => prod2_conv1
             (fun i:twoT =>
                match i with
                | twoT_1 => f w
                | twoT_2 => g w end)).
- apply (@continuous_composition_at W prod2 ProductTopology2
    prod2_conv1
    (fun w:W =>
       fun i:twoT => match i with
           | twoT_1 => f w | twoT_2 => g w end)).
  + apply continuous_func_continuous_everywhere.
    apply prod2_conv1_cont.
  + apply product_map_continuous.
    now destruct a.
- now extensionality w0.
Qed.

Corollary product2_map_continuous: forall (W:TopologicalSpace)
  (f:W -> X) (g:W -> Y),
  continuous f -> continuous g ->
  continuous (fun w:W => (f w, g w))
  (Y:=ProductTopology2).
Proof.
  intros.
  apply pointwise_continuity.
  intros.
  apply product2_map_continuous_at.
  - apply continuous_func_continuous_everywhere.
    assumption.
  - apply continuous_func_continuous_everywhere.
    assumption.
Qed.

Inductive ProductTopology2_basis :
  Family ProductTopology2 :=
| intro_product2_basis_elt:
  forall (U:Ensemble X)
         (V:Ensemble Y),
  open U -> open V ->
  In ProductTopology2_basis (EnsembleProduct U V).

Lemma ProductTopology2_basis_is_basis:
  open_basis ProductTopology2_basis.
Proof.
assert (open_basis (finite_intersections (weak_topology_subbasis prod2_proj))
  (X:=ProductTopology2)) by apply
  Build_TopologicalSpace_from_open_basis_basis.
apply eq_ind with (1:=H).
apply Extensionality_Ensembles; split; red; intros U ?.
- induction H0.
  + rewrite <- EnsembleProduct_Full.
    constructor; apply open_full.
  + destruct H0.
    destruct a.
    * simpl.
      rewrite inverse_image_fst.
      constructor; auto with topology.
    * simpl.
      rewrite inverse_image_snd.
      constructor; auto with topology.
  + destruct IHfinite_intersections as [U1 V1].
    destruct IHfinite_intersections0 as [U2 V2].
    rewrite EnsembleProduct_Intersection.
    constructor; auto with topology.
- destruct H0.
  rewrite EnsembleProduct_proj.
  constructor 3.
  + constructor.
    replace (@fst X Y) with (prod2_proj twoT_1); auto.
    constructor. assumption.
  + constructor.
    replace (@snd X Y) with (prod2_proj twoT_2); auto.
    constructor. assumption.
Qed.

End product_topology2.

Section two_arg_convenience_results.

Variable X Y Z:TopologicalSpace.
Variable f:X -> Y -> Z.

Definition continuous_2arg :=
  continuous (fun p:X * Y =>
                f (fst p) (snd p))
  (X:=ProductTopology2 X Y).
Definition continuous_at_2arg (x:X) (y:Y) :=
  continuous_at (fun p:X * Y =>
                 f (fst p) (snd p))  (x, y)
  (X:=ProductTopology2 X Y).

Lemma continuous_2arg_func_continuous_everywhere:
  continuous_2arg -> forall (x:X) (y:Y),
                       continuous_at_2arg x y.
Proof.
intros.
now apply continuous_func_continuous_everywhere.
Qed.

Lemma pointwise_continuity_2arg:
  (forall (x:X) (y:Y),
   continuous_at_2arg x y) -> continuous_2arg.
Proof.
intros.
apply pointwise_continuity.
intros [? ?].
apply H.
Qed.

End two_arg_convenience_results.

Arguments continuous_2arg {X} {Y} {Z}.
Arguments continuous_at_2arg {X} {Y} {Z}.

Lemma continuous_composition_at_2arg:
  forall (W X Y Z:TopologicalSpace)
    (f:X -> Y -> Z) (g:W -> X) (h:W -> Y)
    (w:W),
  continuous_at_2arg f (g w) (h w) ->
  continuous_at g w -> continuous_at h w ->
  continuous_at (fun w:W => f (g w) (h w)) w.
Proof.
intros.
red in H.
apply (continuous_composition_at
  (fun p:ProductTopology2 X Y =>
      f (fst p) (snd p))
  (fun w:W => (g w, h w))); trivial.
now apply product2_map_continuous_at.
Qed.

Corollary continuous_composition_2arg:
  forall {U X Y Z : TopologicalSpace} (f : U -> X) (g : U -> Y) (h : X -> Y -> Z),
    continuous f -> continuous g -> continuous_2arg h ->
    continuous (fun p => h (f p) (g p)).
Proof.
  intros.
  apply pointwise_continuity.
  intros.
  apply continuous_composition_at_2arg.
  - apply continuous_2arg_func_continuous_everywhere.
    assumption.
  - apply continuous_func_continuous_everywhere.
    assumption.
  - apply continuous_func_continuous_everywhere.
    assumption.
Qed.

Lemma EnsembleProduct_open {X Y : TopologicalSpace} (U : Ensemble X) (V : Ensemble Y) :
open U -> open V -> @open (@ProductTopology2 X Y) (EnsembleProduct U V).
Proof.
intros.
apply ProductTopology2_basis_is_basis.
constructor; assumption.
Qed.

Lemma Hausdorff_ProductTopology2 {X Y : TopologicalSpace} :
  Hausdorff X -> Hausdorff Y ->
  Hausdorff (ProductTopology2 X Y).
Proof.
  intros HX HY [x0 y0] [x1 y1] Hxy.
  specialize (HX x0 x1).
  specialize (HY y0 y1).
  (* Is there some "symmetry" that can be used, so the proof doesn't
     contain redundant parts? *)
  destruct (classic (x0 = x1)) as [|Hx].
  { subst.
    assert (y0 <> y1) as Hy by congruence.
    clear Hxy.
    specialize (HY Hy) as [U [V [HU [HV [HU0 [HV0 HUV]]]]]].
    exists (EnsembleProduct Full_set U), (EnsembleProduct Full_set V).
    repeat split; auto using EnsembleProduct_open, open_full.
    simpl.
    rewrite EnsembleProduct_Intersection.
    rewrite Powerset_facts.Intersection_Full_set.
    rewrite HUV.
    apply EnsembleProduct_Empty_r.
  }
  clear Hxy.
  specialize (HX Hx) as [U [V [HU [HV [HU0 [HV0 HUV]]]]]].
  exists (EnsembleProduct U Full_set), (EnsembleProduct V Full_set).
  repeat split; auto using EnsembleProduct_open, open_full.
  simpl.
  rewrite EnsembleProduct_Intersection.
  rewrite Powerset_facts.Intersection_Full_set.
  rewrite HUV.
  apply EnsembleProduct_Empty_l.
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils subcode sss.

From Undecidability.MinskyMachines Require Export MM.
From Undecidability.MinskyMachines.MMenv Require Import env.

Set Implicit Arguments.

Set Default Proof Using "Type".

(* * Minsky Machines

    A Minsky machine has n registers and there are just two instructions

    1/ INC x   : increment register x by 1
    2/ DEC x k : decrement register x by 1 if x > 0
                 or jump to k if x = 0

  *)

(* Semantics for MM based on environments *)

Section Minsky_Machine_env_based.

  Variable (X : Set) (X_eq_dec : eqdec X).

  Definition mm_state := (nat*env X nat)%type.

  Local Notation " e ⇢ x " := (@get_env _ _ e x).
  Local Notation " e ⦃  x ⇠ v ⦄ " := (@set_env _ _ X_eq_dec e x v).

  (* Minsky machine small step semantics *)

  Inductive mm_sss_env : mm_instr X -> mm_state -> mm_state -> Prop :=
    | in_mm_sss_env_inc   : forall i x v,                   INC x  // (i,v) -1> (1+i,v⦃x⇠S(v⇢x)⦄)
    | in_mm_sss_env_dec_0 : forall i x k v,   v⇢x = O   -> DEC x k // (i,v) -1> (k,v)
    | in_mm_sss_env_dec_1 : forall i x k v u, v⇢x = S u -> DEC x k // (i,v) -1> (1+i,v⦃x⇠u⦄)
  where "i // s -1> t" := (mm_sss_env i s t).

  Fact mm_sss_env_fun i s t1 t2 : i // s -1> t1 -> i // s -1> t2 -> t1 = t2.
  Proof.
    intros []; subst.
    inversion 1; subst; auto.
    inversion 1; subst; auto.
    rewrite H in H6; discriminate.
    inversion 1; subst; auto.
    rewrite H in H6; discriminate.
    rewrite H in H6; inversion H6; subst; auto.
  Qed.

  Fact mm_sss_env_total ii s : { t | ii // s -1> t }.
  Proof.
    destruct s as (i,v).
    destruct ii as [ x | x j ]; [ | case_eq (v⇢x); [ | intros k ]; intros E ].
    * exists (1+i,v⦃x⇠S(v⇢x)⦄); constructor.
    * exists (j,v); constructor; auto.
    * exists (1+i,v⦃x⇠k⦄); constructor; auto.
  Qed.

  Fact mm_sss_env_INC_inv x i v j w : INC x // (i,v) -1> (j,w) -> j=1+i /\ w = v⦃x⇠S(v⇢x)⦄.
  Proof. inversion 1; subst; auto. Qed.

  Fact mm_sss_env_DEC0_inv x k i v j w : v⇢x = O -> DEC x k // (i,v) -1> (j,w) -> j = k /\ w = v.
  Proof.
    intros H; inversion 1; subst; auto; rewrite H in H2; try discriminate.
  Qed.

  Fact mm_sss_env_DEC1_inv x k u i v j w : v⇢x = S u -> DEC x k // (i,v) -1> (j,w) -> j=1+i /\ w = v⦃x⇠u⦄.
  Proof.
    intros H; inversion 1; subst; auto; rewrite H in H2; try discriminate.
    inversion H2; subst; auto.
  Qed.

  Notation "P // s -[ k ]-> t" := (sss_steps mm_sss_env P k s t).
  Notation "P // s -+> t" := (sss_progress mm_sss_env P s t).
  Notation "P // s ->> t" := (sss_compute mm_sss_env P s t).

  Fact mm_env_progress_INC P i x v st :
         (i,INC x::nil) <sc P
      -> P // (1+i,v⦃x⇠S(v⇢x)⦄) ->> st
      -> P // (i,v) -+> st.
  Proof.
    intros H1 H2.
    apply sss_progress_compute_trans with (2 := H2).
    apply subcode_sss_progress with (1 := H1).
    exists 1; split; auto; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; lia.
    constructor; auto.
  Qed.

  Corollary mm_env_compute_INC P i x v st :
         (i,INC x::nil) <sc P
      -> P // (1+i,v⦃x⇠S(v⇢x)⦄) ->> st
      -> P // (i,v) ->> st.
  Proof. intros; apply sss_progress_compute; eapply mm_env_progress_INC; eauto. Qed.

  Fact mm_env_progress_DEC_0 P i x k v st :
         (i,DEC x k::nil) <sc P
      -> v⇢x = O
      -> P // (k,v) ->> st
      -> P // (i,v) -+> st.
  Proof.
    intros H1 H2 H3.
    apply sss_progress_compute_trans with (2 := H3).
    apply subcode_sss_progress with (1 := H1).
    exists 1; split; auto; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; lia.
    constructor; auto.
  Qed.

  Corollary mm_env_compute_DEC_0 P i x k v st :
         (i,DEC x k::nil) <sc P
      -> v⇢x = O
      -> P // (k,v) ->> st
      -> P // (i,v) ->> st.
  Proof. intros; apply sss_progress_compute; eapply mm_env_progress_DEC_0; eauto. Qed.

  Fact mm_env_progress_DEC_S P i x k v u st :
         (i,DEC x k::nil) <sc P
      -> v⇢x = S u
      -> P // (1+i,v⦃x⇠u⦄) ->> st
      -> P // (i,v) -+> st.
  Proof.
    intros H1 H2 H3.
    apply sss_progress_compute_trans with (2 := H3).
    apply subcode_sss_progress with (1 := H1).
    exists 1; split; auto; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; lia.
    constructor; auto.
  Qed.

  Corollary mm_env_compute_DEC_S P i x k v u st :
           (i,DEC x k::nil) <sc P
        -> v⇢x = S u
        -> P // (1+i,v⦃x⇠u⦄) ->> st
        -> P // (i,v) ->> st.
  Proof. intros; apply sss_progress_compute; eapply mm_env_progress_DEC_S; eauto. Qed.

  Fact mm_env_steps_INC_inv k P i x v st :
         (i,INC x::nil) <sc P
      -> k <> 0
      -> P // (i,v) -[k]-> st
      -> exists k', k' < k /\ P // (1+i,v⦃x⇠S(v⇢x)⦄) -[k']-> st.
  Proof.
    intros H1 H2 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (? & ?) | (k' & st2 & ? & H4 & H5) ]; subst; auto.
    destruct H2; auto.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    exists k'; split.
    lia.
    inversion H4; subst; auto.
  Qed.

  Fact mm_env_steps_DEC_0_inv k P i x p v st :
         (i,DEC x p::nil) <sc P
      -> k <> 0
      -> v⇢x = 0
      -> P // (i,v) -[k]-> st
      -> exists k', k' < k /\ P // (p,v) -[k']-> st.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (? & ?) | (k' & st2 & ? & H4 & H5) ]; subst; auto.
    destruct H2; auto.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    exists k'; split.
    lia.
    inversion H4; subst; auto.
    rewrite H3 in H9; discriminate.
  Qed.

  Fact mm_env_steps_DEC_1_inv k P i x p v u st :
         (i,DEC x p::nil) <sc P
      -> k <> 0
      -> v⇢x = S u
      -> P // (i,v) -[k]-> st
      -> exists k', k' < k /\ P // (1+i,v⦃x⇠u⦄) -[k']-> st.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (? & ?) | (k' & st2 & ? & H4 & H5) ]; subst; auto.
    destruct H2; auto.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    exists k'; split.
    lia.
    inversion H4; subst; auto; rewrite H3 in H9.
    discriminate.
    inversion H9; subst; auto.
  Qed.

End Minsky_Machine_env_based.

Local Notation "P // s -[ k ]-> t" := (sss_steps (@mm_sss_env _ _) P k s t).
Local Notation "P // s -+> t" := (sss_progress (@mm_sss_env _ _) P s t).
Local Notation "P // s ->> t" := (sss_compute (@mm_sss_env _ _) P s t).

Tactic Notation "mm" "env" "INC" "with" uconstr(a) :=
  match goal with
    | |- _ // _ -+> _ => apply mm_env_progress_INC with (x := a)
    | |- _ // _ ->> _ => apply mm_env_compute_INC with (x := a)
  end; auto.

Tactic Notation "mm" "env" "DEC" "zero" "with" uconstr(a) uconstr(b) :=
  match goal with
    | |- _ // _ -+> _ => apply mm_env_progress_DEC_0 with (x := a) (k := b)
    | |- _ // _ ->> _ => apply mm_env_compute_DEC_0 with (x := a) (k := b)
  end; auto.

Tactic Notation "mm" "env" "DEC" "S" "with" uconstr(a) uconstr(b) uconstr(c) :=
  match goal with
    | |- _ // _ -+> _ => apply mm_env_progress_DEC_S with (x := a) (k := b) (u := c)
    | |- _ // _ ->> _ => apply mm_env_compute_DEC_S with (x := a) (k := b) (u := c)
  end; auto.

Tactic Notation "mm" "env" "stop" := exists 0; apply sss_steps_0; auto.

(* The Halting problem for MM, for linear logic encoding, we restrict
   to a very specific halting problem. Starting from (1,v), does the
   MM halt at state (0,vec_zero) *)


Require Import Undecidability.FOL.Syntax.Facts Undecidability.FOL.Syntax.Theories.
Require Export Undecidability.FOL.Semantics.Tarski.FragmentCore.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Require Import Vector Lia.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Set Default Proof Using "Type".

Local Notation vec := Vector.t.

(* Tarski Semantics ***)

Section Tarski.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  (* Semantic notions *)

  Section Substs.

    Variable D : Type.
    Variable I : interp D.

    Lemma eval_ext rho xi t :
      (forall x, rho x = xi x) -> eval rho t = eval xi t.
    Proof.
      intros H. induction t; cbn.
      - now apply H.
      - f_equal. apply map_ext_in. now apply IH.
    Qed.

    Lemma eval_comp rho xi t :
      eval rho (subst_term xi t) = eval (xi >> eval rho) t.
    Proof.
      induction t; cbn.
      - reflexivity.
      - f_equal. rewrite map_map. apply map_ext_in, IH.
    Qed.

    Lemma sat_ext {ff : falsity_flag} rho xi phi :
      (forall x, rho x = xi x) -> rho ⊨ phi <-> xi ⊨ phi.
    Proof.
      induction phi  as [ | b P v | | ] in rho, xi |- *; cbn; intros H.
      - reflexivity.
      - erewrite map_ext; try reflexivity. intros t. now apply eval_ext.
      - specialize (IHphi1 rho xi). specialize (IHphi2 rho xi). destruct b0; intuition.
      - destruct q.
        + split; intros H' d; eapply IHphi; try apply (H' d). 1,2: intros []; cbn; intuition.
    Qed.

    Lemma sat_ext' {ff : falsity_flag} rho xi phi :
      (forall x, rho x = xi x) -> rho ⊨ phi -> xi ⊨ phi.
    Proof.
      intros Hext H. rewrite sat_ext. exact H.
      intros x. now rewrite (Hext x).
    Qed.

    Lemma sat_comp {ff : falsity_flag} rho xi phi :
      rho ⊨ (subst_form xi phi) <-> (xi >> eval rho) ⊨ phi.
    Proof.
      induction phi as [ | b P v | | ] in rho, xi |- *; cbn.
      - reflexivity.
      - erewrite map_map, map_ext; try reflexivity. intros t. apply eval_comp.
      - specialize (IHphi1 rho xi). specialize (IHphi2 rho xi). destruct b0; intuition.
      - destruct q.
        + setoid_rewrite IHphi. split; intros H d; eapply sat_ext. 2, 4: apply (H d).
          all: intros []; cbn; trivial; now setoid_rewrite eval_comp.
    Qed.

    Lemma sat_subst {ff : falsity_flag} rho sigma phi :
      (forall x, eval rho (sigma x) = rho x) -> rho ⊨ phi <-> rho ⊨ (subst_form sigma phi).
    Proof.
      intros H. rewrite sat_comp. apply sat_ext. intros x. now rewrite <- H.
    Qed.

    Lemma sat_single {ff : falsity_flag} (rho : nat -> D) (Phi : form) (t : term) :
      (eval rho t .: rho) ⊨ Phi <-> rho ⊨ subst_form (t..) Phi.
    Proof.
      rewrite sat_comp. apply sat_ext. now intros [].
    Qed.

    Lemma impl_sat {ff : falsity_flag} A rho phi :
      sat rho (A ==> phi) <-> ((forall psi, psi el A -> sat rho psi) -> sat rho phi).
    Proof.
      induction A; cbn; firstorder congruence.
    Qed.

    Lemma impl_sat' {ff : falsity_flag} A rho phi :
      sat rho (A ==> phi) -> ((forall psi, psi el A -> sat rho psi) -> sat rho phi).
    Proof.
      eapply impl_sat.
    Qed.

    Lemma bounded_eval_t n t sigma tau :
      (forall k, n > k -> sigma k = tau k) -> bounded_t n t -> eval sigma t = eval tau t.
    Proof.
      intros H. induction 1; cbn; auto.
      f_equal. now apply Vector.map_ext_in.
    Qed.

    Lemma bound_ext {ff : falsity_flag} N phi rho sigma :
      bounded N phi -> (forall n, n < N -> rho n = sigma n) -> (rho ⊨ phi <-> sigma ⊨ phi).
    Proof.
      induction 1 in sigma, rho |- *; cbn; intros HN; try tauto.
      - enough (map (eval rho) v = map (eval sigma) v) as E. now setoid_rewrite E.
        apply Vector.map_ext_in. intros t Ht.
        eapply bounded_eval_t; try apply HN. now apply H.
      - destruct binop; now rewrite (IHbounded1 rho sigma), (IHbounded2 rho sigma).
      - destruct quantop.
        + split; intros Hd d; eapply IHbounded.
          all : try apply (Hd d); intros [] Hk; cbn; auto.
          symmetry. all: apply HN; lia.
    Qed.

    Corollary sat_closed {ff : falsity_flag} rho sigma phi :
      bounded 0 phi -> rho ⊨ phi <-> sigma ⊨ phi.
    Proof.
      intros H. eapply bound_ext. apply H. lia.
    Qed.

    Lemma bounded_S_forall {ff : falsity_flag} N phi :
      bounded (S N) phi <-> bounded N (∀ phi).
    Proof.
      split; intros H.
      - now constructor.
      - inversion H. apply Eqdep_dec.inj_pair2_eq_dec in H4 as ->; trivial.
        unfold Dec.dec. decide equality.
    Qed.

    Definition forall_times {ff : falsity_flag} n (phi : form) := iter (fun psi => ∀ psi) n phi.

  End Substs.

End Tarski.

(* Trivial Model *)

Section TM.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Instance TM : interp unit :=
    {| i_func := fun _ _ => tt; i_atom := fun _ _ => True; |}.

  Fact TM_sat (rho : nat -> unit) (phi : form falsity_off) :
    rho ⊨ phi.
  Proof.
    revert rho. remember falsity_off as ff. induction phi; cbn; trivial.
    - discriminate.
    - destruct b0; auto.
    - destruct q; firstorder.
  Qed.

  Fact TM_sat_decidable {ff} (rho : nat -> unit) (phi : form ff) :
    rho ⊨ phi \/ ~(rho ⊨ phi).
  Proof.
    revert rho. induction phi; cbn; intros rho; eauto.
    - destruct b0. destruct (IHphi1 rho), (IHphi2 rho); tauto.
    - destruct q. destruct (IHphi (tt .: rho)).
      + left; now intros [].
      + right; intros Hcc. apply H, Hcc.
  Qed.

End TM.

Section FlagsTransport.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ff1 : falsity_flag}.

  Section Bottom.
    Variable D : Type.
    Variable I : interp D.
    Context (default : @form _ _ _ ff1).

    Lemma sat_to_falsity_compat {ff2} rho (phi : @form _ _ _ ff2) :
      (sat rho default -> False)
      -> sat rho phi <-> sat rho (phi[default /⊥]).
    Proof.
      induction phi as [|t1 t2|ff [] phi IHphi psi IHpsi|ff [] phi IHphi] in rho,default|-*; intros Hdefault; split.
      - intros [].
      - apply Hdefault.
      - intros H; apply H.
      - intros H; apply H.
      - intros H H1. cbn in H. apply IHpsi. 1:easy. apply H. now eapply IHphi, H1.
      - intros H H1. cbn in H. apply IHpsi with default. 1:easy. apply H. now apply IHphi.
      - intros H d. apply IHphi. 2: apply H. intros Hd. apply Hdefault.
        eapply sat_comp in Hd. eapply sat_ext in Hd. 1: apply Hd.
        now intros [|x].
      - intros H d. apply IHphi with (default [↑]). 2: apply H. intros Hd. apply Hdefault.
        eapply sat_comp in Hd. eapply sat_ext in Hd. 1: apply Hd.
        now intros [|x].
    Qed.
  End Bottom.
  Section Atoms.

    Context {Σ_preds2 : preds_signature}.
    Context (s : forall (P : Σ_preds), Vector.t (@term Σ_funcs) (ar_preds P) -> (@form Σ_funcs Σ_preds2 _ _)).
    Context (Hresp : atom_subst_respects s).

    Definition rho_from_vec {A} n (v : Vector.t A n) d : env A := fun m => match Compare_dec.lt_dec m n with
      left Hl => Vector.nth v (Fin.of_nat_lt Hl)
    | right _ => d end.

    Lemma rho_from_vec_map {A B} {n} (f : B -> A) (t : Vector.t B n) (d2 : A) (d:B):
     f d = d2 ->
     forall k, rho_from_vec (map f t) d2 k = f (rho_from_vec t d k).
    Proof.
      intros H k. unfold rho_from_vec. destruct (Compare_dec.lt_dec k n) as [Hl|Hr].
      - erewrite nth_map. 2:reflexivity. easy.
      - easy.
    Qed.

    Definition tabulate_vars n : Vector.t term n := Vectors.tabulate (fun p => $(proj1_sig (Fin.to_nat p))).

    Lemma semantic_lifting_correct n t tt :
      map (subst_term (rho_from_vec t tt)) (tabulate_vars n) = t.
    Proof.
      apply Vectors.eq_nth_iff'. intros i.
      erewrite nth_map. 2:reflexivity.
      unfold tabulate_vars. rewrite Vectors.nth_tabulate. cbn.
      unfold rho_from_vec. destruct (Fin.to_nat i) as [k Hk] eqn:Heq. cbn.
      destruct Compare_dec.lt_dec; try lia. f_equal.
      erewrite Fin.of_nat_ext.
      rewrite <- Fin.to_nat_of_nat in Heq.
      apply Fin.to_nat_inj. rewrite <- Heq. easy.
    Qed.

    Section ConstructInterp.
      Variable D : Type.
      (* Crucially, we need an interpretation for the formulas s maps _to_ *)
      Variable I : @interp Σ_funcs Σ_preds2 D.
      Definition lift_s_semantically (d:D) (P : Σ_preds) (v : Vector.t D (ar_preds P)) : Prop
        := sat (rho_from_vec v d) (s (tabulate_vars (ar_preds P))).

      (* To construct an interpretation for the formulas we are mapping _from_ *)
      Definition interp_s (d:D) : @interp Σ_funcs Σ_preds D := {|
        i_func := @i_func _ _ D I;
        i_atom := lift_s_semantically d
      |}.

      Lemma sat_atom_subst_compat rho phi n :
        sat rho (phi [s/atom]) <-> @sat _ _ _ (interp_s (rho n)) _ rho phi.
      Proof using Hresp.
        unfold interp_s, lift_s_semantically. revert rho n.
        induction phi as [|t1 t2|ff [] phi IHphi psi IHpsi|ff [] phi IHphi]; split.
        - intros H; apply H.
        - intros H; apply H.
        - cbn; intros H.
          eapply sat_ext with (((rho_from_vec t $n) >> eval rho)).
          1: intros x; unfold funcomp. now apply rho_from_vec_map.
          rewrite <- sat_comp. rewrite Hresp. now rewrite semantic_lifting_correct.
        - cbn; intros H.
          eapply (@sat_ext _ _ _ _ _ (((rho_from_vec t $n) >> eval rho))) in H.
          2: intros x; unfold funcomp; symmetry; now apply rho_from_vec_map.
          rewrite <- sat_comp in H. rewrite Hresp in H. now rewrite semantic_lifting_correct in H.
        - cbn; intros H1 Hphi. apply IHpsi. 1:easy. apply H1. apply IHphi with n. 1:easy. apply Hphi.
        - cbn; intros H1 Hphi. apply IHpsi with n. 1:easy. apply H1, IHphi. 1:easy. apply Hphi.
        - cbn; intros H1 d. apply (IHphi s Hresp (d.:rho) (S n)). apply H1.
        - cbn; intros H1 d. apply (IHphi s Hresp (d.:rho) (S n)). apply H1.
      Qed.

    End ConstructInterp.

    Lemma valid_atom_subst_compat phi :
      valid phi -> valid phi [s/atom].
    Proof using Hresp.
      intros H D I rho. unshelve apply <- sat_atom_subst_compat. 1:exact 0. apply H.
    Qed.

    Lemma satis_atom_subst_compat phi :
      satis phi[s/atom] -> satis phi .
    Proof using Hresp.
      intros (D&I&rho&H). unshelve eapply sat_atom_subst_compat in H. 1:exact 0. do 3 eexists. apply H.
    Qed.

  End Atoms.

End FlagsTransport.

Section Bottom.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Variable D : Type.
  Variable I : interp D.

  Definition interp_bot (F_P : Prop) (i : @interp Σ_funcs Σ_preds D) : @interp Σ_funcs (@Σ_preds_bot Σ_preds) D := {|
    i_func := @i_func _ _ D i;
    i_atom := fun (P : (@preds (@Σ_preds_bot Σ_preds))) => match P with inl _ => fun v => F_P | inr P => fun v => @i_atom _ _ D i P v end
  |}.

  Definition sat_bot {ff : falsity_flag} (F_P : Prop) (rho : env D) (phi : form) : Prop
    := @sat _ Σ_preds_bot D (interp_bot F_P I) falsity_off rho (falsity_to_pred phi).

  Lemma sat_bot_False {ff:falsity_flag} rho phi : sat_bot False rho phi <-> sat rho phi.
  Proof.
    induction phi in rho|-*.
    - easy.
    - easy.
    - destruct b0. unfold sat_bot, falsity_to_pred in *. cbn.
      split; intros H H1 %IHphi1; apply IHphi2; apply H, H1.
    - destruct q. unfold sat_bot, falsity_to_pred in *. cbn.
      split; intros H d; apply IHphi, H.
  Qed.

End Bottom.

Arguments sat_bot {_} {_} {_} {_} {_} _ _ _.

Section BottomDef.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {ff : falsity_flag}.

  Definition exploding D (M : interp D) (F_P:Prop) := forall rho phi, sat_bot F_P rho (⊥ → phi).
  Arguments exploding _ _ _ : clear implicits.
  Definition valid_exploding_ctx A phi :=
    forall D (M : interp D) F_P rho, exploding D M F_P -> (forall psi, psi el A -> sat_bot F_P rho psi) -> sat_bot F_P rho phi.

  Definition valid_exploding_theory (T:theory) phi :=
    forall D (M : interp D) F_P rho, exploding D M F_P ->  (forall psi, T psi -> sat_bot F_P rho psi) -> sat_bot F_P rho phi.

  Definition valid_exploding phi :=
    forall D (M : interp D) F_P rho, exploding D M F_P -> sat_bot F_P rho phi.

  Definition satis_exploding phi :=
    exists D (M : interp D) F_P rho, exploding D M F_P /\ sat_bot F_P rho phi.

End BottomDef.


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg fingroup finalg matrix.
Require Import Reals.
From mathcomp Require Import Rstruct.
Require Import ssrR Reals_ext ssr_ext ssralg_ext logb ln_facts Rbigop num_occ.
Require Import fdist entropy types jtypes divergence conditional_divergence.
Require Import error_exponent channel_code channel success_decode_bound.

(******************************************************************************)
(*                 Channel coding theorem (converse part)                     *)
(*                                                                            *)
(* main theorem: channel_coding_converse                                      *)
(*                                                                            *)
(* For details, see Reynald Affeldt, Manabu Hagiwara, and Jonas Sénizergues.  *)
(* Formalization of Shannon's theorems. Journal of Automated Reasoning,       *)
(* 53(1):63--103, 2014                                                        *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope channel_code_scope.
Local Open Scope channel_scope.
Local Open Scope entropy_scope.
Local Open Scope tuple_ext_scope.
Local Open Scope reals_ext_scope.
Local Open Scope proba_scope.
Local Open Scope types_scope.
Local Open Scope divergence_scope.
Local Open Scope R_scope.

Section channel_coding_converse_intermediate_lemma.
Variables (A B : finType) (W : `Ch*(A, B)).
Variable minRate : R.
Hypothesis HminRate : minRate > capacity W.
Hypothesis set_of_I_has_ubound :
  classical_sets.has_ubound (fun y => exists P, `I(P, W) = y).

Let Anot0 : (0 < #|A|)%nat. Proof. by case: W. Qed.

Let Bnot0 : (0 < #|B|)%nat.
Proof. case/card_gt0P : Anot0 => a _; exact: (fdist_card_neq0 (W a)). Qed.

Lemma channel_coding_converse_gen : exists Delta, 0 < Delta /\ forall n',
  let n := n'.+1 in forall (M : finType) (c : code A B M n), (0 < #|M|)%nat ->
    minRate <= CodeRate c ->
      scha(W, c) <= n.+1%:R ^ (#|A| + #|A| * #|B|) * exp2 (- n%:R * Delta).
Proof.
move: error_exponent_bound => /(_ _ _ Bnot0 W _ HminRate set_of_I_has_ubound).
case => Delta [Delta_pos HDelta].
exists Delta; split => // n' n M c Mnot0 H.
apply: (leR_trans (success_bound W Mnot0 c)).
set Pmax := [arg max_(P > _) _]%O.
set tc :=  _.-typed_code _.
rewrite pow_add -mulRA.
apply leR_wpmul2l; first exact/pow_le/leR0n.
apply: (leR_trans (typed_success_bound W Mnot0 (Pmax.-typed_code c))).
apply leR_wpmul2l; first exact/pow_le/leR0n.
set Vmax := [arg max_(V > _) _]%O.
rewrite /success_factor_bound /exp_cdiv.
case : ifP => Hcase; last by rewrite mul0R.
rewrite -ExpD.
apply Exp_le_increasing => //.
rewrite -mulRDr 2!mulNR.
rewrite leR_oppr oppRK; apply/leR_wpmul2l; first exact/leR0n.
have {}Hcase : Pmax |- Vmax << W.
  move=> a Hp; apply/dominatesP => b /eqP Hw.
  move/forallP : Hcase.
  by move/(_ a)/implyP/(_ Hp)/forallP/(_ b)/implyP/(_ Hw)/eqP.
apply (leR_trans (HDelta Pmax Vmax Hcase)) => /=.
exact/leR_add2l/Rle_max_compat_l/leR_add2r.
Qed.

End channel_coding_converse_intermediate_lemma.

Section channel_coding_converse.
Variables (A B : finType) (W : `Ch*(A, B)).
Variable minRate : R.
Hypothesis minRate_cap : minRate > capacity W.
Hypothesis set_of_I_has_ubound :
  classical_sets.has_ubound (fun y => exists P, `I(P, W) = y).

Variable epsilon : R. (* TODO: use posnum *)
Hypothesis eps_gt0 : 0 < epsilon.

Theorem channel_coding_converse : exists n0,
  forall n M (c : code A B M n),
    (0 < #|M|)%nat -> n0 < n%:R -> minRate <= CodeRate c -> scha(W, c) < epsilon.
Proof.
case: (channel_coding_converse_gen minRate_cap set_of_I_has_ubound) => Delta [Delta_pos HDelta].
pose K := (#|A| + #|A| * #|B|)%nat.
pose n0 := 2 ^ K * K.+1`!%:R / ((Delta * ln 2) ^ K.+1) / epsilon.
exists n0 => n M c HM n0_n HminRate.
have Rlt0n : 0 < n%:R.
  apply: (ltR_trans _ n0_n).
  rewrite /n0.
  apply mulR_gt0; last exact/invR_gt0.
  rewrite /Rdiv -mulRA.
  apply mulR_gt0; first exact/expR_gt0/Rlt_0_2.
  apply mulR_gt0;
    [exact/ltR0n/fact_gt0 | exact/invR_gt0/expR_gt0/mulR_gt0].
destruct n as [|n'].
  by apply ltRR in Rlt0n.
set n := n'.+1.
apply: (@leR_ltR_trans (n.+1%:R ^ K * exp2 (- n%:R * Delta))).
  exact: HDelta.
move: (n0_n) => /(@ltR_pmul2l (/ n%:R) _) => /(_ (invR_gt0 n%:R Rlt0n)).
rewrite mulVR ?INR_eq0' //.
move/(@ltR_pmul2l epsilon) => /(_ eps_gt0); rewrite mulR1 => H1'.
apply: (leR_ltR_trans _ H1') => {H1'}.
rewrite /n0 [in X in _ <= X]mulRC -2![in X in _ <= X]mulRA.
rewrite mulVR ?mulR1 ?gtR_eqF //.
apply Rge_le; rewrite mulRC -2!mulRA; apply Rle_ge.
set aux := _%:R * (_ * _).
have aux_gt0 : 0 < aux.
  apply mulR_gt0; first exact/ltR0n/fact_gt0.
  apply mulR_gt0; [exact/invR_gt0/expR_gt0/mulR_gt0 | exact/invR_gt0].
apply (@leR_trans ((n.+1%:R / n%:R) ^ K * aux)); last first.
  apply leR_pmul => //.
  - apply/expR_ge0/divR_ge0 => //; exact: leR0n.
  - exact: ltRW.
  - apply pow_incr; split.
    + apply divR_ge0 => //; exact: leR0n.
    + apply (@leR_pmul2r n%:R) => //.
      rewrite -mulRA mulVR // ?mulR1 ?INR_eq0' ?gtn_eqF // (_ : 2 = 2%:R) //.
      rewrite -natRM; apply/le_INR/leP; by rewrite -{1}(mul1n n) ltn_pmul2r.
  - exact/leRR.
rewrite expRM -mulRA; apply leR_pmul => //.
- exact/expR_ge0/ltRW/ltR0n.
- exact/leRR.
- apply invR_le => //.
  + apply mulR_gt0; last exact aux_gt0.
    rewrite expRV ?INR_eq0' //; exact/invR_gt0/expR_gt0.
  + rewrite -exp2_Ropp mulNR oppRK /exp2.
    have nDeltaln2 : 0 <= n%:R * Delta * ln 2.
      apply mulR_ge0; last exact/ltRW.
      apply mulR_ge0; [exact/leR0n | exact/ltRW].
    apply: (leR_trans _ (exp_lb (K.+1) nDeltaln2)) => {nDeltaln2}.
    apply Req_le.
    rewrite invRM; last 2 first.
      exact/gtR_eqF/expR_gt0/invR_gt0.
      exact/gtR_eqF.
    rewrite -/(Rdiv _ _) divRM; last 2 first.
      by rewrite INR_eq0' gtn_eqF // fact_gt0.
      rewrite gtR_eqF //; apply/mulR_gt0; last exact/invR_gt0.
      exact/invR_gt0/expR_gt0/mulR_gt0.
    rewrite -mulRA mulRC invRM; last 2 first.
    - by apply/eqP/invR_neq0/eqP; rewrite expR_eq0 mulR_neq0' ln2_neq0 andbT; exact/gtR_eqF.
    - by apply/eqP/invR_neq0/eqP; by rewrite INR_eq0'.
    - rewrite invRK; last first.
        by rewrite expR_eq0 mulR_neq0' ln2_neq0 andbT; exact/gtR_eqF.
      rewrite invRK; last by rewrite INR_eq0'.
      rewrite (_ : / (/ n%:R) ^ K = n%:R ^ K); last first.
        rewrite expRV ?INR_eq0' // invRK //; apply/expR_neq0; by rewrite INR_eq0'.
      rewrite -mulRA {1}/Rdiv (mulRA n%:R) -expRS mulRA -expRM.
      by rewrite -/(Rdiv _ _) mulRCA -mulRA (mulRC (ln 2)).
Qed.

End channel_coding_converse.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.LetIn.
Local Open Scope Z_scope.

Module Z.
  Definition pow2_mod n i := (n &' (Z.ones i)).

  Definition zselect (cond zero_case nonzero_case : Z) :=
    if cond =? 0 then zero_case else nonzero_case.

  Definition add_modulo x y modulus :=
    if (modulus <=? x + y) then (x + y) - modulus else (x + y).

  (** Logical negation, modulo a number *)
  Definition lnot_modulo (v : Z) (modulus : Z) : Z
    := Z.lnot v mod modulus.

  (** Boolean negation *)
  Definition bneg (v : Z) : Z
    := if dec (v = 0) then 1 else 0.

  (* most significant bit *)
  Definition cc_m s x := if dec (2 ^ (Z.log2 s) = s) then x >> (Z.log2 s - 1) else x / (s / 2).

  (* least significant bit *)
  Definition cc_l x := x mod 2.

  (* two-register right shift *)
  Definition rshi s hi lo n :=
       let k := Z.log2 s in
       if dec (2 ^ k = s)
       then ((lo + (hi << k)) >> n) &' (Z.ones k)
       else ((lo + hi * s) >> n) mod s.

  (** left-shift that truncates *)
  Definition truncating_shiftl bw x n := (x << n) mod (2^bw).

  Definition get_carry (bitwidth : Z) (v : Z) : Z * Z
    := (v mod 2^bitwidth, v / 2^bitwidth).
  Definition add_with_carry (c : Z) (x y : Z) : Z
    := c + x + y.
  Definition add_with_get_carry (bitwidth : Z) (c : Z) (x y : Z) : Z * Z
    := dlet v := add_with_carry c x y in get_carry bitwidth v.
  Definition add_get_carry (bitwidth : Z) (x y : Z) : Z * Z
    := add_with_get_carry bitwidth 0 x y.

  Definition get_borrow (bitwidth : Z) (v : Z) : Z * Z
    := let '(v, c) := get_carry bitwidth v in
       (v, -c).
  Definition sub_with_borrow (c : Z) (x y : Z) : Z
    := add_with_carry (-c) x (-y).
  Definition sub_with_get_borrow (bitwidth : Z) (c : Z) (x y : Z) : Z * Z
    := dlet v := sub_with_borrow c x y in get_borrow bitwidth v.
  Definition sub_get_borrow (bitwidth : Z) (x y : Z) : Z * Z
    := sub_with_get_borrow bitwidth 0 x y.

  (* splits at [bound], not [2^bitwidth]; wrapper to make add_getcarry
  work if input is not known to be a power of 2 *)
  Definition add_get_carry_full (bound : Z) (x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then add_get_carry (Z.log2 bound) x y
       else ((x + y) mod bound, (x + y) / bound).
  Definition add_with_get_carry_full (bound : Z) (c x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then add_with_get_carry (Z.log2 bound) c x y
       else ((c + x + y) mod bound, (c + x + y) / bound).
  Definition sub_get_borrow_full (bound : Z) (x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then sub_get_borrow (Z.log2 bound) x y
       else ((x - y) mod bound, -((x - y) / bound)).
  Definition sub_with_get_borrow_full (bound : Z) (c x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then sub_with_get_borrow (Z.log2 bound) c x y
       else ((x - y - c) mod bound, -((x - y - c) / bound)).

  Definition add_split (s x y : Z) : Z * Z
    := dlet sum := Z.add x y in (sum mod s, sum / s).

  Definition mul_split_at_bitwidth (bitwidth : Z) (x y : Z) : Z * Z
    := dlet xy := x * y in
       (if Z.geb bitwidth 0
        then xy &' Z.ones bitwidth
        else xy mod 2^bitwidth,
        if Z.geb bitwidth 0
        then xy >> bitwidth
        else xy / 2^bitwidth).
  Definition mul_split (s x y : Z) : Z * Z
    := if s =? 2^Z.log2 s
       then mul_split_at_bitwidth (Z.log2 s) x y
       else ((x * y) mod s, (x * y) / s).

  Definition mul_high (s x y : Z) : Z
    := snd (mul_split s x y).

  (** returns [1] iff [x < y] *)
  Definition ltz (x y : Z) : Z
    := if x <? y then 1 else 0.

  Definition combine_at_bitwidth (bitwidth lo hi : Z) : Z
    := lo + (hi << bitwidth).

  (** if positive, round up to 2^k-1 (0b11111....); if negative, round down to -2^k (0b...111000000...) *)
  Definition round_lor_land_bound (x : Z) : Z
    := if (0 <=? x)%Z
       then 2^(Z.log2_up (x+1))-1
       else -2^(Z.log2_up (-x)).

  Fixpoint log10_fuel (fuel : nat) (v : Z) :=
    match fuel with
    | O => 0
    | S fuel
      => if v >? 1
         then 1 + log10_fuel fuel (v / 10)
         else 0
    end.
  Definition log10 (v : Z) : Z := log10_fuel (Z.to_nat (Z.log2 v)) v.

  (** Special identity function for constant-time cmov *)
  Definition value_barrier (x : Z) := x.

  (* arithmetic right shift *)
  Definition arithmetic_shiftr1 (m a : Z) :=
    (a &' 2^(m - 1)) |' (a >> 1).

  Definition sign_bit m a := a >> (m - 1).

  Definition ones_from m k := (Z.ones k) << (m - k).
  Definition ones_at m k := (Z.ones k) << m.

  Definition sign_extend old_m new_m a :=
    dlet q := Z.zselect (sign_bit old_m a) 0 (ones_at old_m (new_m - old_m)) in
          q |' a.

  Definition arithmetic_shiftr m a k :=
    dlet q := Z.zselect (sign_bit m a) 0 (ones_from m k) in
          q |' (a >> k).

  (** Note that the following definition may be inconvenient to reason about,
      and [(a + 2^(m-1)) mod 2^m - 2^(m-1)] may prove simpler to reason about arithmetically.
      See also https://github.com/mit-plv/coqutil/blob/c8006ceca816076b117c31d7feaefb5bbb850754/src/coqutil/Word/Naive.v#L15
      and https://github.com/mit-plv/coqutil/blob/c8006ceca816076b117c31d7feaefb5bbb850754/src/coqutil/Word/Properties.v#L190 *)

  Definition twos_complement m a :=
    (if ((a mod 2 ^ m) <? 2 ^ (m - 1)) then a mod 2 ^ m else a mod 2 ^ m - 2 ^ m).

  (* Negation in twos complement *)
  Definition twos_complement_opp m a :=
    ((Z.lnot_modulo a (2 ^ m)) + 1) mod (2 ^ m).

  (* Check if a number considered in twos complement of bitwidth m is negative *)
  Definition twos_complement_neg m a := a >> (m - 1).

  (* note the corner case condition: when f is exactly 2 to the mw-1'th power, then -f = f and
   so checking that -f is negative does not work in that case.
   This is not really an issue, since it just requires that our integers are small (which they are)
   Long term, we would like to add comparison operators to the supported C language *)
  Definition twos_complement_pos m a :=
    dlet b := twos_complement_opp m a in sign_bit m b.

  Definition twos_complement_mul ma mb a b :=
    (sign_extend ma (ma + mb) a) * (sign_extend mb (ma + mb) b).
End Z.