(* Copyright (c) 2008-2012, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import List.

Require Import Cpdt.CpdtTactics Cpdt.MoreSpecif.

Set Implicit Arguments.
Set Asymmetric Patterns.
(* end hide *)

(*
(** %\chapter{Proof by Reflection}% *)
 *)
(** %\chapter{リフレクションによる証明}% *)

(**
(* The last chapter highlighted a very heuristic approach to proving.  In this chapter, we will study an alternative technique,%\index{proof by reflection}% _proof by reflection_ %\cite{reflection}%.  We will write, in Gallina, decision procedures with proofs of correctness, and we will appeal to these procedures in writing very short proofs.  Such a proof is checked by running the decision procedure.  The term _reflection_ applies because we will need to translate Gallina propositions into values of inductive types representing syntax, so that Gallina programs may analyze them, and translating such a term back to the original form is called _reflecting_ it. *)

最後の章では、証明に対する非常にヒューリスティックなアプローチが強調されていました。
この章では、代替の技術、
%\index{proof by reflection}%_proof by reflection_ ＿リフレクションによる証明＿
%\cite{reflection}% を検討します。
Gallinaによって、決定手続き(decision procedures、決定するための手続き)
を正しさの証明とともに書いて、
これらの手続きが非常に短い証明で書けることを示します(appeal)。
項の _reflection_ ＿リフレクション＿ は、
Gallinaの命題を構文が表す帰納型の値に変換する必要があるために、適用されます。
それで、Gallinaプログラムがそれらを解析し、
そのような項を元の形式に戻すことを ＿リフレクトする＿ (_reflecting_ it) と呼びます。
 *)

(*
(** * Proving Evenness *)
 *)
(** * 偶数であることの証明 *)

(**
(* Proving that particular natural number constants are even is certainly something we would rather have happen automatically.  The Ltac-programming techniques that we learned in the last chapter make it easy to implement such a procedure. *)

特定の自然数の定数が偶数であることを証明することは、確かに自動的にできることです。
前章で学習したLtacプログラミング手法は、このような手順を簡単に実装できます。
 *)

Inductive isEven : nat -> Prop :=
| Even_O : isEven O
| Even_SS : forall n, isEven n -> isEven (S (S n)).

(* begin thide *)
Ltac prove_even := repeat constructor.
(* end thide *)

Theorem even_256 : isEven 256.
  prove_even.
Qed.

Print even_256.
(** %\vspace{-.15in}% [[
even_256 =
Even_SS
  (Even_SS
     (Even_SS
        (Even_SS
    ]]

(*
    %\noindent%...and so on.  This procedure always works (at least on machines with infinite resources), but it has a serious drawback, which we see when we print the proof it generates that 256 is even.  The final proof term has length super-linear in the input value.  Coq's implicit arguments mechanism is hiding the values given for parameter [n] of [Even_SS], which is why the proof term only appears linear here.  Also, proof terms are represented internally as syntax trees, with opportunity for sharing of node representations, but in this chapter we will measure proof term size as simple textual length or as the number of nodes in the term's syntax tree, two measures that are approximately equivalent.  Sometimes apparently large proof terms have enough internal sharing that they take up less memory than we expect, but one avoids having to reason about such sharing by ensuring that the size of a sharing-free version of a term is low enough.
*)

    %\noindent%
...等々。
この手順は常に（少なくとも無限のリソースを持つマシンでは）機能しますが、
重大な欠点があります。これは、256が偶数であるという証明を印刷(print)するときに表示されます。
最終的な証明項は、入力値に対して長さが超線形(super-linear)です。
Coqの暗黙的な引数の仕組みは、[Even_SS]のパラメータ[n]に与えられた値を隠しているので、
ここでは証明項はここでは線形にしか見えません。
(* suhara:
以下を実行すると納得できる：
Unset Printing Notations.
Set Printing Implicit.
Print even_256.
Set Printing Notations.
Unset Printing Implicit.
*)
また、証明項は内部的に構文木として表現され、ノード表現を共有する機会がありますが、
この章では、ほぼ同等の2つの尺度、証明文の長さを簡単なテキストの長さとして、
または、用語の構文木のノード数として測定します。
時には明らかに大きな証明項でも、内部では十分な共有を持っているため、
予想以上のメモリを消費することはありませんが、
共有のない(sharing-free)バージョンのサイズが十分に小さいことを保証することによって、
そのような共有を推論する必要はありません。

(*
    Superlinear evenness proof terms seem like a shame, since we could write a trivial and trustworthy program to verify evenness of constants.  The proof checker could simply call our program where needed.
*)

定数の偶数性を検証するための自明で信頼できるプログラムを書くことができるので、
超線形(Superlinear)な偶数性の証明項は残念なものに見えます。
証明チェッカーは、必要に応じて私たちのプログラムを単に呼び出すことができます。

(*
    It is also unfortunate not to have static typing guarantees that our tactic always behaves appropriately.  Other invocations of similar tactics might fail with dynamic type errors, and we would not know about the bugs behind these errors until we happened to attempt to prove complex enough goals.
*)

静的な型付けが、私たちのタクティクが常に適切に動作することを保証しないことも残念です。
同様の手法の他の呼び出しは、動的な型エラーで失敗する可能性があり、
十分に複雑なゴールを証明しようとするまで、
これらのエラーの背後にあるバグについてはわかりません。

(*
    The techniques of proof by reflection address both complaints.  We will be able to write proofs like in the example above with constant size overhead beyond the size of the input, and we will do it with verified decision procedures written in Gallina.
*)

リフレクションによる証明の手法は、両方の不満に対処します。
入力のサイズを超えて一定のサイズ(constant size)のオーバーヘッドを
持つ上記の例のような証明を書くことができ、
私たちはGallinaで書かれた検証された決定手続き(decision procedures)でそれを行います。

(*
    For this example, we begin by using a type from the [MoreSpecif] module (included in the book source) to write a certified evenness checker. *)

この例では、[MoreSpecif] モジュール（この本のソースに含まれています）の型を使用して、
認証された偶数性のチェッカーを作成します。
 *)

(* begin hide *)
(* begin thide *)
Definition paartial := partial.
(* end thide *)
(* end hide *)

(* suhara: src/MoreSpecif.v の partial 型 *)
Print partial.

(** %\vspace{-.15in}% [[
Inductive partial (P : Prop) : Set :=  Proved : P -> [P] | Uncertain : [P]
    ]]

(*
    A [partial P] value is an optional proof of [P]. The notation [[P]] stands for [partial P]. *)

[partial P] の値は、[P]のオプショナルな証明です。 表記[[P]]は[partial P]の略です。
 *)

(* suhara: 「オプション型」「オプショナルな型」に対応する「オプショナルな証明」
命題 [P]に対して、[t : P] であるとき、
それを [[]] で囲んだ、[[P]] には要素 [Proved t] と、[Uncertain P] がある。
なお、[Proved t] は [@Proved P t] の略である。

Check [True].
Check Proved I : [True].
Check @Proved True I : [True].
Check Uncertain True : [True].

Check [False].
Check @Proved False _.                      (* 存在しない値 *)
Check Uncertain False : [False].

Compute Proved Even_O : [isEven 0].             (* Yes *)
Compute @Proved (isEven 0) Even_O : [isEven 0]. (* Yes *)
Compute Uncertain (isEven 1) : [isEven 1].      (* No *)
*)

Local Open Scope partial_scope.

(**
(* We bring into scope some notations for the [partial] type.  These overlap with some of the notations we have seen previously for specification types, so they were placed in a separate scope that needs separate opening. *)

私たちは[partial]型の表記をいくつか取り上げます。
これらは、以前に、型の記述(specification types)で見た表記法の
いくつかと重複しているため、別々に開くことが必要な別のスコープに配置されました。

(* suhara: 「specification types」 は、Subset.v で初出する。 *)
 *)

(* begin thide *)
Definition check_even : forall n : nat, [isEven n].
  Hint Constructors isEven.

  refine (fix F (n : nat) : [isEven n] :=
    match n with
      | 0 => Yes
      | 1 => No
      | S (S n') => Reduce (F n')
    end); auto.
Defined.

(**
(* The function [check_even] may be viewed as a _verified decision procedure_, because its type guarantees that it never returns %\coqdocnotation{%#<tt>#Yes#</tt>#%}% for inputs that are not even.

関数[check_even]は、その型が偶数でない入力に対して
%\coqdocnotation{%#<tt>#Yes#</tt>#%}%
を返さないことを保証するので、
_verified decision procedure_ ＿検証された決定手続き＿
とみなすことができるでしょう。

 (* suhara: Reduce は、src/MoreSpecif.v で Notation として定義される。
Notation "'Reduce' x" := if x then Yes else No. *)
*)

(*
   Now we can use dependent pattern-matching to write a function that performs a surprising feat.  When given a [partial P], this function [partialOut] returns a proof of [P] if the [partial] value contains a proof, and it returns a (useless) proof of [True] otherwise.  From the standpoint of ML and Haskell programming, it seems impossible to write such a type, but it is trivial with a [return] annotation. *)

これで、依存パターンマッチング(dependent pattern-matching)を使用して、
驚くべきことを行う関数を書くことができます。
[partialPut]が与えられている場合、[partialOut]は[partial]値に証明が含まれていれば[P]の証明を返し、
それ以外の場合は [True] の（使用しないuseless)の証明を返します。
MLとHaskellのプログラミングの観点からは、このような型を
書くことは不可能ですが、[return]アノテーションを使用すれば自明です。
 *)

Definition partialOut (P : Prop) (x : [P]) :=
  match x return (match x with
                    | Proved _ => P
                    | Uncertain => True
                  end) with
    | Proved pf => pf
    | Uncertain => I
  end.

(* suhara:
Compute partialOut (@Proved True I).        (* I : True、 P=True 本来の証明 *)
Compute partialOut (Uncertain False).       (* I : True、 partialOut の機能 *)

Compute partialOut (@Proved (isEven 0) Even_O). (* Even_0 *)
Compute partialOut (Uncertain (isEven 1)).      (* I *)
 *)

(**
(* It may seem strange to define a function like this.  However, it turns out to be very useful in writing a reflective version of our earlier [prove_even] tactic: *)

このような関数を定義するのは奇妙に思えるかもしれませんが、
以前の[prove_even]タクティクのリフレクティブのバージョンを書くのに非常に便利です：*）
*)

Ltac prove_even_reflective :=
  match goal with
    | [ |- isEven ?N] => exact (partialOut (check_even N))
  end.
(* end thide *)

(**
(* We identify which natural number we are considering, and we "prove" its evenness by pulling the proof out of the appropriate [check_even] call.  Recall that the %\index{tactics!exact}%[exact] tactic proves a proposition [P] when given a proof term of precisely type [P]. *)

どの自然数を考えているのかを決め、適切な[check_even]の呼び出しから証明を引き出すことによって、
その偶数性を「証明」します。
正確に型 [P] の証明項が与えられたとき、
%\index{tactics!exact}%[exact] タクティクは、
命題 [P] を証明します。
 *)

Theorem even_256' : isEven 256.
  prove_even_reflective.
Qed.

Print even_256'.
(** %\vspace{-.15in}% [[
even_256' = partialOut (check_even 256)
     : isEven 256
    ]]

(*
    We can see a constant wrapper around the object of the proof.  For any even number, this form of proof will suffice.  The size of the proof term is now linear in the number being checked, containing two repetitions of the unary form of that number, one of which is hidden above within the implicit argument to [partialOut].
*)

私たちは、証明のゴールの周りに一定のラッパーを見ることができます。
偶数の場合は、この形式の証明で十分です。
証明項のサイズは、チェックされている数では線形で、

(* suhara: 実際には check_even の refine の末尾再帰だけ *)

その数の単項式の2つの繰り返しが含まれています。
そのうちのひとつは[partialOut]の暗黙の引数の上に隠されています。

(* suhara:
Set Printing Implicit.
Print even_256'.
even_256' = @partialOut (isEven 256) (check_even 256)
 *)

(*
    What happens if we try the tactic with an odd number? *)

奇数でこのタクティクを試してみたらどうなりますか？
*)

Theorem even_255 : isEven 255.
  (** %\vspace{-.275in}%[[
  prove_even_reflective.
]]

<<
User error: No matching clauses for match goal
>>

(*
  Thankfully, the tactic fails.  To see more precisely what goes wrong, we can run manually the body of the [match].
*)
ありがたいことに、タクティクは失敗します。
間違ったことをより正確に見るために、[match]の本体を手動で実行することができます。

  %\vspace{-.15in}%[[
  exact (partialOut (check_even 255)).
]]

<<
  Error: The term "partialOut (check_even 255)" has type
 "match check_even 255 with
  | Yes => isEven 255
  | No => True
  end" while it is expected to have type "isEven 255"
>>

(*
  As usual, the type checker performs no reductions to simplify error messages.  If we reduced the first term ourselves, we would see that [check_even 255] reduces to a %\coqdocnotation{%#<tt>#No#</tt>#%}%, so that the first term is equivalent to [True], which certainly does not unify with [isEven 255]. *)

いつものように、型チェッカーはエラーメッセージを単純化するために
リダクション(式の簡約)を実行しません。
最初の項を自分自身で簡約した場合、[check_even 255]は
%\coqdocnotation{%#<tt>#No#</tt>#%}%に簡約され、
最初の項
(* suhara: の partialOut の結果は I でその型 *)
は[True]と等しく、
(* suhara: exact の引数は I となり、Iの型[True]は、 *)
[isEven 255]とユニファイしないのは確かです。

(* suhara: 補足説明

(1) partialOut (check_even 255)) を手動で評価する。
@partialOut (isEven 255) (check_even 255) なので、

(1.1) partialOut の return のなかのmatchは、

match check_even 255 with
| Yes => isEven 255
| No => True
end

となる。check_even 255 は No なので、return のmatchは True になる。

(1.2) partialOut の本文のmatch
match (x) with
| Proved pf => pf
| Uncertain => I
end
で、x は [isEven 255] の値なので、Uncertain である。本体のmatchは I になる。

(1.1)と(1.2)から、partialOut (check_even 255) は I : True を返す。

(2) 最初の証明にもどって、

exact partialOut (check_even 255)) は exact I になる。

Theorem even_255 : isEven 255.
exact I.

I の型 isEven 255 ではないので、
exact I は、定理の証明になっておらず、エラーである。
   *)
*)

Abort.

(**
(* Our tactic [prove_even_reflective] is reflective because it performs a proof search process (a trivial one, in this case) wholly within Gallina, where the only use of Ltac is to translate a goal into an appropriate use of [check_even]. *)

タクティク[prove_even_reflective]は、リフレクティブです。
なぜなら、Gallina内の証明検索のプロセス（この場合は自明なもの）を実行するために、
Ltacの唯一の使用は目標を[check_even]の適切な使用に変換するためです。
*)

(*
(** * Reifying the Syntax of a Trivial Tautology Language *)
 *)
(** * 自明なトートロジーの言語の文法の具象化(reifying) *)
(* suhara: 具象化 https://ja.wikipedia.org/wiki/%E7%89%A9%E8%B1%A1%E5%8C%96 *)

(**
(* We might also like to have reflective proofs of trivial tautologies like this one: *)

このような自明なトートロジーのリフレクティブな証明をしたいかもしれません：
*)

Theorem true_galore : (True /\ True) -> (True \/ (True /\ (True -> True))).
  (* suhara: crush でも証明できる。結果は同じである。 *)
  tauto.
Qed.

(* begin hide *)
(* begin thide *)
Definition tg := (and_ind, or_introl).
(* end thide *)
(* end hide *)

Print true_galore.
(** %\vspace{-.15in}% [[
true_galore =
fun H : True /\ True =>
and_ind (fun _ _ : True => or_introl (True /\ (True -> True)) I) H
     : True /\ True -> True \/ True /\ (True -> True)
    ]]

(*
    As we might expect, the proof that [tauto] builds contains explicit applications of natural deduction rules.  For large formulas, this can add a linear amount of proof size overhead, beyond the size of the input.
*)

予想されるように、[tauto] が作る証拠は、
自然演繹規則の明示的な応用が含まれています。
大きな式の場合、これは、入力のサイズを超える、
証明のサイズの線形量のオーバーヘッドを追加する可能性があります。

(*
   To write a reflective procedure for this class of goals, we will need to get into the actual "reflection" part of "proof by reflection."  It is impossible to case-analyze a [Prop] in any way in Gallina.  We must%\index{reification}% _reify_ [Prop] into some type that we _can_ analyze.  This inductive type is a good candidate: *)

このクラスのゴールに対してリフレクティブな手順を書くには、
「リフレクティブによる証明」の実際の「リフレクティブ」な部分に入る必要があります。
Gallinaのいかなるところでも、[Prop] を条件分析(case-analyze)することは不可能です。
[Prop] を %\index{reification}% _reify_ ＿具象化＿ して、解析できる型にする必要があります。
この帰納型は良い候補です：
 *)

(* begin thide *)
Inductive taut : Set :=
| TautTrue : taut
| TautAnd : taut -> taut -> taut
| TautOr : taut -> taut -> taut
| TautImp : taut -> taut -> taut.

(**
(* We write a recursive function to _reflect_ this syntax back to [Prop].  Such functions are also called%\index{interpretation function}% _interpretation functions_, and we have used them in previous examples to give semantics to small programming languages. *)

この構文を _reflect_ ＿リフレクト＿ して [Prop]に戻すための再帰関数を書きます。
このような関数は
%\index{interpretation function}% _interpretation functions_ ＿翻訳関数＿
とも呼ばれ、前の例で、小さなプログラミング言語に意味論を与えるために使用しています。
(* suhara: あとで denotation function とも呼ばれる。 *)
 *)

Fixpoint tautDenote (t : taut) : Prop :=
  match t with
    | TautTrue => True
    | TautAnd t1 t2 => tautDenote t1 /\ tautDenote t2
    | TautOr t1 t2 => tautDenote t1 \/ tautDenote t2
    | TautImp t1 t2 => tautDenote t1 -> tautDenote t2
  end.

(**
(* It is easy to prove that every formula in the range of [tautDenote] is true. *)

[tautDenote]の範囲のすべての式が真であることを証明するのは簡単です。
*)

Theorem tautTrue : forall t, tautDenote t.
  induction t; crush.
Qed.

(**
(* To use [tautTrue] to prove particular formulas, we need to implement the syntax reification process.  A recursive Ltac function does the job. *)

特定の式を証明するために[tautTrue]を使用するには、
その構文を具象化する手順(reification process)を実装する必要があります。
再帰的なLtac関数がその仕事をします。
 *)

Ltac tautReify P :=
  match P with
    | True => TautTrue
    | ?P1 /\ ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautAnd t1 t2)
    | ?P1 \/ ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautOr t1 t2)
    | ?P1 -> ?P2 =>
      let t1 := tautReify P1 in
      let t2 := tautReify P2 in
        constr:(TautImp t1 t2)
  end.

(**
(* With [tautReify] available, it is easy to finish our reflective tactic.  We look at the goal formula, reify it, and apply [tautTrue] to the reified formula. *)

[tautReify]が利用可能なので、
リフレクティブなタクティクを終わらせるのは簡単です。
ゴールの式を見て、それを具象化(reify)し、その具象化した式に[tautTrue]を適用します。
 *)

Ltac obvious :=
  match goal with
    | [ |- ?P ] =>
      let t := tautReify P in
        exact (tautTrue t)
  end.

(**
(* We can verify that [obvious] solves our original example, with a proof term that does not mention details of the proof. *)

証明項の詳細は言及せずに、
[obvious] がもとの例を解くことを証明することができます。
*)
(* end thide *)

Theorem true_galore' : (True /\ True) -> (True \/ (True /\ (True -> True))).
(* suhara:
  intros.
  let p := tautReify (True \/ True /\ (True -> True)) in pose p as t.
  Check tautTrue t : tautDenote t.
  exact (tautTrue t).
  Restart.
*)
  obvious.
Qed.

Print true_galore'.
(** %\vspace{-.15in}% [[
true_galore' =
tautTrue
  (TautImp (TautAnd TautTrue TautTrue)
     (TautOr TautTrue (TautAnd TautTrue (TautImp TautTrue TautTrue))))
     : True /\ True -> True \/ True /\ (True -> True)
    ]]

(*
    It is worth considering how the reflective tactic improves on a pure-Ltac implementation.  The formula reification process is just as ad-hoc as before, so we gain little there.  In general, proofs will be more complicated than formula translation, and the "generic proof rule" that we apply here _is_ on much better formal footing than a recursive Ltac function.  The dependent type of the proof guarantees that it "works" on any input formula.  This benefit is in addition to the proof-size improvement that we have already seen.
*)

純粋なLtacによる実装で、リフレクティブなタクティクがどのように改善するかを考える価値があります。
式の具象化の手順は以前と同じようにアドホックなので、
そこではほとんど利益を得ることはできません。
一般に、証明は数式の変換よりも複雑になります。
ここで適用する「一般的な証明の規則 (generic proof rule)」は、
再帰的なLtac関数よりもはるかに優れた正式な基礎に当てはまります。
依存型の証明は、どの入力式でも「機能する」ことを保証します。
この利点は、すでに見てきた、証明のサイズの改善に加えられます。

(*
    It may also be worth pointing out that our previous example of evenness testing used a function [partialOut] for sound handling of input goals that the verified decision procedure fails to prove.  Here, we prove that our procedure [tautTrue] (recall that an inductive proof may be viewed as a recursive procedure) is able to prove any goal representable in [taut], so no extra step is necessary. *)

以前の例の偶数性のテストでは、
検証された決定手続きが証明できない入力ゴールを
健全に処理する(sound handling)ために関数[partialOut]を使用していたことを指摘する価値があります。
ここで、手続き [tautTrue]
（帰納的証明は再帰的手続きと見なすことができることを思い出してください）
は、[taut]で表現できるどんなゴールをも証明できるので、余分なステップは必要ありません。

 *)
(*
(** * A Monoid Expression Simplifier *)
 *)
(** * モノイド式の簡略化 *)

(**
(* Proof by reflection does not require encoding of all of the syntax in a goal.  We can insert "variables" in our syntax types to allow injection of arbitrary pieces, even if we cannot apply specialized reasoning to them.  In this section, we explore that possibility by writing a tactic for normalizing monoid equations. *)

リフレクションによる証明では、ゴールの中のすべての構文をエンコードする必要はありません。
特殊な推論を適用できない場合でも、任意の断片が注入(injection)を許すために、
構文の型に「変数」を挿入することができます。
その可能性を、モノイドの等式(monoid equations)を正規化するための
タクティクを書くことによって探求します。
 *)

Section monoid.
  Variable A : Set.
  Variable e : A.
  Variable f : A -> A -> A.

  Infix "+" := f.

  Hypothesis assoc : forall a b c, (a + b) + c = a + (b + c).
  Hypothesis identl : forall a, e + a = a.
  Hypothesis identr : forall a, a + e = a.

  (**
(* We add variables and hypotheses characterizing an arbitrary instance of the algebraic structure of monoids.  We have an associative binary operator and an identity element for it.
*)

モノイドの代数構造の任意のインスタンスを特徴付ける変数と仮説を追加します。
結合法則を満たす(associative)2項演算子とそれに対する単位元があります。

(*
     It is easy to define an expression tree type for monoid expressions.  A [Var] constructor is a "catch-all" case for subexpressions that we cannot model.  These subexpressions could be actual Gallina variables, or they could just use functions that our tactic is unable to understand. *)

モノイドの式についての木の型の式を定義するのは簡単です。
[Var]コンストラクタは、私たちがモデル化できない部分式の「キャッチ・オール」ケースです。
これらの部分式は、実際のGallina変数であるべきで、また、
私たちのタクティクが理解できない関数を使うことができます。
   *)

(* begin thide *)
  Inductive mexp : Set :=
  | Ident : mexp
  | Var : A -> mexp
  | Op : mexp -> mexp -> mexp.

  (**
(* Next, we write an interpretation function. *)

次に、翻訳関数(interpretation function)を書きます。
   *)

  Fixpoint mdenote (me : mexp) : A :=
    match me with
      | Ident => e
      | Var v => v
      | Op me1 me2 => mdenote me1 + mdenote me2
    end.

  (**
(* We will normalize expressions by flattening them into lists, via associativity, so it is helpful to have a denotation function for lists of monoid values. *)

結合法則を使って(via associativity)式をリストにフラット化(flattening)することで式を
正規化するので、モノイドの値のリストのための表示関数(denotation function)があると便利です。
   *)

  Fixpoint mldenote (ls : list A) : A :=
    match ls with
      | nil => e
      | x :: ls' => x + mldenote ls'
    end.

  (**
(* The flattening function itself is easy to implement. *)

フラット化関数は、それ自体、実装するのに簡単です。
*)

  Fixpoint flatten (me : mexp) : list A :=
    match me with
      | Ident => nil
      | Var x => x :: nil
      | Op me1 me2 => flatten me1 ++ flatten me2
    end.

  (**
  (* This function has a straightforward correctness proof in terms of our [denote] functions. *)
この関数は、私たちの [表示(denote)] 関数に関して簡単な正当性証明を持っています。
*)

  Lemma flatten_correct' : forall ml2 ml1,
    mldenote ml1 + mldenote ml2 = mldenote (ml1 ++ ml2).
    induction ml1; crush.
  Qed.

  Theorem flatten_correct : forall me, mdenote me = mldenote (flatten me).
    Hint Resolve flatten_correct'.

    induction me; crush.
  Qed.

  (**
  (* Now it is easy to prove a theorem that will be the main tool behind our simplification tactic. *)

簡約化タクティクの主な道具となる定理を証明するのは簡単です。
*)

  Theorem monoid_reflect : forall me1 me2,
    mldenote (flatten me1) = mldenote (flatten me2)
    -> mdenote me1 = mdenote me2.
    intros; repeat rewrite flatten_correct; assumption.
  Qed.

  (**
  (* We implement reification into the [mexp] type. *)

[mexp] 型への具象化を実装します。
   *)

  Ltac reify me :=
    match me with
      | e => Ident
      | ?me1 + ?me2 =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          constr:(Op r1 r2)
      | _ => constr:(Var me)
    end.

  (**
(* The final [monoid] tactic works on goals that equate two monoid terms.  We reify each and change the goal to refer to the reified versions, finishing off by applying [monoid_reflect] and simplifying uses of [mldenote].  Recall that the %\index{tactics!change}%[change] tactic replaces a conclusion formula with another that is definitionally equal to it. *)

最終的な[monoid]タクティクは、モノイドの項のふたつからなる等式のゴールに作用します。
それぞれを具象化(reify)し、[monoid_reflect]を適用し、[mldenote]使って簡単化することで、
ゴールが具現化したバージョンを参照するように変更します。
%\index {tactics!change}%[change] タクティクは、
結論の式を定義として等しいものに置き換えることを思い出してください。
   *)

  Ltac monoid :=
    match goal with
      | [ |- ?me1 = ?me2 ] =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          change (mdenote r1 = mdenote r2);
            apply monoid_reflect; simpl
    end.

  (**
(* We can make short work of theorems like this one: *)

このような定理の短い作業をすることができます：
*)

(* end thide *)

  Theorem t1 : forall a b c d, a + b + c + d = a + (b + c) + d.
    intros; monoid.
    (** [[
  ============================
   a + (b + (c + (d + e))) = a + (b + (c + (d + e)))

        ]]

(*
        Our tactic has canonicalized both sides of the equality, such that we can finish the proof by reflexivity. *)

monoidタクティクは、等式の両辺を正準化(canonicalized)しているので、
反射性(reflexivity)によって証明を完成させることができます。
*)
    reflexivity.
  Qed.

  (**
(* It is interesting to look at the form of the proof. *)

証明の形式(the form)を見るのは面白いです。
*)

  Print t1.
  (** %\vspace{-.15in}% [[
t1 =
fun a b c d : A =>
monoid_reflect (Op (Op (Op (Var a) (Var b)) (Var c)) (Var d))
  (Op (Op (Var a) (Op (Var b) (Var c))) (Var d))
  (eq_refl (a + (b + (c + (d + e)))))
     : forall a b c d : A, a + b + c + d = a + (b + c) + d
      ]]

(*
      The proof term contains only restatements of the equality operands in reified form, followed by a use of reflexivity on the shared canonical form. *)

証明項は、具現化された形式の等式のオペランドの再記述だけを含み、
共有された(shared)正準形(canonical form)への反射性の使用が続きます。
   *)

End monoid.

(**
(* Extensions of this basic approach are used in the implementations of the %\index{tactics!ring}%[ring] and %\index{tactics!field}%[field] tactics that come packaged with Coq. *)

この基本的なアプローチの拡張は、Coqでパッケージ化された、
%\index{tactics!ring}%[ring] と %\index{tactics!field}%[field] タクティク
の実装で使われています。
*)

(*
(** * A Smarter Tautology Solver *)
*)
(** * 賢いトートロジー・ソルバー *)

(**
(* Now we are ready to revisit our earlier tautology solver example.  We want to broaden the scope of the tactic to include formulas whose truth is not syntactically apparent.  We will want to allow injection of arbitrary formulas, like we allowed arbitrary monoid expressions in the last example.  Since we are working in a richer theory, it is important to be able to use equalities between different injected formulas.  For instance, we cannot prove [P -> P] by translating the formula into a value like [Imp (Var P) (Var P)], because a Gallina function has no way of comparing the two [P]s for equality.
*)

これで、以前のトートロジー・ソルバーの例を再検討する準備が整いました。
私たちは、真理が構文的に明らかでない式を含むようにタクティクの範囲を広げたいと考えています。
最後の例で任意のモノイド式を許可したのと同じように、
任意の式の注入(injection)を許可したいと思うでしょう。
私たちはより豊かな理論で作業しているので、
注入された異なる式の間で等値を使用できることが重要です。
例えば、Gallina関数は、ふたつの[P]が等しいかどうかを比較する方法がないため、
式を[Imp (Var P) (Var P)]のような値に変換することによって[P -> P]を証明することはできません。

(* suhara: 「注入」 に単射(injection)の意味はあるか？
後で [Prop]から[Formula]への injection という。 *)

(*
   To arrive at a nice implementation satisfying these criteria, we introduce the %\index{tactics!quote}%[quote] tactic and its associated library. *)

これらの基準を満たす素晴らしい実装に到達するために、
%\index{tactics!quote}%[quote]
タクティクとそれに関連するライブラリを紹介します。
 *)

Require Import Quote.

(* begin thide *)
Inductive formula : Set :=
| Atomic : index -> formula                 (* suhara: 原始論理式 *)
| Truth : formula
| Falsehood : formula
| And : formula -> formula -> formula
| Or : formula -> formula -> formula
| Imp : formula -> formula -> formula.
(* end thide *)

(**
(* The type %\index{Gallina terms!index}%[index] comes from the [Quote] library and represents a countable variable type.  The rest of [formula]'s definition should be old hat by now.

%\index{Gallina terms!index}%[index] 型は、[Quote]ライブラリからのものであり、
可算の変数の型を表します。
残りの[formula]の定義は、今のところ以前のまま(old hat)でなければなりません。
*)

(*   The [quote] tactic will implement injection from [Prop] into [formula] for us, but it is not quite as smart as we might like.  In particular, it wants to treat function types specially, so it gets confused if function types are part of the structure we want to encode syntactically.  To trick [quote] into not noticing our uses of function types to express logical implication, we will need to declare a wrapper definition for implication, as we did in the last chapter. *)

[quote] タクティクは[Prop]から[Formula]への単射(injection)を実装しますが、
望むほどスマートではありません。
特に、関数型を特別に扱いたいので、
関数型が構文的に符号化したい構造体の一部であれば混乱(confused)します。
論理的な意味を表現するために関数型を使用することに気づかないように
[quote]することをトリックするには、
最後の章で行ったように、含意のラッパー定義を宣言する必要があります。
 *)

Definition imp (P1 P2 : Prop) := P1 -> P2.
Infix "-->" := imp (no associativity, at level 95).

(**
(* Now we can define our denotation function. *)

ここでは、表示関数(denotation function)を定義することができます。
 (* suhara: 翻訳関数 interpretation function とも呼ばれる。 see. tautDenote *)
*)

Definition asgn := varmap Prop.             (* suhara: varmap は plugins/quote/Quote.v *)

(* begin thide *)
Fixpoint formulaDenote (atomics : asgn) (f : formula) : Prop :=
  match f with
    | Atomic v => varmap_find False v atomics
    | Truth => True
    | Falsehood => False
    | And f1 f2 => formulaDenote atomics f1 /\ formulaDenote atomics f2
    | Or f1 f2 => formulaDenote atomics f1 \/ formulaDenote atomics f2
    | Imp f1 f2 => formulaDenote atomics f1 --> formulaDenote atomics f2
  end.
(* end thide *)

(**
(* The %\index{Gallina terms!varmap}%[varmap] type family implements maps from [index] values.  In this case, we define an assignment as a map from variables to [Prop]s.  Our interpretation function [formulaDenote] works with an assignment, and we use the [varmap_find] function to consult the assignment in the [Atomic] case.  The first argument to [varmap_find] is a default value, in case the variable is not found. *)

%\index{Gallina terms!varmap}%[varmap] のファミリーは、
[index] の値から map を実装します。
この場合、変数から [Prop] への map として代入を定義します。
翻訳関数(interpretation function) [formulaDenote]は代入として動作し、
[varmap_find]関数を使って[Atomic]の場合の代入を調べます。
[varmap_find]の最初の引数は、変数が見つからない場合のデフォルト値です。
 *)

(* suhara: [varmap] ファミリーの使用例。

Print index.
(*
Inductive index : Set :=
| Left_idx : index -> index
| Right_idx : index -> index
| End_idx : index
 *)

Print varmap.
(*
Inductive varmap (A : Type) : Type :=
| Empty_vm : varmap A
| Node_vm : A -> varmap A -> varmap A -> varmap A
 *)

Variable ap0 : Prop.
Variable ap1 : Prop.
Variable ap2 : Prop.
Definition av0 :=           End_idx : index.
Definition av1 := Left_idx  End_idx : index.
Definition av2 := Right_idx End_idx : index.
Definition av3 := Right_idx (Right_idx End_idx) : index.
Definition aas := (Node_vm ap0              (* End_idx *)
                          (Node_vm ap1      (* Left_idx End_idx *)
                                   (Empty_vm Prop)
                                   (Empty_vm Prop))
                          (Node_vm ap2      (* Right_idx End_idx *)
                                   (Empty_vm Prop)
                                   (Empty_vm Prop)))
                 : asgn.
Compute varmap_find False av0 aas.            (* ap0 *)
Compute varmap_find False av1 aas.            (* ap1 *)
Compute varmap_find False av2 aas.            (* ap2 *)
Compute varmap_find False av3 aas.            (* False *)

asgn は、変数とその値の対応（代入）である。あとで出てくる
環境を示す変数のリスト(set index)とは異なる。
*)

Section my_tauto.
  Variable atomics : asgn.

  Definition holds (v : index) := varmap_find False v atomics.

  (**
(* We define some shorthand for a particular variable being true, and now we are ready to define some helpful functions based on the [ListSet] module of the standard library, which (unsurprisingly) presents a view of lists as sets. *)

特定の変数が真であるためにいくつかの省略形を定義し、
標準ライブラリの[ListSet]モジュールに基づいて、
（驚くことではありませんが）リストを集合として見ることを提供する、
便利な関数を定義する準備が整いました。
   *)

  Require Import ListSet.                   (* suhara: set_add の定義 *)

  Definition index_eq : forall x y : index, {x = y} + {x <> y}.
    decide equality.
  Defined.

  Definition add (s : set index) (v : index) := set_add index_eq v s.
  (* suhara: 環境sに、変数vを追加する。 *)

  Definition In_dec : forall v (s : set index), {In v s} + {~ In v s}.
    Local Open Scope specif_scope.

    intro; refine (fix F (s : set index) : {In v s} + {~ In v s} :=
      match s with
        | nil => No
        | v' :: s' => index_eq v' v || F s'
      end); crush.
  Defined.

  (**
(* We define what it means for all members of an index set to represent true propositions, and we prove some lemmas about this notion. *)

index の集合のすべてのメンバーに対して真となる命題を表わすもの
(* suhara: この場合はallTrue *)を定義し、
この表記についてのいくつかの補題を証明します。
*)

  Fixpoint allTrue (s : set index) : Prop :=
    match s with
      | nil => True
      | v :: s' => holds v /\ allTrue s'
    end.

  Theorem allTrue_add : forall v s,
    allTrue s
    -> holds v
    -> allTrue (add s v).
    induction s; crush;
      match goal with
        | [ |- context[if ?E then _ else _] ] => destruct E
      end; crush.
  Qed.

  Theorem allTrue_In : forall v s,
    allTrue s
    -> set_In v s
    -> varmap_find False v atomics.
    induction s; crush.
  Qed.

  Hint Resolve allTrue_add allTrue_In.

  Local Open Scope partial_scope.

  (**
(* Now we can write a function [forward] that implements deconstruction of hypotheses, expanding a compound formula into a set of sets of atomic formulas covering all possible cases introduced with use of [Or].  To handle consideration of multiple cases, the function takes in a continuation argument, which will be called once for each case.
*)

ここで、仮説の分解(deconstruction)を実装する関数 [forward] を書くことができ、
複合式を、[Or]を使って導入された可能性のあるすべての場合(case)をカバーする
一連のアトミックな論理式の集合に
展開することができます。

(* suhara:
どこに展開されるのかよくわからない。

atomic formula と言っているけれど、
Or で並べられた論理式なので、原始論理式ではなく「節」と呼ぶべきであろう。
formula型で導入された Atomic とは異なる。
*)

複数のケースの考慮を処理するために、この関数は継続引数(continuation argument
(* suhara: 継続渡しの引数 *))を取ります。
これはそれぞれのケースに対して1回呼び出されます。

(*
     The [forward] function has a dependent type, in the style of Chapter 6, guaranteeing correctness.  The arguments to [forward] are a goal formula [f], a set [known] of atomic formulas that we may assume are true, a hypothesis formula [hyp], and a success continuation [cont] that we call when we have extended [known] to hold new truths implied by [hyp]. *)

[forward]関数は、第6章のスタイルで依存性の型を持ち、正確さを保証します。
[forward]のへの引数は、ゴールの式[f]、
真であると仮定してもよい原子式の集合[known]、
仮定の式[hyp]、
および、[hyp]によって含意される新しい真実を保持するために
[known] を拡張するときに呼び出す次への継続(success continuation) [cont] です。
   *)

  Definition forward : forall (f : formula) (known : set index) (hyp : formula)
    (cont : forall known', [allTrue known' -> formulaDenote atomics f]),
    [allTrue known -> formulaDenote atomics hyp -> formulaDenote atomics f].
    refine (fix F (f : formula) (known : set index) (hyp : formula)
      (cont : forall known', [allTrue known' -> formulaDenote atomics f])
      : [allTrue known -> formulaDenote atomics hyp -> formulaDenote atomics f] :=
      match hyp with
        | Atomic v => Reduce (cont (add known v))
        | Truth => Reduce (cont known)
        | Falsehood => Yes
        | And h1 h2 =>
          Reduce (F (Imp h2 f) known h1 (fun known' =>
            Reduce (F f known' h2 cont)))
        | Or h1 h2 => F f known h1 cont && F f known h2 cont
        | Imp _ _ => Reduce (cont known)
      end); crush.
  Defined.

  (**
(* A [backward] function implements analysis of the final goal.  It calls [forward] to handle implications. *)

[backward]関数は、最終のゴールの分析を実装します。
含意を扱うために[forward]を呼び出します。
   *)

(* begin thide *)
  Definition backward : forall (known : set index) (f : formula),
    [allTrue known -> formulaDenote atomics f].
    refine (fix F (known : set index) (f : formula)
      : [allTrue known -> formulaDenote atomics f] :=
      match f with
        | Atomic v => Reduce (In_dec v known)
        | Truth => Yes
        | Falsehood => No
        | And f1 f2 => F known f1 && F known f2
        | Or f1 f2 => F known f1 || F known f2
        | Imp f1 f2 => forward f2 known f1 (fun known' => F known' f2)
      end); crush; eauto.
  Defined.
(* end thide *)

  (**
(* A simple wrapper around [backward] gives us the usual type of a partial decision procedure. *)

[backward]の周りの単純なラッパーは、部分的な決定のための手続きの通常のタイプを与えます。
(* suhara: partial は部分関数だが、decision は決定性ではないと思う *)
   *)

  Definition my_tauto : forall f : formula, [formulaDenote atomics f].
(* begin thide *)
    intro; refine (Reduce (backward nil f)); crush.
  Defined.
(* end thide *)
End my_tauto.

(**
(* Our final tactic implementation is now fairly straightforward.  First, we [intro] all quantifiers that do not bind [Prop]s.  Then we call the [quote] tactic, which implements the reification for us.  Finally, we are able to construct an exact proof via [partialOut] and the [my_tauto] Gallina function. *)

最終的なタクティクの実装はかなり簡単です。
まず、[Prop] の束縛しないすべての量化子を [intro] します。
次に、具象化を実装する[quote]タクティクを呼び出します。
最後に、[partialOut]と[my_tauto] のGallina関数を使用して正確な証明を構築します。

 (* suhara: exact の中のmy_tautoは、関数呼び出し。 *)
 *)

Ltac my_tauto :=
  repeat match goal with
           | [ |- forall x : ?P, _ ] =>
             match type of P with
               | Prop => fail 1      (* suhara: 2階論理は扱わない？ *)
               | _ => intro
             end
         end;
  quote formulaDenote;
  match goal with
    | [ |- formulaDenote ?m ?f ] => exact (partialOut (my_tauto m f))
  end.
(* end thide *)

(**
(* A few examples demonstrate how the tactic works. *)

いくつかの例は、タクティクがどのように機能するかを示しています。
*)

Theorem mt1 : True.
  my_tauto.
Qed.

Print mt1.
(** %\vspace{-.15in}% [[
mt1 = partialOut (my_tauto (Empty_vm Prop) Truth)
     : True
    ]]

(*
    We see [my_tauto] applied with an empty [varmap], since every subformula is handled by [formulaDenote]. *)

すべての部分式は[formulaDenote]によって処理されるため、
[my_tauto]に空の[varmap] (* suhara: (Empty_vm Prop) *) が適用されていることがわかります。
 *)

(* suhara:
Compute my_tauto (Empty_vm Prop) Truth.     (* YES *)
*)

Theorem mt2 : forall x y : nat, x = y --> x = y.
  my_tauto.
Qed.

(* suhara: nvm はなんのためにあるのか？ *)
(* begin hide *)
(* begin thide *)
Definition nvm := (Node_vm, Empty_vm, End_idx, Left_idx, Right_idx).
(* end thide *)
(* end hide *)

Print mt2.
(** %\vspace{-.15in}% [[
mt2 =
fun x y : nat =>
partialOut
  (my_tauto (Node_vm (x = y) (Empty_vm Prop) (Empty_vm Prop))
     (Imp (Atomic End_idx) (Atomic End_idx)))
     : forall x y : nat, x = y --> x = y
    ]]

(*
    Crucially, both instances of [x = y] are represented with the same index, [End_idx].  The value of this index only needs to appear once in the [varmap], whose form reveals that [varmap]s are represented as binary trees, where [index] values denote paths from tree roots to leaves. *)

重要なことに、[x = y]の両方のインスタンスは同じインデックス[End_idx]で表されます。
このインデックスの値は[varmap]に1回だけ現れなければならず、
[varmap]は、
[index] の値が木の根から葉までのパスを示す、
二進木(binary trees) として表現されます。
 *)
(*
Variables x y : nat.
Compute (my_tauto (Node_vm (x = y) (Empty_vm Prop) (Empty_vm Prop))
                  (Imp (Atomic End_idx) (Atomic End_idx))). (* YES *)
 *)

Theorem mt3 : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  --> y > z /\ (x < y \/ x < S y).
  my_tauto.
Qed.

Print mt3.
(** %\vspace{-.15in}% [[
fun x y z : nat =>
partialOut
  (my_tauto
     (Node_vm (x < S y) (Node_vm (x < y) (Empty_vm Prop) (Empty_vm Prop))
        (Node_vm (y > z) (Empty_vm Prop) (Empty_vm Prop)))
     (Imp
        (Or (And (Atomic (Left_idx End_idx)) (Atomic (Right_idx End_idx)))
           (And (Atomic (Right_idx End_idx)) (Atomic End_idx)))
        (And (Atomic (Right_idx End_idx))
           (Or (Atomic (Left_idx End_idx)) (Atomic End_idx)))))
     : forall x y z : nat,
       x < y /\ y > z \/ y > z /\ x < S y --> y > z /\ (x < y \/ x < S y)
    ]]

(*
    Our goal contained three distinct atomic formulas, and we see that a three-element [varmap] is generated.
*)

ゴールにはみっつの異なる原子式が含まれていて、
3要素の「varmap」が生成されていることがわかります。

(*
    It can be interesting to observe differences between the level of repetition in proof terms generated by [my_tauto] and [tauto] for especially trivial theorems. *)

特に自明な定理のために[my_tauto]と[tauto]によって生成される証明項の反復の
レベルの違いを観察することは面白いかもしれません。
 *)

Theorem mt4 : True /\ True /\ True /\ True /\ True /\ True /\ False --> False.
  my_tauto.
Qed.

Print mt4.
(** %\vspace{-.15in}% [[
mt4 =
partialOut
  (my_tauto (Empty_vm Prop)
     (Imp
        (And Truth
           (And Truth
              (And Truth (And Truth (And Truth (And Truth Falsehood))))))
        Falsehood))
     : True /\ True /\ True /\ True /\ True /\ True /\ False --> False
    ]]
    *)

Theorem mt4' : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
  tauto.
Qed.

(* suhara: これも必要か？ *)
(* begin hide *)
(* begin thide *)
Definition fi := False_ind.
(* end thide *)
(* end hide *)

Print mt4'.
(** %\vspace{-.15in}% [[
mt4' =
fun H : True /\ True /\ True /\ True /\ True /\ True /\ False =>
and_ind
  (fun (_ : True) (H1 : True /\ True /\ True /\ True /\ True /\ False) =>
   and_ind
     (fun (_ : True) (H3 : True /\ True /\ True /\ True /\ False) =>
      and_ind
        (fun (_ : True) (H5 : True /\ True /\ True /\ False) =>
         and_ind
           (fun (_ : True) (H7 : True /\ True /\ False) =>
            and_ind
              (fun (_ : True) (H9 : True /\ False) =>
               and_ind (fun (_ : True) (H11 : False) => False_ind False H11)
                 H9) H7) H5) H3) H1) H
     : True /\ True /\ True /\ True /\ True /\ True /\ False -> False
    ]]

(*
The traditional [tauto] tactic introduces a quadratic blow-up in the size of the proof term, whereas proofs produced by [my_tauto] always have linear size. *)

伝統的な[tauto]タクティクは、
証明項のサイズの2次(quadratic)的な「爆発(blow-up)」を導入するのに対し、(* suhara: O(n2) *)
[my_tauto]によって生成される証明は常に線形の大きさを持ちます。(* suhara: O(n) *)
 *)

(*
(** ** Manual Reification of Terms with Variables *)
 *)
(** ** 変数を持つ項の手動の具象化 *)

(* begin thide *)
(**
(* The action of the [quote] tactic above may seem like magic.  Somehow it performs equality comparison between subterms of arbitrary types, so that these subterms may be represented with the same reified variable.  While [quote] is implemented in OCaml, we can code the reification process completely in Ltac, as well.  To make our job simpler, we will represent variables as [nat]s, indexing into a simple list of variable values that may be referenced.
*)

上記の[quote] タクティクの動作は手品のように見えます。
どういうわけか、それは任意の型の副項(subterms)どうしが等しいかどうかの比較(equality comparison)
を実行するので、これらの副項は同じ具象化された(reified)変数でされるでしょう。
[quote]はOCamlで実装されていますが、具象化のプロセス(reification process)
をLtacで完全にコードすることができます。
仕事をより簡単にするために、変数を[nat]として表現し、
参照される変数の値からなる単純なリストにインデックスを付けます。
(* suhara: 変数を表現する[nat]のインデックスでリストを参照することで、値を得る。
これに対して、[varmap]ファミリは、二分木を使っていた。 *)

(*
   Step one of the process is to crawl over a term, building a duplicate-free list of all values that appear in positions we will encode as variables.  A useful helper function adds an element to a list, preventing duplicates.  Note how we use Ltac pattern matching to implement an equality test on Gallina terms; this is simple syntactic equality, not even the richer definitional equality.  We also represent lists as nested tuples, to allow different list elements to have different Gallina types. *)

プロセスの最初のステップは、項をクロールし、
エンコードする位置に表示されるすべての値の重複のないリストを変数として構築することです。
便利な補助関数(helper function)は、重複を防止ながら、要素をリストに追加ます。
Ltacのパターンマッチングを使用してGallina項についての等値のテスト
(equality test)を実装する方法に注意してください。
これは単純な文法的な等値(syntactic equality)であり、
より豊かな定義による等値(definitional equality)ではありません。
また、異なるリストの要素が異なるGallinaに型を持つことを可能にするために、
ネストされたタプルとしてリストを表現します。
*)

Ltac inList x xs :=
  match xs with
    | tt => false
    | (x, _) => true
    | (_, ?xs') => inList x xs'
  end.

Ltac addToList x xs :=
  let b := inList x xs in
    match b with
      | true => xs
      | false => constr:((x, xs))
    end.

(**
(* Now we can write our recursive function to calculate the list of variable values we will want to use to represent a term. *)

ここで、項を表すために使用する変数値のリストを計算する再帰関数を書くことができます。
 *)

Ltac allVars xs e :=
  match e with
    | True => xs
    | False => xs
    | ?e1 /\ ?e2 =>
      let xs := allVars xs e1 in
        allVars xs e2
    | ?e1 \/ ?e2 =>
      let xs := allVars xs e1 in
        allVars xs e2
    | ?e1 -> ?e2 =>
      let xs := allVars xs e1 in
        allVars xs e2
    | _ => addToList e xs
  end.

(**
(* We will also need a way to map a value to its position in a list. *)

値をリストの内の位置にマップする方法も必要です。
 *)

Ltac lookup x xs :=
  match xs with
    | (x, _) => O
    | (_, ?xs') =>
      let n := lookup x xs' in
        constr:(S n)
  end.

(**
(* The next building block is a procedure for reifying a term, given a list of all allowed variable values.  We are free to make this procedure partial, where tactic failure may be triggered upon attempting to reify a term containing subterms not included in the list of variables.  The type of the output term is a copy of [formula] where [index] is replaced by [nat], in the type of the constructor for atomic formulas. *)

次の構成要素(building block)は、許可されたすべての変数値のリストを指定して、
項を具象化する手順です。
変数のリストに含まれていない副項(subterm)を含む項の具象化を試みると、
タクティクの失敗が引き起こされる可能性があるため、
この手続きは部分的(partial)になります(free to make this procedure partial)。
出力項の型は、[index]が[nat]に置き換えられた[formula]のコピーで、
アトミックな式のコンストラクタの型です。
 *)

Inductive formula' : Set :=
| Atomic' : nat -> formula'
| Truth' : formula'
| Falsehood' : formula'
| And' : formula' -> formula' -> formula'
| Or' : formula' -> formula' -> formula'
| Imp' : formula' -> formula' -> formula'.

(**
(* Note that, when we write our own Ltac procedure, we can work directly with the normal [->] operator, rather than needing to introduce a wrapper for it. *)

私たち自身のLtac手続きを書くときは、ラッパーを導入する必要はなく、
通常の[->]演算子で直接作業することができます。
(* suhara: quote のためには --> が必要だったが、ここでは不要である *)
 *)

Ltac reifyTerm xs e :=
  match e with
    | True => Truth'
    | False => Falsehood'
    | ?e1 /\ ?e2 =>
      let p1 := reifyTerm xs e1 in
      let p2 := reifyTerm xs e2 in
        constr:(And' p1 p2)
    | ?e1 \/ ?e2 =>
      let p1 := reifyTerm xs e1 in
      let p2 := reifyTerm xs e2 in
        constr:(Or' p1 p2)
    | ?e1 -> ?e2 =>
      let p1 := reifyTerm xs e1 in
      let p2 := reifyTerm xs e2 in
        constr:(Imp' p1 p2)
    | _ =>
      let n := lookup e xs in
        constr:(Atomic' n)
  end.

(**
(* Finally, we bring all the pieces together. *)

最後に、すべての作品をまとめています。
*)
Ltac reify :=
  match goal with
    | [ |- ?G ] => let xs := allVars tt G in
      let p := reifyTerm xs G in
        pose p
  end.

(**
(* A quick test verifies that we are doing reification correctly. *)

クイックテストは、私たちが正しく具象化(reification)を行っていることを検証します。
*)

Theorem mt3' : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  -> y > z /\ (x < y \/ x < S y).
  do 3 intro; reify.

(**
(* Our simple tactic adds the translated term as a new variable:
*)

私たちの簡単なタクティクは、変換された項を新しい変数として追加します：

[[
f := Imp'
         (Or' (And' (Atomic' 2) (Atomic' 1)) (And' (Atomic' 1) (Atomic' 0)))
         (And' (Atomic' 1) (Or' (Atomic' 2) (Atomic' 0))) : formula'
]]
*)
Abort.

(**
(* More work would be needed to complete the reflective tactic, as we must connect our new syntax type with the real meanings of formulas, but the details are the same as in our prior implementation with [quote]. *)

新しい構文型と式の実際の意味を結びつけなければならないので、
リフレクティブなタクティクを完成させるためにはもっと多くの作業が必要ですが、
詳細は以前の[quote]による実装と同じです。
*)

(* end thide *)

(* suhara: quote をみなおす。

Theorem mt3'' : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  --> y > z /\ (x < y \/ x < S y).
  intros.
  quote formulaDenote.
(* ここまででは、my_tauto, backward, forward は不要である。 *)
(* 奇妙なのは、formulaDenote が、formulaからPropの関数であるのに、
   ここでは、Prop から formula へ変換していることである。 *)
Abort.

Coq manual から：
10.3  quote
The tactic quote allows using Barendregt's so-called 2-level approach
without writing any ML code. Suppose you have a language L of
'abstract terms' and a type A of 'concrete terms' and a function f : L-> A.
If L is a simple inductive datatype and f a simple fixpoint,
quote f will replace the head of current goal by a convertible term of
the form (f t). L must have a constructor of type: A -> L.

抽象的な項Lから具体的な項A への関数 f : L->A があり、
Lが帰納型で、fが再帰関数なら、quote f は、現在のゴールを(f t)から変換する。
Lは、A->L型のコンストラクタが必要である。
つまり、formulaDenote : formula -> Prop に対して、
quote formulaDenote は、ゴールに対して、Prop -> formula を実行する。

これに対して、reify は ゴールに対して、直接、Prop -> formula をおこなうタクティクである。
*)

(*
(** * Building a Reification Tactic that Recurses Under Binders *)
 *)
(** * 束縛のもとで再帰する具象化タクティクを作る *)

(**
(* All of our examples so far have stayed away from reifying the syntax of terms that use such features as quantifiers and [fun] function abstractions.  Such cases are complicated by the fact that different subterms may be allowed to reference different sets of free variables.  Some cleverness is needed to clear this hurdle, but a few simple patterns will suffice.  Consider this example of a simple dependently typed term language, where a function abstraction body is represented conveniently with a Coq function. *)

これまでのすべての例では、量化子や、[fun]による関数抽象などの項の構文を具現化する形式
から離れていました。
そのような場合は、
異なる副項が自由変数の異なる集合を参照することを許されるという事実によって複雑になります。
このようなハードルを解消するためにはいくつかの巧妙さが必要ですが、
すこしの単純なパターンで十分です。
関数抽象の本体が便利にCoqの関数で表されている単純な依存型の言語の例を考えてみましょう。
 *)

Inductive type : Type :=
| Nat : type
| NatFunc : type -> type.

Inductive term : type -> Type :=
| Const : nat -> term Nat
| Plus : term Nat -> term Nat -> term Nat
| Abs : forall t, (nat -> term t) -> term (NatFunc t).

Fixpoint typeDenote (t : type) : Type :=
  match t with
    | Nat => nat
    | NatFunc t => nat -> typeDenote t
  end.

Fixpoint termDenote t (e : term t) : typeDenote t :=
  match e with
    | Const n => n
    | Plus e1 e2 => termDenote e1 + termDenote e2
    | Abs _ e1 => fun x => termDenote (e1 x)
  end.

(**
(* Here is a %\%naive%{}% first attempt at a reification tactic. *)

ここでは、具象化のタクティクで素朴(%\%naive%{}%)な最初の試みがあります。
*)

(* begin hide *)
Definition red_herring := O.
(* end hide *)
Ltac refl' e :=
  match e with
    | ?E1 + ?E2 =>
      let r1 := refl' E1 in
      let r2 := refl' E2 in
        constr:(Plus r1 r2)

    | fun x : nat => ?E1 =>
      let r1 := refl' E1 in
        constr:(Abs (fun x => r1 x))

    | _ => constr:(Const e)
  end.

(**
(* Recall that a regular Ltac pattern variable [?X] only matches terms that _do not mention new variables introduced within the pattern_.  In our %\%naive%{}% implementation, the case for matching function abstractions matches the function body in a way that prevents it from mentioning the function argument!  Our code above plays fast and loose with the function body in a way that leads to independent problems, but we could change the code so that it indeed handles function abstractions that ignore their arguments.

正規のLtacのパターン変数[?X]は、
＿パターン内に導入された新しい変数について言及していない項＿
にのみマッチすることを想起してください。

(* suhara: fun x => ?E1 と fun a => F a はマッチしない。E1 = F a にならない。
ここでいう新しく導入された変数とは、a にあたる *)

素朴(%\%naive%{}%)な実装では、
関数の引数に言及することを妨げる方法です！
上記のコードは、独立した問題を引き起こすような方法で、
関数本体を高速かつ緩やかに実行しますが、コードを変更して、
引数を無視する関数抽象を実際に処理できるようにします。
*)

(*
   To handle functions in general, we will use the pattern variable form [@?X], which allows [X] to mention newly introduced variables that are declared explicitly.  A use of [@?X] must be followed by a list of the local variables that may be mentioned.  The variable [X] then comes to stand for a Gallina function over the values of those variables.  For instance: *)

関数を一般的に扱うために、パターンの変数の形式 [@?X]を使用して、
明示的に宣言された新しく導入された変数について[X]が言及するようにします。
[@?X]の使用のあとには、言及する可能性のあるローカル変数のリストを続ける必要があります。

(* suhara: fun x => @?E1 x と fun a => F a はマッチする。E1 = F になる。 *)

変数[X]は、それらの変数の値に渡ってGallina関数を表します。 例えば：
 *)

Reset refl'.
(* begin hide *)
Reset red_herring.
Definition red_herring := O.
(* end hide *)
Ltac refl' e :=
  match e with
    | ?E1 + ?E2 =>
      let r1 := refl' E1 in
      let r2 := refl' E2 in
        constr:(Plus r1 r2)

    | fun x : nat => @?E1 x =>              (* suhara: @をつける。 *)
      let r1 := refl' E1 in
        constr:(Abs r1)

    | _ => constr:(Const e)
  end.

(**
(* Now, in the abstraction case, we bind [E1] as a function from an [x] value to the value of the abstraction body.  Unfortunately, our recursive call there is not destined for success.  It will match the same abstraction pattern and trigger another recursive call, and so on through infinite recursion.  One last refactoring yields a working procedure.  The key idea is to consider every input to [refl'] as _a function over the values of variables introduced during recursion_. *)

抽象化の場合[E1]を、[x]の値から抽象化した本体の値への関数に、束縛します。
残念ながら、再帰呼び出しは成功すると決まったわけではありません。

同じ抽象パターンに一致し、別の再帰呼び出しを実行するなど、無限再帰を使用します。
最後の具象化によって作業手順が得られます。
重要なアイデアは、[refl']へのすべての入力を
＿再帰中に導入された変数の値に対する関数＿ として考えることです。

 *)

Reset refl'.
(* begin hide *)
Reset red_herring.
(* end hide *)
Ltac refl' e :=
  match eval simpl in e with
    | fun x : ?T => @?E1 x + @?E2 x =>
      let r1 := refl' E1 in
      let r2 := refl' E2 in
        constr:(fun x => Plus (r1 x) (r2 x)) (* suhara: 返値を関数にする。 *)

    | fun (x : ?T) (y : nat) => @?E1 x y =>
      let r1 := refl' (fun p : T * nat => E1 (fst p) (snd p)) in
        constr:(fun u => Abs (fun v => r1 (u, v))) (* suhara: 返値を関数にする。 *)

    | _ => constr:(fun x => Const (e x)) (* suhara: 返値を関数にする。 *)
  end.

(**
(* Note how now even the addition case works in terms of functions, with [@?X] patterns.  The abstraction case introduces a new variable by extending the type used to represent the free variables.  In particular, the argument to [refl'] used type [T] to represent all free variables.  We extend the type to [T * nat] for the type representing free variable values within the abstraction body.  A bit of bookkeeping with pairs and their projections produces an appropriate version of the abstraction body to pass in a recursive call.  To ensure that all this repackaging of terms does not interfere with pattern matching, we add an extra [simpl] reduction on the function argument, in the first line of the body of [refl'].
*)

[@?X]のパターンでは、関数の形で加算の場合でもどのように動作するのか注意してください。
抽象化の場合、自由変数を表すために使用される型を拡張することによって新しい変数が導入されます。
すべての自由変数を表すために[T]型を使用しました。
抽象化の本体内の自由変数値を表す型の型を[T * nat]に拡張します。
ペアとその射影(projection)による
少しのブックキーピング(a bit of bookkeeping)は、
再帰呼び出しで渡す抽象本体の適切なバージョンを生成します。
このような項の再パッケージングがすべてパターンマッチングを妨げないようにするために、
[refl']の本体の最初の行に関数引数を追加します。

(*
   Now one more tactic provides an example of how to apply reification.  Let us consider goals that are equalities between terms that can be reified.  We want to change such goals into equalities between appropriate calls to [termDenote]. *)

今やもうひとつのタクティクが、具象化を適用する方法の例を提供します。
具象化できる項どうしの等式であるゴールを考えてみましょう。
このようなゴールを[termDenote]への適切な呼び出しの間で等式に変更したいと考えています。
 *)

Ltac refl :=
  match goal with
    | [ |- ?E1 = ?E2 ] =>
      let E1' := refl' (fun _ : unit => E1) in
      let E2' := refl' (fun _ : unit => E2) in
        change (termDenote (E1' tt) = termDenote (E2' tt));
          cbv beta iota delta [fst snd]
  end.

Goal (fun (x y : nat) => x + y + 13) = (fun (_ z : nat) => z).
  refl.
(** %\vspace{-.15in}%[[
  ============================
   termDenote
     (Abs
        (fun y : nat =>
         Abs (fun y0 : nat => Plus (Plus (Const y) (Const y0)) (Const 13)))) =
   termDenote (Abs (fun _ : nat => Abs (fun y0 : nat => Const y0)))
]]
*)

Abort.

(**
(* Our encoding here uses Coq functions to represent binding within the terms we reify, which makes it difficult to implement certain functions over reified terms.  An alternative would be to represent variables with numbers.  This can be done by writing a slightly smarter reification function that identifies variable references by detecting when term arguments are just compositions of [fst] and [snd]; from the order of the compositions we may read off the variable number.  We leave the details as an exercise (though not a trivial one!) for the reader. *)

ここでのエンコーディングは、Coqの関数を使用して、妥当な条件で束縛を表現しているため、
特定の関数機能を実現するのが難しくなります。

また、変数を数値で表現する方法もあります。
これは、項の引数が[fst]と[snd]の合成だけであることを検出することによって、
変数参照を識別する若干スマートな具象化関数を書くことによって行うことができます。
構成の順序から、変数の数値を読み取ることができます。
読者のために詳細を練習問題（しかし、自明なものではありません！）として残しています。
 *)

(* END *)


(* http://ilyasergey.net/pnp/ *)

(** * 「Hoare Type Theory の基礎」から抜粋 *)
(** * Elements of Hoare Type Theory *)

Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.

Add LoadPath "./../htt".
Require Import prelude pred pcm unionmap heap heaptac
        stmod stsep stlog stlogR.

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

(** ** 階乗計算手続 の証明 *)
(* ** Verifying the factorial procedure mechanically *)

(** 純粋関数型の階乗 *)
Fixpoint fact_pure n := if n is n'.+1 then n * (fact_pure n') else 1.

(** ループ不変式 *)
Definition fact_inv (n acc : ptr) (N : nat) h : Prop :=
  exists n' a': nat,
  [/\ h = n :-> n' \+ acc :-> a' &
      (fact_pure n') * a' = fact_pure N].

(** 階乗の加算器(accumulator)部分の証明  *)
Definition fact_acc_tp n acc :=
  unit -> {N},
     STsep (fact_inv n acc N,
           [vfun (res : nat) h => fact_inv n acc N h /\ res = fact_pure N]).

Program Definition fact_acc (n acc : ptr): fact_acc_tp n acc :=
  Fix (fun (loop : fact_acc_tp n acc) (_ : unit) =>
    Do (a1 <-- !acc;
        n' <-- !n;
        if n' == 0 then
          ret a1
        else
          acc ::= a1 * n';;
          n ::= n' - 1;;
          loop tt)).
Next Obligation.
  apply: ghR => i N.                        (* conseq を消す。 *)
  case=> n' [a'] []. move=> -> Hi _.        (* case=> n' [a'][->{i}] Hi _.  *)

  Search (verify _ _ _).
  (* (x <-- !x; e x) を2個処理する。 *)
  do 2! [apply: bnd_readR => /=].           (* heval. *)

  case X: (n' == 0).

  (* (n' == 0) = true *)
  Search _ (verify _ _ _) (ret _).
  (* (ret v) を変形する。 *)
  - apply: val_ret => /= _.

    (* fact_inv n acc N (n :-> n' \+ acc :-> a') /\ a' = fact_pure N
       を証明する。 *)
    move/eqP : X => Z; subst n'.            (* 前提のXを n' = 0 にする。 *)
    rewrite mul1n in Hi.
    split.
    + exists 0. exists a'. rewrite /= mul1n. by [].
    + by [].

  (* (n' == 0) = false *)
  (* 代入文の並びなら、heval でよい。 *)
  - heval.

    Check (gh_ex N).
    (* (loop tt) を (Do loop tt) にするだけのように見えるが、
     ({N}, STsep (_, _)) を (STbin _) に、Nを追い出している。 *)
    Check (loop tt).
    Check (Do loop tt).
    apply: (gh_ex N).

    (* Do loop tt からループ不変式を取り出す。 *)
    apply: val_doR => // _.

    (* fact_inv n acc N (n :-> (n' - 1) \+ acc :-> (a' * n'))
       を証明する。 *)
    rewrite /fact_inv. exists (n' - 1). exists (a' * n').
    split => //=.
    rewrite -Hi=> {Hi}.
    rewrite [a' * _]mulnC mulnA [_ * n']mulnC.
    case: n' X => //= n' _.
    by rewrite subn1 -pred_Sn.
Qed.

(** 全体の証明  *)
Definition fact_tp N :=
  STsep ([Pred h | h = Unit],
         [vfun res h => res = fact_pure N /\ h = Unit]).

Program Definition fact (N : nat) : fact_tp N :=
  Do (n   <-- alloc N;
      acc <-- alloc 1;
      res <-- fact_acc n acc tt;
      dealloc n;;
      dealloc acc;;
      ret res).
Next Obligation.
  rewrite /conseq => /=.
  move=> i ->.                              (* rewriteは、 i = Unit  *)
  heval=> n.                                (* n <-- alloc N をheapに。 *)
  heval=> acc.                              (* acc <-- alloc 1 をheapに。 *)
  (* x \+ y を y \+ x *)
  (* x \+ Unit を x *)
  rewrite joinC unitR.

  Search _ (verify _ _ _).
  (* (x <-- e1; e2 x) を変形する。 *)
  apply: bnd_seq => /=.

  (* (fact_acc n acc tt) を (Do fact_acc n acc tt)  *)
  apply: (gh_ex N).

  (* (Do fact_acc n acc tt) *)
  apply: val_doR => //.

  (* fact_inv n acc N (n :-> N \+ acc :-> 1) の証明 *)
  - by exists N, 1; rewrite muln1.
  (*  *)
  - move=> x m.
    case.
    case=> n'.
    case=> a'.
    case=> H1 _ H2 _.
    (* move=> x m [] [n'] [a'] [] H1 _ H2 _.
       または
       move=> x m [[n'] [a'] [H1] _ H2 _]. *)
    rewrite H1 H2.
    by heval.                               (* e1;; e2;; ret _ *)
Qed.

(* END *)


Require Import Blech.Defaults.

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

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Blech.Reflect.

Import CategoryNotations.
Import BishopNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition Bsh: Category := {|
  Obj := Bishop ;
  Mor A B := {f: A → B | Proper (equiv ==> equiv) f };
  Mor_Setoid _ _ := {| equiv f g := ∀ x, f x == g x |};

  id _ x := x ;
  compose _ _ _ f g x := f (g x) ;
|}.

Next Obligation.
Proof.
  exists.
  - intros ? ?.
    reflexivity.
  - intros ? ? p ?.
    rewrite (p _).
    reflexivity.
  - intros ? ? ? p q ?.
    rewrite (p _).
    rewrite (q _).
    reflexivity.
Qed.

Next Obligation.
Proof.
  intros ? ? ?.
  assumption.
Qed.

Next Obligation.
Proof.
  intros ? ? ?.
  rewrite H1.
  reflexivity.
Qed.

Next Obligation.
Proof.
  intros f g p f' g' q x.
  cbn in *.
  rewrite (p _).
  apply (proj2_sig g).
  rewrite (q _).
  reflexivity.
Qed.

Definition Mor_proj {A B}: Bsh A B → A → B := @proj1_sig _ _.

Definition Mor_Proper {A B}: ∀ (f: Bsh A B), Proper _ _ := @proj2_sig _ _.
Existing Instance Mor_Proper.

Instance curry_Proper (A B: Bishop): Proper (@equiv _ (@Mor_Setoid Bsh A B) ==> equiv ==> equiv) ( @proj1_sig (A → B) (Proper (@equiv _ Bishop_Setoid ==> @equiv _ Bishop_Setoid))).
Proof.
  intros ? ? p ? ? q.
  rewrite q.
  apply p.
Defined.


Require Export Bool.Sumbool.
Require Export Omega.
Require Export List.
Export ListNotations.
(* for composition *)
Require Export Basics.
(* for rewriting *)
Export Setoid.

Require Export SmolkaUtilities.
Require Export Utilities.
Require Export TheoryDef.
Require Export TermsUtilities.
Require Export Substitutions.
Require Export Factoring.
Require Export EquivalenceAndUnifiability.

(** * The Algorithm *)

(** *** Compute an initial solution *)

(**  Returns (Some gamma) if gamma is a 01_sub making t eval to T0  *)

Definition ground_soln (t: term) : option subL :=
  find (fun s => eqv_bool (s @ t) T0) (all_01subs t).

(** *** Build a new sub out of a given subs and a given term *)

Fixpoint lowenheim_liftX (tau : subL) (t: term)  (l: list var) : subL :=
  match l  with
    [] => id_sub
  | (x :: rest) =>
    (x, (t +' T1) *' (V x) +' t *' (tau @ (V x)))
      :: (lowenheim_liftX tau t rest)
  end.

Definition lowenheim_lift (t: term) (tau: subL) : subL :=
  lowenheim_liftX tau t (vars_term t).

(** *** Amazingly, this constructs an mgu *)

Definition solve_lowenheim (t: term) :=
  option_map (lowenheim_lift t) (ground_soln t).

(** * Correctness Argument *)

(** ** Facts About lowenheim_lift *)

Section LowenheimLiftBehavior.

Lemma lowenheim_liftX_domain (t: term) (tau: subL) l :
  domain_sub (lowenheim_liftX tau t l ) = l.
Proof.
  induction l as [| v rest]; simpl; auto.
  now rewrite IHrest.
Qed.

Lemma lowenheim_lift_domain (t: term) (tau: subL) :
  domain_sub (lowenheim_lift t tau) = (vars_term t).
Proof.
  unfold lowenheim_lift.
  apply lowenheim_liftX_domain.
Qed.

  (** *** lowenheim_liftX on vars *)

  (* in_cons_neq is from SB_Base *)
  Lemma lowenheim_liftX_var_In :
    forall   (t: term) (tau: subL) (l: list var) (v: var),
      In v l ->
      (lowenheim_liftX tau t l) @ (V v) ==
      (t +' T1) *' (V v) +' t *' (tau @ (V v)).
  Proof.
    induction l as [| x l'].
    - intros v H. inversion H.
    - intros v H.
      + simpl.
        decide (x=v).
        -- rewrite e.
           auto.
        -- assert (v el l').
           apply (in_cons_neq v x l').
           assumption.
           intros K. apply symmetry in K. auto.
           now apply IHl'.
  Qed.

  (** *** lowenheim_liftX on terms *)

  Lemma lowenheim_liftX_term:
    forall   (t: term) (tau : subL) (l: list var),
    forall (u: term),
      (forall x, (In x (vars_term u)) -> (In x l)) ->
      (lowenheim_liftX tau t l) @ u ==
      (t+'T1) *' u +' t *' (tau @ u).
  Proof.
    intros t tau l u Hvars.
    induction u.  unfold lowenheim_liftX.
    - repeat rewrite apply_sub_T0_hom; auto.
      repeat rewrite zeroM'.  now rewrite invA.
    - repeat rewrite apply_sub_T1_hom; auto.
      repeat rewrite idM'. rewrite comA. rewrite <- assocA.
      now rewrite invA.
    - intros. apply lowenheim_liftX_var_In.
      now apply Hvars; simpl; left.
    - intros. simpl. bsimp.
      rewrite IHu1. rewrite IHu2.
      bsimp.  intros. apply Hvars.
      now apply vars_term_A_R.
      intros. apply Hvars.
      now apply vars_term_A_L.
    - intros. simpl.
      rewrite IHu1. rewrite IHu2.
      intros.
      bsimp.
      intros. apply Hvars.
      now apply vars_term_M_R.
      intros. apply Hvars.
      now apply vars_term_M_L.
  Qed.

  Lemma lowenheim_lift_term (t: term) (tau: subL) :
    (lowenheim_lift t tau) @ t ==
    t *' (tau @ t).
  Proof.
    intros.
    unfold lowenheim_lift.
    rewrite lowenheim_liftX_term.
    - now rewrite T0_div'.
    - easy.
  Qed.

  Theorem lift_unifies : forall (t: term) (tau: subL),
      solves tau t ->
      solves (lowenheim_lift t tau) t.
  Proof.
    intros t tau Htau.
    unfold solves in *.
    rewrite lowenheim_lift_term.
    rewrite Htau.
    now rewrite zeroM'.
  Qed.

  Lemma lift_action: forall t tau x,
      In x (vars_term t) ->
      ((lowenheim_lift t tau) @ (V x)) ==
      (t +' T1) *' (V x) +' t *' (tau @ (V x)).
  Proof.
    intros t tau x Hin.
    unfold lowenheim_lift.
    rewrite lowenheim_liftX_term.
    - easy.
    - intros x0 Hin'.
      assert (a: x = x0).
      + unfold vars_term in Hin'.
        simpl in Hin'.
        now destruct Hin'.
      + now rewrite <- a.
  Qed.

  Lemma lift_mgu : forall (t: term) (tau: subL),
      solves tau t ->
      mgu (lowenheim_lift t tau) t.
  Proof.
    intros t tau Htau.
    unfold mgu.
    split.
    - (* the solution solves t *)
      now apply lift_unifies.
    - (* it is most general *)
      intros gamma Hgamma x.
      decide (In x (vars_term t)).
      + (* x is in vars_term t *)
        assert (A1:= lowenheim_liftX_var_In t tau (vars_term t) x i).
        unfold lowenheim_lift.
        rewrite A1.

        (** now do the calculations *)
        unfold solves in *.
        repeat rewrite apply_sub_A_hom.
        repeat rewrite apply_sub_M_hom.
        rewrite apply_sub_A_hom.
        repeat rewrite Hgamma.
        rewrite apply_sub_T1_hom.
        rewrite idA.
        rewrite idM.
        rewrite zeroM.
        now rewrite idA'.
      +  (* x is in not vars_term t *)
        assert (A1:  (lowenheim_lift t tau @ V x) = (V x)).
        -- assert (A2:= lowenheim_lift_domain t tau).
           apply not_domain_no_change.
           now rewrite <- A2 in n.
        -- now rewrite A1.
  Qed.

End LowenheimLiftBehavior.

(** ** Correctness of the None case *)

Section Solvable_Ground_Soln.

  Variable t: term.

  Lemma solvable_then_ground_soln :
    solvable t ->
    exists gamma, ground_soln t = Some gamma.
  Proof.
    intros H.
    apply existsb_find.
    apply List.existsb_exists.
    (* unfold ground_solved_byb. *)
    rewrite (computable_solvability t) in H.
    destruct H as [gamma H1]. destruct H1.
    assert (H1 := eval_ground_exact_T0 (gamma @ t) H0).
    exists gamma.
    split.
    - easy.
    - now rewrite eqv_bool_correct.
  Qed.

  Lemma ground_soln_then_solvable :
    (exists gamma, ground_soln t = Some gamma) ->
    solvable t .
  Proof.
    intros H. destruct H as [gamma H1].
    exists gamma.
    unfold ground_soln in H1.
    assert (H2 := find_some _ _ H1).
    destruct H2.
    (* unfold ground_solved_byb in H0. *)
    rewrite (eqv_bool_correct (gamma @ t) T0) in H0.
    easy.
  Qed.

  Lemma solvable_iff_ground_soln :
    solvable t <->
    exists gamma, ground_soln t = Some gamma.
  Proof.
    split.
    apply solvable_then_ground_soln.
    apply ground_soln_then_solvable.
  Qed.

End Solvable_Ground_Soln.

Lemma lowenheim_correct_None t :
  solve_lowenheim t = None ->
  solvable t -> False.
Proof.
  intros H1 H2.
  rewrite (solvable_iff_ground_soln t) in H2.
  apply option_map_reflect_None in H1.
  assert (A1:= None_not_Some ground_soln t).
  assert (A2:= A1 H1).
  destruct H2 as [gamma H2'].
  congruence.
Qed.

(** ** Correctness of the Some case *)

Lemma ground_soln_Some t gamma :
  ground_soln t = Some gamma ->
  solves gamma t.
Proof.
  intros H.
  unfold ground_soln in H.
  assert (H1:= find_some (fun s => eqv_bool (s @ t) T0)
                         (all_01subs t) H ).
  destruct H1.
  now rewrite eqv_bool_correct in H1.
Qed.

Lemma solve_lowenheim_Some (t: term) (sigma: subL) :
  (solve_lowenheim t = Some sigma) ->
  exists gamma,
    ground_soln t = Some gamma /\
    sigma = (lowenheim_lift t) gamma.
Proof.
  intros.
  unfold solve_lowenheim in H.
  assert (A1:= option_map_reflect_Some
                 (lowenheim_lift t)
                 (ground_soln t) sigma H).
  destruct A1 as [gamma A11]. destruct A11 as [A111 A112].
  now exists gamma.
Qed.

Lemma lowenheim_correct_Some sigma t :
  solve_lowenheim t = Some sigma ->
  mgu sigma t.
Proof.
  intro H.
  assert (a:= solve_lowenheim_Some t sigma H).
  elim a.
  intros.
  elim H0.
  intros.
  rewrite H2.
  apply lift_mgu.
  now apply (ground_soln_Some t).
Qed.

(** ** Put the pieces together *)

Theorem lowenheim_correct (t: term) :
  match (solve_lowenheim t) with
  | None => ~ (solvable t)
  | Some sigma => mgu sigma t
  end .
Proof.
  case_eq (solve_lowenheim t).
  - intros sigma.
    exact (lowenheim_correct_Some sigma t).
  - exact (lowenheim_correct_None t).
Qed.


From Hammer Require Import Hammer.

Definition prop_degeneracy := forall A:Prop, A = True \/ A = False.

Definition prop_extensionality := forall A B:Prop, (A <-> B) -> A = B.

Definition excluded_middle := forall A:Prop, A \/ ~ A.

Lemma prop_degen_ext : prop_degeneracy -> prop_extensionality.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.prop_degen_ext".
intros H A B [Hab Hba].
destruct (H A); destruct (H B).
rewrite H1; exact H0.
absurd B.
rewrite H1; exact (fun H => H).
apply Hab; rewrite H0; exact I.
absurd A.
rewrite H0; exact (fun H => H).
apply Hba; rewrite H1; exact I.
rewrite H1; exact H0.
Qed.

Lemma prop_degen_em : prop_degeneracy -> excluded_middle.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.prop_degen_em".
intros H A.
destruct (H A).
left; rewrite H0; exact I.
right; rewrite H0; exact (fun x => x).
Qed.

Lemma prop_ext_em_degen :
prop_extensionality -> excluded_middle -> prop_degeneracy.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.prop_ext_em_degen".
intros Ext EM A.
destruct (EM A).
left; apply (Ext A True); split;
[ exact (fun _ => I) | exact (fun _ => H) ].
right; apply (Ext A False); split; [ exact H | apply False_ind ].
Qed.

Require Import PropExtensionalityFacts.

Definition provable_prop_extensionality := forall A:Prop, A -> A = True.

Lemma provable_prop_ext :
prop_extensionality -> provable_prop_extensionality.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.provable_prop_ext".
exact PropExt_imp_ProvPropExt.
Qed.

Local Notation inhabited A := A (only parsing).

Lemma prop_ext_A_eq_A_imp_A :
prop_extensionality -> forall A:Prop, inhabited A -> (A -> A) = A.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.prop_ext_A_eq_A_imp_A".
intros Ext A a.
apply (Ext (A -> A) A); split; [ exact (fun _ => a) | exact (fun _ _ => a) ].
Qed.

Record retract (A B:Prop) : Prop :=
{f1 : A -> B; f2 : B -> A; f1_o_f2 : forall x:B, f1 (f2 x) = x}.

Lemma prop_ext_retract_A_A_imp_A :
prop_extensionality -> forall A:Prop, inhabited A -> retract A (A -> A).
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.prop_ext_retract_A_A_imp_A".
intros Ext A a.
rewrite (prop_ext_A_eq_A_imp_A Ext A a).
exists (fun x:A => x) (fun x:A => x).
reflexivity.
Qed.

Record has_fixpoint (A:Prop) : Prop :=
{F : (A -> A) -> A; Fix : forall f:A -> A, F f = f (F f)}.

Lemma ext_prop_fixpoint :
prop_extensionality -> forall A:Prop, inhabited A -> has_fixpoint A.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.ext_prop_fixpoint".
intros Ext A a.
case (prop_ext_retract_A_A_imp_A Ext A a); intros g1 g2 g1_o_g2.
exists (fun f => (fun x:A => f (g1 x x)) (g2 (fun x => f (g1 x x)))).
intro f.
pattern (g1 (g2 (fun x:A => f (g1 x x)))) at 1.
rewrite (g1_o_g2 (fun x:A => f (g1 x x))).
reflexivity.
Qed.

Definition proof_irrelevance := forall (A:Prop) (a1 a2:A), a1 = a2.

Section Proof_irrelevance_gen.

Variable bool : Prop.
Variable true : bool.
Variable false : bool.
Hypothesis bool_elim : forall C:Prop, C -> C -> bool -> C.
Hypothesis
bool_elim_redl : forall (C:Prop) (c1 c2:C), c1 = bool_elim C c1 c2 true.
Hypothesis
bool_elim_redr : forall (C:Prop) (c1 c2:C), c2 = bool_elim C c1 c2 false.
Let bool_dep_induction :=
forall P:bool -> Prop, P true -> P false -> forall b:bool, P b.

Lemma aux : prop_extensionality -> bool_dep_induction -> true = false.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.aux".
intros Ext Ind.
case (ext_prop_fixpoint Ext bool true); intros G Gfix.
set (neg := fun b:bool => bool_elim bool false true b).
generalize (eq_refl (G neg)).
pattern (G neg) at 1.
apply Ind with (b := G neg); intro Heq.
rewrite (bool_elim_redl bool false true).
change (true = neg true); rewrite Heq; apply Gfix.
rewrite (bool_elim_redr bool false true).
change (neg false = false); rewrite Heq; symmetry ;
apply Gfix.
Qed.

Lemma ext_prop_dep_proof_irrel_gen :
prop_extensionality -> bool_dep_induction -> proof_irrelevance.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.ext_prop_dep_proof_irrel_gen".
intros Ext Ind A a1 a2.
set (f := fun b:bool => bool_elim A a1 a2 b).
rewrite (bool_elim_redl A a1 a2).
change (f true = a2).
rewrite (bool_elim_redr A a1 a2).
change (f true = f false).
rewrite (aux Ext Ind).
reflexivity.
Qed.

End Proof_irrelevance_gen.

Section Proof_irrelevance_Prop_Ext_CC.

Definition BoolP := forall C:Prop, C -> C -> C.
Definition TrueP : BoolP := fun C c1 c2 => c1.
Definition FalseP : BoolP := fun C c1 c2 => c2.
Definition BoolP_elim C c1 c2 (b:BoolP) := b C c1 c2.
Definition BoolP_elim_redl (C:Prop) (c1 c2:C) :
c1 = BoolP_elim C c1 c2 TrueP := eq_refl c1.
Definition BoolP_elim_redr (C:Prop) (c1 c2:C) :
c2 = BoolP_elim C c1 c2 FalseP := eq_refl c2.

Definition BoolP_dep_induction :=
forall P:BoolP -> Prop, P TrueP -> P FalseP -> forall b:BoolP, P b.

Lemma ext_prop_dep_proof_irrel_cc :
prop_extensionality -> BoolP_dep_induction -> proof_irrelevance.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.ext_prop_dep_proof_irrel_cc".
exact (ext_prop_dep_proof_irrel_gen BoolP TrueP FalseP BoolP_elim BoolP_elim_redl
BoolP_elim_redr).
Qed.

End Proof_irrelevance_Prop_Ext_CC.

Section Proof_irrelevance_CIC.

Inductive boolP : Prop :=
| trueP : boolP
| falseP : boolP.
Definition boolP_elim_redl (C:Prop) (c1 c2:C) :
c1 = boolP_ind C c1 c2 trueP := eq_refl c1.
Definition boolP_elim_redr (C:Prop) (c1 c2:C) :
c2 = boolP_ind C c1 c2 falseP := eq_refl c2.
Scheme boolP_indd := Induction for boolP Sort Prop.

Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.ext_prop_dep_proof_irrel_cic".
exact (fun pe =>
ext_prop_dep_proof_irrel_gen boolP trueP falseP boolP_ind boolP_elim_redl
boolP_elim_redr pe boolP_indd).
Qed.

End Proof_irrelevance_CIC.

Require Import Hurkens.

Section Proof_irrelevance_EM_CC.

Variable or : Prop -> Prop -> Prop.
Variable or_introl : forall A B:Prop, A -> or A B.
Variable or_intror : forall A B:Prop, B -> or A B.
Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C.
Hypothesis
or_elim_redl :
forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A),
f a = or_elim A B C f g (or_introl A B a).
Hypothesis
or_elim_redr :
forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B),
g b = or_elim A B C f g (or_intror A B b).
Hypothesis
or_dep_elim :
forall (A B:Prop) (P:or A B -> Prop),
(forall a:A, P (or_introl A B a)) ->
(forall b:B, P (or_intror A B b)) -> forall b:or A B, P b.

Hypothesis em : forall A:Prop, or A (~ A).
Variable B : Prop.
Variables b1 b2 : B.

Let p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A).
Let b2p b := b1 = b.

Lemma p2p1 : forall A:Prop, A -> b2p (p2b A).
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.p2p1".
unfold p2b; intro A; apply or_dep_elim with (b := em A);
unfold b2p; intros.
apply (or_elim_redl A (~ A) B (fun _ => b1) (fun _ => b2)).
destruct (b H).
Qed.

Lemma p2p2 : b1 <> b2 -> forall A:Prop, b2p (p2b A) -> A.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.p2p2".
intro not_eq_b1_b2.
unfold p2b; intro A; apply or_dep_elim with (b := em A);
unfold b2p; intros.
assumption.
destruct not_eq_b1_b2.
rewrite <- (or_elim_redr A (~ A) B (fun _ => b1) (fun _ => b2)) in H.
assumption.
Qed.

Theorem proof_irrelevance_cc : b1 = b2.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.proof_irrelevance_cc".
refine (or_elim _ _ _ _ _ (em (b1 = b2))); intro H.
trivial.
apply (NoRetractFromSmallPropositionToProp.paradox B p2b b2p (p2p2 H) p2p1).
Qed.

End Proof_irrelevance_EM_CC.

Section Proof_irrelevance_WEM_CC.

Variable or : Prop -> Prop -> Prop.
Variable or_introl : forall A B:Prop, A -> or A B.
Variable or_intror : forall A B:Prop, B -> or A B.
Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C.
Hypothesis
or_elim_redl :
forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A),
f a = or_elim A B C f g (or_introl A B a).
Hypothesis
or_elim_redr :
forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B),
g b = or_elim A B C f g (or_intror A B b).
Hypothesis
or_dep_elim :
forall (A B:Prop) (P:or A B -> Prop),
(forall a:A, P (or_introl A B a)) ->
(forall b:B, P (or_intror A B b)) -> forall b:or A B, P b.

Hypothesis wem : forall A:Prop, or (~~A) (~ A).

Local Notation NProp := NoRetractToNegativeProp.NProp.
Local Notation El := NoRetractToNegativeProp.El.

Variable B : Prop.
Variables b1 b2 : B.

Let p2b (A:NProp) := or_elim (~~El A) (~El A) B (fun _ => b1) (fun _ => b2) (wem (El A)).
Let b2p b : NProp := exist (fun P=>~~P -> P) (~~(b1 = b)) (fun h x => h (fun k => k x)).

Lemma wp2p1 : forall A:NProp, El A -> El (b2p (p2b A)).
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.wp2p1".
intros A. unfold p2b.
apply or_dep_elim with  (b := wem (El A)).
+ intros nna a.
rewrite <- or_elim_redl.
cbn. auto.
+ intros n x.
destruct (n x).
Qed.

Lemma wp2p2 : b1 <> b2 -> forall A:NProp, El (b2p (p2b A)) -> El A.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.wp2p2".
intro not_eq_b1_b2.
intros A. unfold p2b.
apply or_dep_elim with  (b := wem (El A)).
+ cbn.
intros x _.
destruct A. cbn in x |- *.
auto.
+ intros na.
rewrite <- or_elim_redr. cbn.
intros h. destruct (h not_eq_b1_b2).
Qed.

Theorem wproof_irrelevance_cc : ~~(b1 = b2).
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.wproof_irrelevance_cc".
intros h.
unshelve (refine (let NB := exist (fun P=>~~P -> P) B _ in _)).
{ exact (fun _ => b1). }
pose proof (NoRetractToNegativeProp.paradox NB p2b b2p (wp2p2 h) wp2p1) as paradox.
unshelve (refine (let F := exist (fun P=>~~P->P) False _ in _)).
{ auto. }
exact (paradox F).
Qed.

End Proof_irrelevance_WEM_CC.

Section Proof_irrelevance_CCI.

Hypothesis em : forall A:Prop, A \/ ~ A.

Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C)
(a:A) : f a = or_ind f g (or_introl B a) := eq_refl (f a).
Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C)
(b:B) : g b = or_ind f g (or_intror A b) := eq_refl (g b).
Scheme or_indd := Induction for or Sort Prop.

Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.proof_irrelevance_cci".
exact (proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl
or_elim_redr or_indd em).
Qed.

End Proof_irrelevance_CCI.

Section Weak_proof_irrelevance_CCI.

Hypothesis wem : forall A:Prop, ~~A \/ ~ A.

Theorem wem_proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), ~~b1 = b2.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.wem_proof_irrelevance_cci".
exact (wproof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl
or_elim_redr or_indd wem).
Qed.

End Weak_proof_irrelevance_CCI.

Definition weak_excluded_middle :=
forall A:Prop, ~~A \/ ~A.

Definition weak_generalized_excluded_middle :=
forall A B:Prop, ((A -> B) -> B) \/ (A -> B).

Definition GodelDummett := forall A B:Prop, (A -> B) \/ (B -> A).

Lemma excluded_middle_Godel_Dummett : excluded_middle -> GodelDummett.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.excluded_middle_Godel_Dummett".
intros EM A B. destruct (EM B) as [HB|HnotB].
left; intros _; exact HB.
right; intros HB; destruct (HnotB HB).
Qed.

Definition RightDistributivityImplicationOverDisjunction :=
forall A B C:Prop, (C -> A\/B) -> (C->A) \/ (C->B).

Lemma Godel_Dummett_iff_right_distr_implication_over_disjunction :
GodelDummett <-> RightDistributivityImplicationOverDisjunction.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.Godel_Dummett_iff_right_distr_implication_over_disjunction".
split.
intros GD A B C HCAB.
destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC;
destruct (HCAB HC) as [HA|HB]; [ | apply HBA | apply HAB | ]; assumption.
intros Distr A B.
destruct (Distr A B (A\/B)) as [HABA|HABB].
intro HAB; exact HAB.
right; intro HB; apply HABA; right; assumption.
left; intro HA; apply HABB; left; assumption.
Qed.

Lemma Godel_Dummett_weak_excluded_middle :
GodelDummett -> weak_excluded_middle.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.Godel_Dummett_weak_excluded_middle".
intros GD A. destruct (GD (~A) A) as [HnotAA|HAnotA].
left; intro HnotA; apply (HnotA (HnotAA HnotA)).
right; intro HA; apply (HAnotA HA HA).
Qed.

Definition IndependenceOfGeneralPremises :=
forall (A:Type) (P:A -> Prop) (Q:Prop),
inhabited A -> (Q -> exists x, P x) -> exists x, Q -> P x.

Lemma
independence_general_premises_right_distr_implication_over_disjunction :
IndependenceOfGeneralPremises -> RightDistributivityImplicationOverDisjunction.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.IndependenceOfGeneralPremises".
intros IP A B C HCAB.
destruct (IP bool (fun b => if b then A else B) C true) as ([|],H).
intro HC; destruct (HCAB HC); [exists true|exists false]; assumption.
left; assumption.
right; assumption.
Qed.

Lemma independence_general_premises_Godel_Dummett :
IndependenceOfGeneralPremises -> GodelDummett.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.independence_general_premises_Godel_Dummett".
destruct Godel_Dummett_iff_right_distr_implication_over_disjunction.
auto using independence_general_premises_right_distr_implication_over_disjunction.
Qed.

Definition DrinkerParadox :=
forall (A:Type) (P:A -> Prop),
inhabited A -> exists x, (exists x, P x) -> P x.

Lemma independence_general_premises_drinker :
IndependenceOfGeneralPremises <-> DrinkerParadox.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.independence_general_premises_drinker".
split.
intros IP A P InhA; apply (IP A P (exists x, P x) InhA); intro Hx; exact Hx.
intros Drinker A P Q InhA H; destruct (Drinker A P InhA) as (x,Hx).
exists x; intro HQ; apply (Hx (H HQ)).
Qed.

Definition generalized_excluded_middle :=
forall A B:Prop, A \/ (A -> B).

Lemma excluded_middle_independence_general_premises :
generalized_excluded_middle -> DrinkerParadox.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.excluded_middle_independence_general_premises".
intros GEM A P x0.
destruct (GEM (exists x, P x) (P x0)) as [(x,Hx)|Hnot].
exists x; intro; exact Hx.
exists x0; exact Hnot.
Qed.

Require Import Coq.Arith.PeanoNat.

Definition Minimal (P:nat -> Prop) (n:nat) : Prop :=
P n /\ forall k, P k -> n<=k.

Definition Minimization_Property (P : nat -> Prop) : Prop :=
forall n, P n -> exists m, Minimal P m.

Section Unrestricted_minimization_entails_excluded_middle.

Hypothesis unrestricted_minimization: forall P, Minimization_Property P.

Theorem unrestricted_minimization_entails_excluded_middle : forall A, A\/~A.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.unrestricted_minimization_entails_excluded_middle".
intros A.
pose (P := fun n:nat => n=0/\A \/ n=1).
assert (P 1) as h.
{ unfold P. intuition. }
assert (P 0 <-> A) as p₀.
{ split.
+ intros [[_ h₀]|[=]]. assumption.
+ unfold P. tauto. }
apply unrestricted_minimization in h as ([|[|m]] & hm & hmm).
+ intuition.
+ right.
intros HA. apply p₀, hmm, PeanoNat.Nat.nle_succ_0 in HA. assumption.
+ destruct hm as [([=],_) | [=] ].
Qed.

End Unrestricted_minimization_entails_excluded_middle.

Require Import Wf_nat.

Section Excluded_middle_entails_unrestricted_minimization.

Hypothesis em : forall A, A\/~A.

Theorem excluded_middle_entails_unrestricted_minimization :
forall P, Minimization_Property P.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.excluded_middle_entails_unrestricted_minimization".
intros P n HPn.
assert (dec : forall n, P n \/ ~ P n) by auto using em.
assert (ex : exists n, P n) by (exists n; assumption).
destruct (dec_inh_nat_subset_has_unique_least_element P dec ex) as (n' & HPn' & _).
exists n'. assumption.
Qed.

End Excluded_middle_entails_unrestricted_minimization.

Section Example_of_undecidable_predicate_with_the_minimization_property.

Variable s : nat -> bool.

Let P n := exists k, n<=k /\ s k = true.

Example undecidable_predicate_with_the_minimization_property :
Minimization_Property P.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.undecidable_predicate_with_the_minimization_property".
unfold Minimization_Property.
intros h hn.
exists 0. split.
+ unfold P in *. destruct hn as (k&hk₁&hk₂).
exists k. split.
* rewrite <- hk₁.
apply PeanoNat.Nat.le_0_l.
* assumption.
+ intros **. apply PeanoNat.Nat.le_0_l.
Qed.

End Example_of_undecidable_predicate_with_the_minimization_property.

Require Import RelationClasses.

Local Notation representative_boolean_partition :=
(forall R:bool->bool->Prop,
Equivalence R -> exists f, forall x, R x (f x) /\ forall y, R x y -> f x = f y).

Theorem representative_boolean_partition_imp_excluded_middle :
representative_boolean_partition -> excluded_middle.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.representative_boolean_partition_imp_excluded_middle".
intros ReprFunChoice P.
pose (R (b1 b2 : bool) := b1 = b2 \/ P).
assert (Equivalence R).
{ split.
- now left.
- destruct 1. now left. now right.
- destruct 1, 1; try now right. left; now transitivity y. }
destruct (ReprFunChoice R H) as (f,Hf). clear H.
destruct (Bool.bool_dec (f true) (f false)) as [Heq|Hneq].
+ left.
destruct (Hf false) as ([Hfalse|HP],_); try easy.
destruct (Hf true) as ([Htrue|HP],_); try easy.
congruence.
+ right. intro HP.
destruct (Hf true) as (_,H). apply Hneq, H. now right.
Qed.

Theorem excluded_middle_imp_representative_boolean_partition :
excluded_middle -> representative_boolean_partition.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.excluded_middle_imp_representative_boolean_partition".
intros EM R H.
destruct (EM (R true false)).
- exists (fun _ => true).
intros []; firstorder.
- exists (fun b => b).
intro b. split.
+ reflexivity.
+ destruct b, y; intros HR; easy || now symmetry in HR.
Qed.

Theorem excluded_middle_iff_representative_boolean_partition :
excluded_middle <-> representative_boolean_partition.
Proof. hammer_hook "ClassicalFacts" "ClassicalFacts.excluded_middle_iff_representative_boolean_partition".
split; auto using excluded_middle_imp_representative_boolean_partition,
representative_boolean_partition_imp_excluded_middle.
Qed.


Require Import ZXCore.
From VyZX Require Import Proportional.

Local Open Scope ZX_scope.

(** Gate Definitions in the ZX Calculus *)

Notation "'_Z_'" := (Z 1 1 PI) (at level 40).
Notation "'_X_'" := (X 1 1 PI) (at level 40).
Definition _Rz_ α : ZX 1 1 := Z 1 1 α.

Notation "'_H_'" :=
    ((Z 1 1 (PI/2)) ⟷ (X 1 1 (PI/2)) ⟷ (Z 1 1 (PI/2)))
    (at level 40).

Notation "'_CNOT_'" :=
  ((Z 1 2 0 ↕ —) ⟷ (— ↕ X 2 1 0)).

Notation "'_CNOT_inv_'" := ((2 ↑ □) ⟷ _CNOT_ ⟷ (2 ↑ □)).

Notation "'_CNOT_R'" :=
  ((— ↕ X 1 2 0) ⟷ (Z 2 1 0 ↕ —)).

Notation "'_NOTC_'" :=
  ((— ↕ Z 1 2 0 ) ⟷ (X 2 1 0 ↕ —)).

Notation "'_NOTC_R'" :=
  ((X 1 2 0 ↕ —) ⟷ (— ↕ Z 2 1 0 )).

Notation "'_3_CNOT_SWAP_'" :=
  (_CNOT_ ⟷ _NOTC_ ⟷ _CNOT_).


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj20synthconj1_hyp: forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 lv2) (mult lv2 (Succ lv1))) ->  (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus (mult lv2 (Succ (plus Zero lv1))) (Succ (plus Zero lv1)))).
Admitted.
QuickChick conj20synthconj1_hyp.


(** ** Variables and terms with variables *)
(** Gianluca Amato,  Marco Maggesi, Cosimo Perini Brogi 2019-2021 *)
(**
Given a signature σ, a [varspec] (variable specification) is a map from an [hSet] of _variables_
to the corresponding sort. A signature σ and a variable specification [V] give origin to a new
signature, [vsignature σ V] where variables in [v] become constant symbols. A term over
signature σ and variables in V is, i.e., a [vterm σ v], is a plain (ground) term over this
extended signature.
*)

Require Import UniMath.Foundations.All.

Require Import UniMath.Algebra.Universal.SortedTypes.
Require Export UniMath.Algebra.Universal.Terms.

Local Open Scope sorted.

Section Variables.

  Definition varspec (σ: signature) := ∑ V: hSet, V → sorts σ.

  Definition make_varspec (σ: signature) (varsupp: hSet) (varsorts: varsupp → sorts σ)
    : varspec σ := (varsupp,, varsorts).

  Coercion varsupp {σ: signature}: varspec σ → hSet := pr1.

  Definition varsort {σ: signature} {V: varspec σ}: V → sorts σ := pr2 V.

  Definition vsignature (σ : signature) (V: varspec σ): signature
    := make_signature (sorts σ) (setcoprod (names σ) V) (sumofmaps (ar σ) (λ v, nil ,, varsort v)).

  Context {σ : signature}.

  Definition namelift (V: varspec σ) (nm: names σ): names (vsignature σ V) := inl nm.

  Definition varname {V: varspec σ} (v: V): names (vsignature σ V) := inr v.

  Definition term (σ: signature) (V: varspec σ): sUU (sorts σ) := gterm (vsignature σ V).

  Definition termset (σ: signature) (V: varspec σ): shSet (sorts σ) := gtermset (vsignature σ V).

  Definition build_term {V: varspec σ} (nm: names σ) (v: (term σ V)⋆ (arity nm))
    : term σ V (sort nm) := build_gterm (namelift V nm) v.

  Definition varterm {V: varspec σ} (v: V): term σ V (varsort v) := build_gterm (varname v) [()].

  Definition assignment {σ: signature} (A: sUU (sorts σ)) (V: varspec σ) : UU := ∏ v: V, A (varsort v).

  Definition build_term_curried {V: varspec σ} (nm: names σ)
    : iterfun (vec_map (term σ V) (pr2 (arity (namelift V nm)))) (term σ V (sort (namelift V nm)))
    := build_gterm_curried (namelift V nm).

  (** Evaluation maps for terms and corresponding unfolding properties *)

  Definition fromterm {A: sUU (sorts σ)} {V: varspec σ}
                      (op : (∏ nm : names σ, A⋆ (arity nm) → A (sort nm)))
                      (α : assignment A V)
    : term σ V s→ A.
  Proof.
    refine (@fromgterm (vsignature σ V) A _).
    induction nm as [nm | v].
    - exact (op nm).
    - exact (λ _, α v).
  Defined.

  Lemma fromtermstep {A: sUU (sorts σ)} {V: varspec σ}
                     (op : (∏ nm : names σ, A⋆ (arity nm) → A (sort nm)))
                     (α : assignment A V)
                     (nm: names σ) (v: (term σ V)⋆ (arity nm))
    : fromterm op α (sort nm) (build_term nm v) = op nm ((fromterm op α)⋆⋆ (arity nm) v).
  Proof.
    unfold fromterm, fromgterm, build_term.
    rewrite (term_ind_step _ _  (namelift V nm)).
    simpl.
    rewrite h2lower_h1map_h1lift.
    apply idpath.
  Defined.

  (** This used to be provable with apply idpath in the single sorted case **)
  Lemma fromtermstep' {A: sUU (sorts σ)} {V: varspec σ}
                      (op : (∏ nm : names σ, A⋆ (arity nm) → A (sort nm)))
                      (α : assignment A V)
                      (v: V)
    : fromterm op α (varsort v) (varterm v) = α v.
  Proof.
    unfold fromterm, fromgterm, varterm.
    rewrite (term_ind_step _ _ (varname v)).
    apply idpath.
  Defined.

End Variables.


Require Export Basics.

Require Export EnvListAux7.
Require Export EnvListAuxT1.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import Coq.Logic.ProofIrrelevance.

Require Import TPipStaticM2.
Require Import TPipDynamicM2.
Require Import TRInductM2.
Require Import WeakM2.
Require Import TSoundnessM2.
Require Import IdModType.
Require Import IdMod2.

Module TSoundness2 := TSoundness IdModM2.
Export TSoundness2.

Definition Id := TSoundness2.Id.
Definition IdEqDec := TSoundness2.IdEqDec.
Definition IdEq := TSoundness2.IdEq.
Definition W := TSoundness2.W.
Definition Loc_PI := TSoundness2.Loc_PI.
Definition BInit := TSoundness2.BInit.
Definition WP := TSoundness2.WP.

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

Lemma fenvTyping : FEnvTyping emptyE emptyE.
  constructor.
Defined.

Lemma envTyping : EnvTyping  emptyE emptyE.
  constructor.
Defined.

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

(* line 1 : if true then 3 else 3) *)

Definition three:Exp := Val(cst nat 3).
Definition truth:Exp := Val (cst bool true).
Definition line1:Exp := IfThenElse truth three three.
Lemma expTypingline1 : ExpTyping emptyE emptyE emptyE line1 Nat.
Proof.
repeat try (econstructor;auto).
Defined.

Definition line1Test (n: nat) :=  projT1 (sigT_of_sigT2
 (WellTypedEvalM emptyE emptyE emptyE line1 Nat
  expTypingline1 fenvTyping emptyE envTyping n)).

Lemma Test1 (n: nat) : line1Test n = cst nat 3.
auto.
Qed.

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

(* line 2 : apply add3 to 0*)

Open Scope string_scope.

Definition zero:Exp := Val(cst nat 0).

Definition xf_add3 : XFun nat nat := {|
   b_mod := fun st x => (2,2)
|}.
Definition add3':Exp := Modify nat nat NatV NatV xf_add3 (Var "x").
Definition add3:QFun := QF(FC emptyE [("x",Nat)] add3' zero "add3" 0).
Definition line2:Exp := Apply add3 (PS [zero]).

Lemma expTypingline2 : ExpTyping emptyE emptyE emptyE line2 Nat.
Proof.
repeat econstructor.
Defined.

Definition line2Test (n: nat) :=  projT1 (sigT_of_sigT2
 (WellTypedEvalM emptyE emptyE emptyE line2 Nat
  expTypingline2 fenvTyping emptyE envTyping n)).

Lemma Test2 (n: nat) : line2Test n = cst nat 3.
Admitted.

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

(* line 3 : BindN line1 line2*)

Definition line3:Exp := BindN line1 line2.
Lemma expTypingline3 : ExpTyping emptyE emptyE emptyE line3 Nat.
Proof.
econstructor.
eapply expTypingline1.
apply expTypingline2.
Defined.

Definition line3Test (n: nat) :=  projT1 (sigT_of_sigT2
 (WellTypedEvalM emptyE emptyE emptyE line3 Nat
  expTypingline3 fenvTyping emptyE envTyping n)).

Lemma Test3 (n: nat) : line3Test n = cst nat 3.
Admitted.

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

(* line 4 : BindN zero line1*)

Lemma expTypingzero : ExpTyping emptyE emptyE emptyE zero Nat.
Proof.
constructor.
constructor.
auto.
constructor.
Defined.

Definition line4:Exp := BindN zero line1.
Lemma expTypingline4 : ExpTyping emptyE emptyE emptyE line4 Nat.
Proof.
econstructor.
eapply expTypingzero.
apply expTypingline1.
Defined.

Definition line4Test (n: nat) :=  projT1 (sigT_of_sigT2
 (WellTypedEvalM emptyE emptyE emptyE line4 Nat
  expTypingline4 fenvTyping emptyE envTyping n)).

Lemma Test4 (n: nat) : line4Test n = cst nat 3.
auto.
Qed.

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

(*line 6 : if (Apply est_0 0) then zero else three*)

Definition xf_est_0 : XFun nat bool := {|
   b_mod := fun st x => (st,if beq_nat x 0 then true else false)
|}.
Definition est_0':Exp := Modify nat bool NatV BoolV xf_est_0 (Var "x").
Definition est_0:QFun := QF(FC emptyE [("x",Nat)] est_0' zero "est_0" 0).
Definition line6:Exp := IfThenElse (Apply est_0 (PS [zero])) zero three.

Lemma expTypingline6 : ExpTyping emptyE emptyE emptyE line6 Nat.
Proof.
repeat econstructor.
Defined.

Definition line6Test (n: nat) :=  projT1 (sigT_of_sigT2
 (WellTypedEvalM emptyE emptyE emptyE line6 Nat
  expTypingline6 fenvTyping emptyE envTyping n)).

Lemma Test6 (n: nat) : line6Test n = cst nat 0.
Admitted.

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

Definition ret_x : Exp := Return RR (Var "x").
Definition line7 : Exp := BindS "x" zero ret_x.
Lemma expTypingline7 : ExpTyping emptyE emptyE emptyE line7 Nat.
Proof.
econstructor.
constructor.
eapply expTypingzero.
repeat constructor.
Defined.

Definition line7Test (n: nat) :=  projT1 (sigT_of_sigT2
 (WellTypedEvalM emptyE emptyE emptyE line7 Nat
  expTypingline7 fenvTyping emptyE envTyping n)).

Lemma Test7 (n: nat) : line7Test n = cst nat 0.
auto.
Qed.