├── common
    ├── dot.coqrc
    ├── _CoqProject
    ├── test.v
    ├── ssrifcond.v
    ├── ssrclosure.v
    ├── ssrstring.v
    └── ssromega.v
├── bf
    ├── TODO.md
    ├── ssrstring.v
    ├── README.md
    └── ssrclosure.v
├── monad
    ├── Makefile
    └── ssr_cat_kleisli.v
├── ex2014
    ├── README.md
    ├── exa
    │   ├── Ternary.v
    │   └── TernaryProperties.v
    ├── ex19.v
    ├── ex13.v
    ├── ex43.v
    ├── ex42.v
    ├── ex41.v
    ├── ex42_2.v
    ├── ex10.v
    ├── ex38.v
    ├── ex32.v
    ├── ex31.v
    └── ex44_2.v
├── categories
    ├── Makefile
    ├── README.md
    └── Aw_2_1_EpicMinic.v
├── fp
    ├── ssrstring.v
    ├── ssr_test.v
    ├── ssrstar.v
    ├── ssr_cpl_1.md
    └── ssr_fp_2.md
├── intro
    ├── 1-2.v
    ├── 1-1.v
    └── 2.v
├── tools
    ├── coq-windows.el
    ├── coqv.pl
    ├── line-edit.pl
    └── mkmd.pl
├── jsst2014
    ├── ssr_jsst2014_finset_example.v
    └── ssr_jsst2014_eqtype_example.v
├── mp
    └── memo-proofcafe.txt
├── ssr2
    ├── ssr2_choice.v
    └── ch8.v
├── coq_classic_nnpp_eml.v
├── sms
    ├── README.md
    └── ssrclosure.v
├── math4
    ├── ssr_lean_like_even_odd.v
    ├── ssr_barber_paradox.v
    ├── ssr_fib_fibonacci_equiv.v
    ├── ssr_doubtimplication.v
    ├── ssr_inhabited.v
    └── ssr_root2_contrarian.v
├── secd
    └── ssrclosure.v
├── ssr
    ├── ssr_ooiseq.v
    ├── ssr_coq.v
    ├── ssr_diag.v
    ├── ssr_pigeonhole.v
    ├── ssr_zakky.v
    ├── ssr_fold_symmetric.v
    ├── ssr_set_a_a_b__b_qitta.v
    ├── ssr_well_founded.v
    ├── ssr_callcc_classic.v
    ├── ssr_set_a_a_b__b.v
    ├── ssr_state_monad.v
    ├── ssr_ais_6_1_4_rst_depth_first_search.v
    ├── ssr_mockbird_3.v
    └── ssr_phant_lang.v
├── pearl
    ├── ssr_lemmas.v
    └── ssr_ex_card.v
├── math
    └── ssr_multiset_coef_rising_fact.v
├── prog
    ├── coq_list.v
    ├── ssr_typed_interpreter.v
    ├── coq_sublist.v
    ├── coq_merger.v
    └── coq_m91function.v
├── math-comp-book
    ├── suhara.ch7-windrose.v
    ├── suhara.enum.v
    ├── suhara.ch6-finset.v
    ├── ssr_irrelevance.v
    ├── suhara.ch6-tuples-subtype.v
    ├── suhara.ch6.finset.v
    └── suhara.ch56.unit.v
├── coq_fixed_point.v
├── gitcrc
    ├── Mat.v
    └── coq_gitcrc_3_8_EMonoid.v
├── iii
    ├── ssr_coqt4.v
    ├── ssr_coqt3.v
    ├── ssr_transpose.v
    └── ssr_coqt7.v
├── pnp
    ├── ssr_cls_poset.v
    ├── ssr_htt_alter_x.v
    └── ssr_pnp_4_3_leqP.v
├── htpl
    └── htpi_existence_uniqueness.v
├── csm
    ├── README.md
    └── csm_5_set_theory_finset.v
├── coq_cps_fact.v
├── lisp
    └── ssr_string.v
├── coq_cps_len.v
├── coq_sumbool_2.v
├── gpt
    └── gpt_list_app_assoc.v
├── coq_sumbool_2_not_use_variable.v
├── coq_ex_sig_sumbool.v
├── coq_cps_fib.v
├── tcfm
    └── tcfm_category_1.v
├── coq_apply.v
├── elpi
    ├── coq_elpi_list.md
    ├── coq_elpi_tailrec.v
    └── coq_elpi_examples_memo.md
├── regexp
    └── ssr_regexp_ex152.v
├── alg
    └── rat_sample.v
├── coq_leibnitz_equality.v
├── coq_fib.v
├── rt
    └── coq_masc_maximum.v
├── coq_generalize_dependent.v
├── coq_set_func.v
├── coq_classical.v
└── coq__rec.v


/common/dot.coqrc:
--------------------------------------------------------------------------------
1 | (* .coqrc *)
2 | (* none *)
3 | (* END *)
4 | 


--------------------------------------------------------------------------------
/common/_CoqProject:
--------------------------------------------------------------------------------
 1 | -R /Users/suhara/WORK/coq/common common
 2 | ssrclosure.v
 3 | ssrifcond.v
 4 | ssrinv.v
 5 | ssrneg.v
 6 | ssromega.v
 7 | ssrstring.v
 8 | ssrsumint.v
 9 | ssrsumop.v
10 | 


--------------------------------------------------------------------------------
/bf/TODO.md:
--------------------------------------------------------------------------------
 1 | 
 2 | - 証明済みのプログラムを組み合わせて、プログラムを作る。
 3 | 
 4 | - lstack と rstack の [:: 0] と [::] を同一視できるようにする。
 5 | あるいは、エラーが発生するようにする。
 6 | 
 7 | - Parser を monadic ににする。
 8 | 
 9 | - input / output を ASCII Char. にする。
10 | 
11 | - output をリアルタイムにする。
12 | 
13 | 


--------------------------------------------------------------------------------
/monad/Makefile:
--------------------------------------------------------------------------------
 1 | OBJS = \
 2 | 	Notations.vo \
 3 | 	Categories.vo \
 4 | 	Functors.vo \
 5 | 	Isomorphisms.vo \
 6 | 	OppositeCategories.vo \
 7 | 	ProductCategories.vo \
 8 | 	SliceCategories.vo
 9 | 
10 | 
11 | all:	$(OBJS)
12 | 
13 | clean:;	rm -f *.vo *.glob
14 | 
15 | .SUFFIXES: .v .vo
16 | .v.vo:
17 | 	coqc ${.IMPSRC}
18 | 
19 | # END
20 | 


--------------------------------------------------------------------------------
/ex2014/README.md:
--------------------------------------------------------------------------------
 1 | # ex2014 について
 2 | 
 3 | @suharahiromichi 2014_05_30
 4 | 
 5 | qnighyさんの出題する「Coq演習2014」をあまり締切りを考慮せずに解いていきます。
 6 | 
 7 | http://qnighy.github.io/coqex2014/
 8 | 
 9 | 「課題中で指定されていないライブラリの利用自体はOK」
10 | を好意的に解釈して、全面的にSSReflectを使います。
11 | Standard Coqのautoに当たるタクティクス（タクティカル）も使用しますが、
12 | 出題の意図に反したライブラリは使わないように留意します。
13 | 
14 | 以上
15 | 


--------------------------------------------------------------------------------
/categories/Makefile:
--------------------------------------------------------------------------------
 1 | OBJS = \
 2 | 	Aw_0_Notations.vo \
 3 | 	Aw_1_3_Categories.vo \
 4 | 	Aw_1_4_Functors.vo \
 5 | 	Aw_1_5_Isomorphisms.vo \
 6 | 	Aw_1_6_1_ProductCategories.vo \
 7 | 	Aw_1_6_2_OppositeCategories.vo \
 8 | 	Aw_1_6_4_SliceCategories.vo \
 9 | 	Aw_2_1_EpicMinic.vo \
10 | 	Aw_2_2_InitialTerminal.vo \
11 | 	Aw_7_4_NaturalTransformations.vo
12 | 
13 | all:	$(OBJS)
14 | 
15 | clean:;	rm -f *.vo *.glob
16 | 
17 | .SUFFIXES: .v .vo
18 | .v.vo:
19 | 	coqc ${.IMPSRC}
20 | 
21 | # END
22 | 


--------------------------------------------------------------------------------
/common/test.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | Require Import ssromega.
 3 | Require Import ssrinv.
 4 | Require Import ssrneg.
 5 | 
 6 | Set Implicit Arguments.
 7 | Unset Strict Implicit.
 8 | Unset Printing Implicit Defensive.
 9 | (* Set Print All. *)
10 | 
11 | Goal forall (a b : nat), (a <= b) = false -> b < a.
12 | Proof.
13 |   move=> a b H1.
14 |   find_neg_hypo.
15 |   Check leqNgt : forall m n : nat, (m <= n) = ~~ (n < m).
16 |   Check ltnNge : forall m n : nat, (m < n) = ~~ (n <= m).
17 |   rewrite -ltnNge in H1.
18 |   Search _ (_ <= _).
19 |   done.
20 | Qed.
21 | 
22 | 


--------------------------------------------------------------------------------
/ex2014/exa/Ternary.v:
--------------------------------------------------------------------------------
 1 | (* Ternary.v *)
 2 | 
 3 | Delimit Scope tern_scope with tern.
 4 | 
 5 | Inductive tern := true | intermed | false.
 6 | 
 7 | Definition andt a b :=
 8 |   match a, b with
 9 |   | false, _ | _, false => false
10 |   | intermed, _ | _, intermed => intermed
11 |   | _, _ => true
12 |   end.
13 | 
14 | Notation "a && b" := (andt a b) : tern_scope.
15 | 
16 | Definition ort a b :=
17 |   match a, b with
18 |   | true, _ | _, true => true
19 |   | intermed, _ | _, intermed => intermed
20 |   | _, _ => false
21 |   end.
22 | 
23 | Notation "a || b" := (ort a b) : tern_scope.
24 | 
25 | (* end *)
26 | 


--------------------------------------------------------------------------------
/ex2014/exa/TernaryProperties.v:
--------------------------------------------------------------------------------
 1 | (* TernaryProperties.v *)
 2 | 
 3 | Require Import Ternary.
 4 | 
 5 | Lemma andt_assoc a b c : (a && (b && c) = (a && b) && c)%tern.
 6 | Proof.
 7 |   destruct a; destruct b; destruct c; reflexivity.
 8 | Qed.
 9 | 
10 | Lemma andt_comm a b : (a && b = b && a)%tern.
11 | Proof.
12 |   destruct a; destruct b; reflexivity.
13 | Qed.
14 | 
15 | Lemma ort_assoc a b c : (a || (b || c) = (a || b) || c)%tern.
16 | Proof.
17 |   destruct a; destruct b; destruct c; reflexivity.
18 | Qed.
19 | 
20 | Lemma ort_comm a b : (a || b = b || a)%tern.
21 | Proof.
22 |   destruct a; destruct b; reflexivity.
23 | Qed.
24 | 
25 | (* end *)
26 | 


--------------------------------------------------------------------------------
/bf/ssrstring.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | Require Import Ascii String.
 3 | Export Ascii String.
 4 | 
 5 | (**
 6 | https://coq.inria.fr/library/Coq.Strings.Ascii.html
 7 |  *)
 8 | (* Open Scope char_scope.                   (* "a" : ascii *) *)
 9 | Definition ascii_eqMixin := EqMixin Ascii.eqb_spec.
10 | Canonical ascii_eqType := EqType ascii ascii_eqMixin.
11 | 
12 | 
13 | (**
14 | https://coq.inria.fr/library/Coq.Strings.String.html
15 |  *)
16 | (* Open Scope string_scope.                    (* "a" : string *) *)
17 | Definition string_eqMixin := EqMixin String.eqb_spec.
18 | Canonical string_eqType := EqType string (EqMixin String.eqb_spec).
19 | 
20 | (* END *)
21 | 


--------------------------------------------------------------------------------
/fp/ssrstring.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | Require Import Ascii String.
 3 | Export Ascii String.
 4 | 
 5 | (**
 6 | https://coq.inria.fr/library/Coq.Strings.Ascii.html
 7 |  *)
 8 | (* Open Scope char_scope.                   (* "a" : ascii *) *)
 9 | Definition ascii_eqMixin := EqMixin Ascii.eqb_spec.
10 | Canonical ascii_eqType := EqType ascii ascii_eqMixin.
11 | 
12 | 
13 | (**
14 | https://coq.inria.fr/library/Coq.Strings.String.html
15 |  *)
16 | (* Open Scope string_scope.                    (* "a" : string *) *)
17 | Definition string_eqMixin := EqMixin String.eqb_spec.
18 | Canonical string_eqType := EqType string (EqMixin String.eqb_spec).
19 | 
20 | (* END *)
21 | 


--------------------------------------------------------------------------------
/intro/1-2.v:
--------------------------------------------------------------------------------
 1 | Require Import Div2.
 2 | Require Import Arith.
 3 | Require Import Omega.
 4 | 
 5 | Goal forall n : nat, div2 (S n) < S n.
 6 | Proof.
 7 |   intros n.
 8 |   (* Hintデータベースとしてarithを指定して、Resoluitonをする。 *)
 9 |   (* debug *) auto with arith.
10 | Qed.
11 |   
12 | Goal forall n : nat, div2 (S n) < S n.
13 | Proof.
14 |   intros n.  
15 |   (* 上記のautoと同内容を手動でおこなう例。 *)
16 |   Check lt_div2 : forall n : nat, 0 < n -> Nat.div2 n < n.
17 |   apply lt_div2.
18 |   Check Nat.lt_0_succ : forall n : nat, 0 < S n.
19 |   apply Nat.lt_0_succ.
20 | Qed.
21 |   
22 | Goal forall n : nat, div2 (S n) < S n.
23 | Proof.
24 |   intros n.  
25 |   apply lt_div2.
26 |   (* 0 < S n をプレスバーガー算術で解く。 *)
27 |   omega.
28 | Qed.
29 | 
30 | 


--------------------------------------------------------------------------------
/bf/README.md:
--------------------------------------------------------------------------------
 1 | Brainfuck (Brainf\*uck) の Small-Step semantics
 2 | -- または、もうひとつの Coq で書いた brainf\*ckインタプリタ
 3 | 
 4 | @suharahiromichi
 5 | 
 6 | 2019_10_26
 7 | c
 8 | 
 9 | 
10 | # 初めに
11 | 
12 | Small-Step semantics を定義して、それを使ってインタプリタを実行する。
13 | 実行の繰り返しには、[2.] がLtac の再帰呼び出しを使っていることに対して、
14 | 「do !」 つまり repeat タクティクで行っている。
15 | 
16 | 2個スタックのVMでの実装、すなわち Small-Step semantics は [3.] を参考にした。
17 | 
18 | Coqのコードは、全体的に [1.] の考え方に沿っている。
19 | 
20 | 
21 | # 参考
22 | 
23 | [1.] 坂口、Coqによる定理証明 Coqでスタック指向プログラミング、Stricter.org
24 | 
25 | [2.] Coqはチューリング完全 -- Ltacでbrainf*ckインタプリタを書いた
26 |      https://qiita.com/erutuf13/items/98f15cc7e74b0570c971
27 | 
28 | [3.] Cはチューリング完全だった
29 |      https://qiita.com/takl/items/6ffe14db22974b1f74ce
30 | 
31 | 以上
32 | 


--------------------------------------------------------------------------------
/ex2014/ex19.v:
--------------------------------------------------------------------------------
 1 | Require Import ssreflect.
 2 | 
 3 | (**
 4 | # 第4回 Curry-Howard対応/Churchエンコーディング
 5 | 
 6 | http://qnighy.github.io/coqex2014/ex4.html
 7 | 
 8 | ## 課題19 (種別:B / 締め切り : 2014/05/11)
 9 | 
10 | 帰納型を使わずにイコールを定義し、それが標準ライブラリのeqの定義と同値であることを証明せよ。
11 | *)
12 | 
13 | Parameter A : Set.
14 | 
15 | (**
16 | 帰納型を使わずにイコール(Eq)を定義する。
17 |  *)
18 | Definition Eq : A -> A -> Prop :=
19 |   fun (a b : A) =>
20 |     forall (P : A -> Prop), P a -> P b.
21 | 
22 | (**
23 | Eqか標準ライブラリのeq(=)の定義と同値であることを証明する。
24 | *)
25 | Lemma Eq_eq : forall x y, Eq x y <-> x = y.
26 | Proof.
27 |   move=> x y.
28 |   split.
29 |   (* Eq x y -> x = y *)
30 |     by apply.
31 |   (* x = y -> Eq x y *)
32 |   move=> H P.
33 |   by rewrite H.
34 | Qed.
35 | 
36 | (* END *)
37 | 


--------------------------------------------------------------------------------
/ex2014/ex13.v:
--------------------------------------------------------------------------------
 1 | Require Import ssreflect.
 2 | 
 3 | (**
 4 | # 第3回
 5 | 
 6 | http://qnighy.github.io/coqex2014/ex3.html
 7 | 
 8 | ## 課題13 (種別:B / 締め切り : 2014/05/04)
 9 | 
10 | 1. 自然数の定義を参考にして、正の整数をあらわすデータ型を帰納的に定義せよ。
11 | 2. 自然数の足し算の定義を参考にして、上で定義した正の整数に関する足し算を定義せよ。
12 | 3. 上で定義した足し算が結合的であることを証明せよ。
13 |  *)
14 | 
15 | Inductive pos : Set :=
16 | | SO
17 | | S of pos.
18 | 
19 | Fixpoint plus (n m : pos) : pos :=
20 |   match n with
21 |     | SO => S m
22 |     | S n' => S (plus n' m)
23 |   end.
24 | 
25 | Infix "+" := plus.
26 | 
27 | Theorem plus_assoc : forall n m p, n + (m + p) = (n + m) + p.
28 | Proof.
29 |   elim.                                     (* 一番左の数についての帰納法 *)
30 |     by [].
31 |   move=> p H m p0 /=.
32 |   by rewrite (H m p0).
33 | Qed.
34 | 
35 | (* END *)
36 | 


--------------------------------------------------------------------------------
/tools/coq-windows.el:
--------------------------------------------------------------------------------
 1 | ;; 
 2 | ;; ProofGneral に適したウィンドウを開く。
 3 | ;;
 4 | (global-set-key [f4] 'coq-windows)
 5 | 
 6 | (defun coq-windows-old ()
 7 |   "Setup Windows for Proof General"
 8 |   (interactive)
 9 |   (delete-other-windows)
10 |   (new-frame)
11 |   (other-frame 1)
12 |   (split-window-vertically)
13 |   (switch-to-buffer "*goals*")
14 |   (other-window 1)
15 |   (switch-to-buffer "*response*"))
16 | 
17 | (defun coq-windows ()
18 |   "Setup Windows for Proof General"
19 |   (interactive)
20 |   (toggle-frame-fullscreen)
21 |   (delete-other-windows)
22 |   (split-window-horizontally)
23 |   (other-window 1)
24 |   (switch-to-buffer "*goals*")
25 |   (split-window-vertically)
26 |   (other-window 1)
27 |   (switch-to-buffer "*response*")
28 |   (other-window 1))
29 | ;; end
30 | 


--------------------------------------------------------------------------------
/common/ssrifcond.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | Require Import ssromega.
 3 | 
 4 | Set Implicit Arguments.
 5 | Unset Strict Implicit.
 6 | Unset Printing Implicit Defensive.
 7 | 
 8 | (* ゴールと前提にある if式の条件で場合分けする。 *)
 9 | Ltac if_condition' :=
10 |   intros;
11 |   repeat match goal with
12 |          | [ |- context[if ?b then _ else _] ] =>
13 |            let H' := fresh in destruct b eqn: H'
14 |          | [ H : context[if ?b then _ else _] |- _ ] =>
15 |            let H' := fresh in destruct b eqn: H'
16 |          | _ => idtac
17 |          end.
18 | 
19 | Ltac if_condition :=
20 |   if_condition'; try done; ssromega.
21 | 
22 | (* Sample *)
23 | Goal forall m n, (if m < n then m else n) = (if n <= m then n else m).
24 | Proof.
25 |   if_condition.
26 | Qed.
27 | 
28 | (* END *)
29 | 


--------------------------------------------------------------------------------
/jsst2014/ssr_jsst2014_finset_example.v:
--------------------------------------------------------------------------------
 1 | Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq choice fintype.
 2 | Require Import finfun bigop finset.
 3 | 
 4 | Set Implicit Arguments.
 5 | Unset Strict Implicit.
 6 | Unset Printing Implicit Defensive.
 7 | 
 8 | Goal FinSet [ffun x : 'I_3 => true] = setT.
 9 | apply/setP => /= x.
10 | rewrite {1}SetDef.pred_of_setE /=.
11 | rewrite {1}/in_mem.
12 | rewrite {1}/mem.
13 | rewrite /=.
14 | rewrite ffunE.
15 | rewrite in_setT.
16 | done.
17 | Qed.
18 | 
19 | (* おまけ。 *)
20 | Goal [set: 'I_3] = setT.
21 | apply/setP.
22 | by case => /=.
23 | Qed.
24 | 
25 | Section finset_example.
26 | 
27 | Variable T : finType.
28 | Variables A B C : {set T}.
29 | 
30 | (* use setP *)
31 | Lemma exo20 : (A :&: B) :|: C = (A :|: C) :&: (B :|: C).
32 | Proof.
33 |   Search (_ :&: _ :|: _).
34 |   by rewrite setUIl.
35 | Qed.
36 | 
37 | End finset_example.
38 | 


--------------------------------------------------------------------------------
/mp/memo-proofcafe.txt:
--------------------------------------------------------------------------------
 1 | 1. 圏論を本格にやる
 2 | 1.1 A Gentle Introduction to Type Classes andmRelations in Coq の復習
 3 | 
 4 | 1.2 Awodeyの圏論
 5 | https://www.orecoli.com/entry/2016/02/27/221008         日本語解説
 6 | https://www.kyoritsu-pub.co.jp/book/b10003662.html      訳本
 7 | 
 8 | 1.3 Awodeyの圏論をCoq/Classで書いた
 9 | http://www.megacz.com/berkeley/coq-categories/
10 | http://git.megacz.com/coq-categories.git/
11 | 
12 | 
13 | 2. 圏論を軽くやる
14 | 5つの圏の定義とCoqによる実装
15 | https://mathlog.info/articles/2818
16 | Definition による定義。同値であることを証明したい。
17 | 
18 | 
19 | 
20 | 3.再帰のパターン（なんたらモーフィズム）
21 | 数学とプログラミングの境界、Haskell的かも
22 | https://scrapbox.io/haskell-shoen/Recursion_Schemes
23 | 
24 | - Catamorphism、Anamorphism、Hylomorphism
25 | https://github.com/suharahiromichi/coq/blob/master/fp/ssr_rec_pat_3.v
26 | 
27 | - 動的計画法
28 | https://github.com/suharahiromichi/coq/blob/master/fp/ssr_rec_pat_4_dp.v
29 | 
30 | 
31 | 
32 | *.参考
33 | https://coq.discourse.group/t/survey-of-category-theory-in-coq/371
34 | 
35 | **.CoqTokyo
36 | 
37 | 以上
38 | 


--------------------------------------------------------------------------------
/ssr2/ssr2_choice.v:
--------------------------------------------------------------------------------
 1 | From elpi Require Import elpi.
 2 | From HB Require Import structures.
 3 | From mathcomp Require Import all_ssreflect.
 4 | 
 5 | Set Implicit Arguments.
 6 | Unset Strict Implicit.
 7 | Unset Printing Implicit Defensive.
 8 | 
 9 | (**
10 | Coq/SSReflect の choiceType とは何か
11 | 
12 | http://www.a-k-r.org/d/2024-12.html#a2024_12_22
13 | *)
14 | 
15 | (**
16 | # choice operator を使う。
17 | *)
18 | Section a.
19 | 
20 |   Lemma ex8 : exists n, 2 < n.
21 |   Proof.
22 |     exists 8.
23 |     done.
24 |   Qed.
25 | 
26 |   Lemma ex42 : exists n, 2 < n.
27 |   Proof.
28 |     exists 42.
29 |     done.
30 |   Qed.
31 |   
32 |   Check @xchoose : forall (T : choiceType) (P : pred T), (exists x : T, P x) -> T.
33 | 
34 | (**
35 | ex8 からそれを満たす n を取り出す。それは ``2 < n`` である。
36 | *)
37 |   Goal 2 < xchoose ex8.
38 |   Proof.
39 |     by apply: xchooseP.
40 |   Qed.
41 |   
42 | (**
43 | ex8 と ex42 を満たす n は等しい。
44 | *)
45 |   Goal xchoose ex8 = xchoose ex42.
46 |   Proof.
47 |     by apply: eq_xchoose.
48 |   Qed.
49 | 
50 | End a.
51 | 
52 | (* END *)
53 | 


--------------------------------------------------------------------------------
/coq_classic_nnpp_eml.v:
--------------------------------------------------------------------------------
 1 | (* 二重否定除去と排中律の同値性 *)
 2 | (* Double negative elimination, Excluded Middle Low *)
 3 | 
 4 | 
 5 | Lemma NNPP_EML :
 6 |   (forall A, ~~A -> A) <-> (forall A B, (~B -> ~A) -> (A -> B)).
 7 | Proof.
 8 |   unfold not.
 9 |   split.
10 | 
11 | 
12 |   intros NNPP A B H0.
13 |   intros HA.
14 |   apply NNPP.
15 |   intros HnB.
16 |   apply H0.
17 |   apply HnB.
18 |   apply HA.
19 |   
20 |   intros HEM A.
21 |   Check (HEM ((A -> False) -> False) A).
22 |   apply (HEM ((A -> False) -> False) A).
23 |   intros HnA HnnA.
24 |   apply HnnA.
25 |   apply HnA.
26 | Qed.
27 | 
28 | 
29 | (* 模範回答 *)
30 | 
31 | 
32 | Lemma p10 :
33 |   (forall A, ~~A -> A) <-> (forall A B, (~B -> ~A) -> (A -> B)).
34 | Proof.
35 |   split.
36 |   
37 |   intros.
38 |   apply H.
39 |   intro.
40 |   elim (H0 H2).                             (* apply (H0 H2). *)
41 |   apply H1.
42 |   
43 |   intros.
44 |   apply (H True A).
45 |   intro.
46 |   intro.
47 |   elim H0.                                  (* apply H0. *)
48 |   apply H1.
49 |   apply I.
50 | Qed.
51 | 
52 | 
53 | (* END *)


--------------------------------------------------------------------------------
/fp/ssr_test.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | Require Import ssrstring.                   (* Ascii String *)
 3 | Require Import ssrstar.                     (* S-EXP *)
 4 | 
 5 | Set Implicit Arguments.
 6 | Unset Strict Implicit.
 7 | Unset Printing Implicit Defensive.
 8 | 
 9 | (**
10 | Backup's FP のインタプリタが書けないことの説明
11 | 
12 | ``Apply program object`` の実装において、
13 | Apply が program についての帰納法になる一方、
14 | ApplyInsret (iota) や ApplyAll (alpha) が object についての帰納法になる。
15 | 
16 | このような相互再帰は、Coq では許されないようである。
17 | *)
18 | 
19 | Fail Fixpoint test1 (a b : seq nat) {struct a} :=
20 |   match a with
21 |   | [::] => 0
22 |   | a1 :: a2 => test2 a2 b
23 |   end
24 | with test2 (a b : seq nat) {struct b}  :=
25 |   match b with
26 |   | [::] => 0
27 |   | b1 :: b2 => test1 a b2
28 |   end.
29 | 
30 | Program Fixpoint test1' (a b : seq nat) {size a} :=
31 |   match a with
32 |   | [::] => 0
33 |   | a1 :: a2 => test2' a2 b
34 |   end
35 | with test2' (a b : seq nat) {size b}  :=
36 |   match b with
37 |   | [::] => 0
38 |   | b1 :: b2 => test1' a b2
39 |   end.
40 | Obligations.
41 | 
42 | (* END *)
43 | 


--------------------------------------------------------------------------------
/sms/README.md:
--------------------------------------------------------------------------------
 1 | Tezos' Michelson small-setp semantics
 2 | 
 3 | # はじめに
 4 | 
 5 | Tezos' Michelson は、Big-Step で意味が与えられていますが([1.][2.])、
 6 | ここでは Small-Step の意味を考えてみようとおもいます。
 7 | 
 8 | Michelson は、型つきのスタック指向言語ですが、PostScript や HP電卓のRPNと比べて
 9 | 特徴的なのは *DIP* 命令です。
10 | 
11 | DIP命令は、DIP code: Runs code protecting the top of the stack. と定義されていて、
12 | スタックトップを残した状態で引数のコードを実行します([1.])。
13 | 
14 | ```
15 | :: 'b : 'A   ->   'b : 'C
16 |    iff   code :: [ 'A -> 'C ]
17 | 
18 | > DIP code / x : S  =>  x : S'
19 |     where    code / S  =>  S'
20 | ```
21 | 
22 | スタックトップの値をどこかに保存しておいて、引数のコードを実行し、元に戻す、
23 | 必要があります。これを実現するには（DIP命令がネストされることを考慮すると）、
24 | スタックがもうひとつ必要になることがわかります。
25 | 
26 | ここで示す Small-Step 定義は、コードスタック（継続スタック）と
27 | 値スタック（オペランドスタック）を使うものです([3.])。
28 | これに、UPPERスタックを加えたみっつのスタックで定義を考えてみます。
29 | 
30 | 
31 | # 文献
32 | 
33 | [1.] Michelson: the language of Smart Contracts in Tezos,
34 |      https://tezos.gitlab.io/master/whitedoc/michelson.html
35 | 
36 | [2.] https://gitlab.com/nomadic-labs/mi-cho-coq/tree/master/src/michocott
37 | 
38 | [3.] 坂口、Coqによる定理証明 Coqでスタック指向プログラミング、Stricter.org
39 | 
40 | 
41 | 以上
42 | 


--------------------------------------------------------------------------------
/math4/ssr_lean_like_even_odd.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | Lean 風の Even、Oddの定義と補題の証明
 3 | *)
 4 | From mathcomp Require Import all_ssreflect.
 5 | From mathcomp Require Import all_algebra.
 6 | 
 7 | Set Implicit Arguments.
 8 | Unset Strict Implicit.
 9 | Unset Printing Implicit Defensive.
10 | 
11 | Import GRing.Theory.         (* mulrA などを使えるようにする。 *)
12 | Open Scope ring_scope.       (* 環の四則演算を使えるようにする。 *)
13 | 
14 | Definition evenP (n : int) := exists (k : int), n = k * 2.
15 | Definition oddP (n : int) := exists k, n = (k * 2) + 1.
16 | 
17 | Lemma even_add m n : evenP m -> evenP n -> evenP (m + n).
18 | Proof.
19 | (**
20 | in Lean
21 | - have (k1 hk1)
22 | - have (k2 hk2)
23 | - calc m + n = 2 * k1 + n := by rw [hk2]
24 | --  _ = 2 * k1 + 2 * k2   := by rw [hk2]
25 | --  _ = 2 * (k1 + k2)     := by ring
26 | *)
27 |   case=> [k1 hk1].
28 |   case=> [k2 hk2].
29 |   exists (k1 + k2).
30 |   by rewrite hk1 hk2 mulrDl.
31 | Qed.
32 | 
33 | Lemma odd_even_add m n : oddP m -> evenP n -> oddP (m + n).
34 | Proof.
35 |   case=> [k1 hk1].
36 |   case=> [k2 hk2].
37 |   exists (k1 + k2).
38 |   by rewrite hk1 hk2 mulrDl addrAC.
39 | Qed.
40 | 
41 | (* END *)
42 | 


--------------------------------------------------------------------------------
/tools/coqv.pl:
--------------------------------------------------------------------------------
 1 | #! /usr/bin/perl
 2 | 
 3 | my @list = `opam list`;
 4 | 
 5 | $ocaml = "none";
 6 | $coq = "none";
 7 | $mathcomp = "none";
 8 | $alg_tac = "none";
 9 | $elpi = "none";
10 | $coq_elpi = "none";
11 | $hb = "none";
12 | 
13 | foreach $pkg (@list)
14 | {
15 |     if ($pkg =~ /^ocaml\s+(\S+)\s/)
16 |     {
17 |         $ocaml = $1;
18 |     }
19 |     elsif ($pkg =~ /^rocq\-core\s+(\S+)\s/)
20 |     {
21 |         $coq = $1;
22 |     }
23 |     elsif ($pkg =~ /^rocq-mathcomp-ssreflect\s+(\S+)\s/)
24 |     {
25 |         $mathcomp = $1;
26 |     }
27 |     elsif ($pkg =~ /^coq-mathcomp-algebra-tactics\s+(\S+)\s/)
28 |     {
29 |         $alg_tac = $1;
30 |     }
31 |     elsif ($pkg =~ /^elpi\s+(\S+)\s/)
32 |     {
33 |         $elpi = $1;
34 |     }
35 |     elsif ($pkg =~ /^rocq-elpi\s+(\S+)\s/)
36 |     {
37 |         $coq_elpi = $1;
38 |     }
39 |     elsif ($pkg =~ /^rocq-hierarchy-builder\s+(\S+)\s/)
40 |     {
41 |         $hb = $1;
42 |     }
43 | }
44 | 
45 | print "Coq:$coq, MathComp:$mathcomp\n";
46 | print "OCaml:$ocaml, Coq:$coq, MathComp:$mathcomp, Algebra Tactics:$alg_tac, ELPI:$elpi, HB:$hb\n";
47 | 
48 | # END
49 | 


--------------------------------------------------------------------------------
/bf/ssrclosure.v:
--------------------------------------------------------------------------------
 1 | Section Closure.
 2 |   
 3 |   (* SF Rel.v *)
 4 |   
 5 |   Definition relation (X : Type) := X -> X -> Prop.  
 6 |   
 7 |   Inductive refl_step_closure {X : Type} (R : relation X)  : X -> X -> Prop :=
 8 |   | rsc_refl  : forall (x : X), refl_step_closure R x x
 9 |   | rsc_step : forall (x y z : X),
10 |       R x y ->
11 |       refl_step_closure R y z ->
12 |       refl_step_closure R x z.
13 |   
14 |   Lemma rsc_R : forall {X : Type} (R : relation X) (x y : X),
15 |       R x y -> refl_step_closure R x y.
16 |   Proof.
17 |     intros X R x y r.
18 |     apply rsc_step with y.
19 |     apply r.
20 |     now apply rsc_refl.
21 |   Qed.
22 |   
23 |   Lemma rsc_trans : forall {X : Type} (R : relation X) (x y z : X),
24 |       refl_step_closure R x y ->
25 |       refl_step_closure R y z ->
26 |       refl_step_closure R x z.
27 |   Proof.
28 |     intros X R x y z.
29 |     intros HRxy HRyz.
30 |     induction HRxy as [|z' x y Rxy].
31 |     - now apply HRyz.
32 |     - apply (rsc_step R z' x z).
33 |       apply Rxy.
34 |       apply IHHRxy.
35 |       now apply HRyz.
36 |   Qed.
37 | 
38 | End Closure.
39 | 
40 | (* END *)
41 | 


--------------------------------------------------------------------------------
/common/ssrclosure.v:
--------------------------------------------------------------------------------
 1 | Section Closure.
 2 |   
 3 |   (* SF Rel.v *)
 4 |   
 5 |   Definition relation (X : Type) := X -> X -> Prop.  
 6 |   
 7 |   Inductive refl_step_closure {X : Type} (R : relation X)  : X -> X -> Prop :=
 8 |   | rsc_refl  : forall (x : X), refl_step_closure R x x
 9 |   | rsc_step : forall (x y z : X),
10 |       R x y ->
11 |       refl_step_closure R y z ->
12 |       refl_step_closure R x z.
13 |   
14 |   Lemma rsc_R : forall {X : Type} (R : relation X) (x y : X),
15 |       R x y -> refl_step_closure R x y.
16 |   Proof.
17 |     intros X R x y r.
18 |     apply rsc_step with y.
19 |     apply r.
20 |     now apply rsc_refl.
21 |   Qed.
22 |   
23 |   Lemma rsc_trans : forall {X : Type} (R : relation X) (x y z : X),
24 |       refl_step_closure R x y ->
25 |       refl_step_closure R y z ->
26 |       refl_step_closure R x z.
27 |   Proof.
28 |     intros X R x y z.
29 |     intros HRxy HRyz.
30 |     induction HRxy as [|z' x y Rxy].
31 |     - now apply HRyz.
32 |     - apply (rsc_step R z' x z).
33 |       apply Rxy.
34 |       apply IHHRxy.
35 |       now apply HRyz.
36 |   Qed.
37 | 
38 | End Closure.
39 | 
40 | (* END *)
41 | 


--------------------------------------------------------------------------------
/secd/ssrclosure.v:
--------------------------------------------------------------------------------
 1 | Section Closure.
 2 |   
 3 |   (* SF Rel.v *)
 4 |   
 5 |   Definition relation (X : Type) := X -> X -> Prop.  
 6 |   
 7 |   Inductive refl_step_closure {X : Type} (R : relation X)  : X -> X -> Prop :=
 8 |   | rsc_refl  : forall (x : X), refl_step_closure R x x
 9 |   | rsc_step : forall (x y z : X),
10 |       R x y ->
11 |       refl_step_closure R y z ->
12 |       refl_step_closure R x z.
13 |   
14 |   Lemma rsc_R : forall {X : Type} (R : relation X) (x y : X),
15 |       R x y -> refl_step_closure R x y.
16 |   Proof.
17 |     intros X R x y r.
18 |     apply rsc_step with y.
19 |     apply r.
20 |     now apply rsc_refl.
21 |   Qed.
22 |   
23 |   Lemma rsc_trans : forall {X : Type} (R : relation X) (x y z : X),
24 |       refl_step_closure R x y ->
25 |       refl_step_closure R y z ->
26 |       refl_step_closure R x z.
27 |   Proof.
28 |     intros X R x y z.
29 |     intros HRxy HRyz.
30 |     induction HRxy as [|z' x y Rxy].
31 |     - now apply HRyz.
32 |     - apply (rsc_step R z' x z).
33 |       apply Rxy.
34 |       apply IHHRxy.
35 |       now apply HRyz.
36 |   Qed.
37 | 
38 | End Closure.
39 | 
40 | (* END *)
41 | 


--------------------------------------------------------------------------------
/sms/ssrclosure.v:
--------------------------------------------------------------------------------
 1 | Section Closure.
 2 |   
 3 |   (* SF Rel.v *)
 4 |   
 5 |   Definition relation (X : Type) := X -> X -> Prop.  
 6 |   
 7 |   Inductive refl_step_closure {X : Type} (R : relation X)  : X -> X -> Prop :=
 8 |   | rsc_refl  : forall (x : X), refl_step_closure R x x
 9 |   | rsc_step : forall (x y z : X),
10 |       R x y ->
11 |       refl_step_closure R y z ->
12 |       refl_step_closure R x z.
13 |   
14 |   Lemma rsc_R : forall {X : Type} (R : relation X) (x y : X),
15 |       R x y -> refl_step_closure R x y.
16 |   Proof.
17 |     intros X R x y r.
18 |     apply rsc_step with y.
19 |     apply r.
20 |     now apply rsc_refl.
21 |   Qed.
22 |   
23 |   Lemma rsc_trans : forall {X : Type} (R : relation X) (x y z : X),
24 |       refl_step_closure R x y ->
25 |       refl_step_closure R y z ->
26 |       refl_step_closure R x z.
27 |   Proof.
28 |     intros X R x y z.
29 |     intros HRxy HRyz.
30 |     induction HRxy as [|z' x y Rxy].
31 |     - now apply HRyz.
32 |     - apply (rsc_step R z' x z).
33 |       apply Rxy.
34 |       apply IHHRxy.
35 |       now apply HRyz.
36 |   Qed.
37 | 
38 | End Closure.
39 | 
40 | (* END *)
41 | 


--------------------------------------------------------------------------------
/categories/README.md:
--------------------------------------------------------------------------------
 1 | 参考文献
 2 | =========================
 3 | 
 4 | # ConCaT
 5 | - Amokrane Saïbi
 6 | - http://www.lix.polytechnique.fr/coq/V8.2pl1/contribs/ConCaT.html
 7 | 
 8 | ## 主な技法
 9 | - Structre Setoid
10 | - Canonical Structure
11 | 
12 | 
13 | # Category Theory Library for Coq (coq-categories)
14 | - Adam Megacz <megacz@acm.org>
15 | - http://www.megacz.com/berkeley/coq-categories/
16 | 
17 | ## 主な技法
18 | - Class Category
19 | - Proper で setoid_rewriteする。
20 | - Program Insatance を使う。
21 | - Generalizable All Variables.
22 | 
23 | 
24 | # プログラマのための圏論の基礎
25 | - 池渕さん
26 | - http://www.iij-ii.co.jp/lab/techdoc/category/
27 | 
28 | ## 主な技法
29 | - Class Category
30 | - Instance
31 | 
32 | 
33 | # 代数的構造と Coq
34 | - Mathinkさん
35 | - http://www.mathink.net/program/coq_group.html
36 | 
37 | ## 主な技法
38 | - Structre Setoid、「:>」
39 | - Proper で rewrite
40 | 
41 | 
42 | # Coq で Setoid を作る。
43 | - Mathinkさん
44 | - http://www.mathink.net/program/coq_setoid.html
45 | 
46 | ## 主な技法
47 | - Structre Setoid、「:>」
48 | - Program Canonical Structure
49 | 
50 | 
51 | # A Gentle Introduction to Type Classes and Relations in Coq
52 | - Matthieu Sozeau ほか
53 | 
54 | ## 主な技法
55 | - Class Setoid
56 | - Proper で rewrite
57 | - Coercion
58 | 
59 | 以上
60 | 


--------------------------------------------------------------------------------
/math4/ssr_barber_paradox.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | 床屋のパラドックス
 3 | 
 4 | -------------------
 5 | 
 6 | Lean by Example の演習問題の「床屋のパラドックス」を解いてみます。
 7 | 
 8 | https://lean-ja.github.io/lean-by-example/Tutorial/Exercise/BarberParadox.html
 9 | *)
10 | 
11 | Search (_ <-> _).
12 | 
13 | From mathcomp Require Import all_ssreflect.
14 | 
15 | Set Implicit Arguments.
16 | Unset Strict Implicit.
17 | Unset Printing Implicit Defensive.
18 | 
19 | Section Barber.
20 | 
21 | (**
22 | ## Lean の演習問題の部分をCoqにする
23 | *)
24 | 
25 | (* 全体集合となる人々の集合 *)
26 | Variable Person : Type.
27 | 
28 | (* p さんが q さんの髭を剃るという述語 *)
29 | Variable shave : Person -> Person -> bool.
30 | 
31 | (* 床屋が存在するという仮定 *)
32 | Variable barber : Person.
33 | 
34 | (* 床屋の信念を仮定として表現したもの *)
35 | (*
36 | Variable policy : forall p : Person, (shave barber p <-> ~ shave p p).
37 | *)
38 | 
39 | (**
40 | ## 補題
41 | *)
42 | Lemma paradox (q : bool) : (q -> ~q) -> (~q -> q) -> False.
43 | Proof.
44 |   case: q => H1 H2.
45 |   - by case: H1.
46 |   - by case: H2.
47 | Qed.
48 | 
49 | (**
50 | ## 証明したいもの
51 |  *)
52 | Theorem nosuchbarber :
53 |   ~ (forall p : Person, shave barber p <-> ~ shave p p).
54 | Proof.
55 |   move/(_ barber).
56 |   case.
57 |   by apply: paradox.
58 | Qed.
59 | 
60 | End Barber.
61 | 
62 | (* END *)
63 | 


--------------------------------------------------------------------------------
/ssr/ssr_ooiseq.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | {0, 1}* のうち0の出現数が1の出現数の丁度2倍であるような列だけを集めた集合は、
 3 | S = SS | 00S1 | 1S00 | 0S1S0 | ε というCFGで書き表せることを証明せよ。
 4 | 
 5 | https://twitter.com/pi8027/status/476708668239384576
 6 | 
 7 | このCFDで生成される文字列の 0の数は 1の数の2倍であることを示す。
 8 | （これで、問題の趣旨に合っている？）
 9 | *)
10 | 
11 | Require Import ssreflect ssrnat ssrbool eqtype seq.
12 | 
13 | Inductive S : Set :=
14 | | ss of S & S
15 | | oosi of S
16 | | isoo of S
17 | | osiso of S
18 | | ε.
19 | 
20 | Fixpoint icount (l : S) : nat :=
21 |   match l with
22 |     | ss m n => (icount m) + (icount n)
23 |     | oosi m => (icount m).+1
24 |     | isoo m => (icount m).+1
25 |     | osiso m => (icount m).+1
26 |     | ε => 0
27 |   end.
28 | 
29 | Fixpoint ocount (l : S) : nat :=
30 |   match l with
31 |     | ss m n => (ocount m) + (ocount n)
32 |     | oosi m => (ocount m).+2
33 |     | isoo m => (ocount m).+2
34 |     | osiso m => (ocount m).+2
35 |     | ε => 0
36 |   end.
37 | 
38 | Goal forall l : S, (icount l).*2 = ocount l.
39 | Proof.
40 |   elim;
41 |   first                                     (* SS *)
42 |     (move=> l H l' H'; by rewrite /= doubleD H H');
43 |   last                                      (* ε *)
44 |     by [];
45 |   (move=> l H /=; by rewrite doubleS H).
46 | Qed.
47 | 
48 | (* END *)
49 | 


--------------------------------------------------------------------------------
/ssr/ssr_coq.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | Starndard Coq と SSReflect の証明の違い。
 3 | -----------------
 4 | 
 5 | 2014_06_12
 6 | @suharahiromichi
 7 | *)
 8 | 
 9 | (**
10 | # Standard Coq の場合
11 | *)
12 | Require Import Arith Omega.
13 | 
14 | Check le_lt_dec.
15 | (* : forall m n : nat, {m <= n} + {n < m} *)
16 | 
17 | Definition min' (m n :nat) :=
18 |   match le_lt_dec m n with
19 |     | left _ => m
20 |     | right _ => n
21 |   end.
22 | 
23 | Theorem le_min' : forall m n, m <= n -> min' m n = m.
24 | Proof.
25 |   intros m n ; unfold min'.
26 |   case (le_lt_dec m n); simpl.
27 |     trivial.
28 |   intros. omega.
29 | Qed.
30 | 
31 | (**
32 | # SSReflect の場合
33 | *)
34 | Require Import ssreflect ssrnat ssrbool eqtype.
35 | 
36 | Definition min'' m n :=
37 |   match m <= n with
38 |     | true => m
39 |     | false => n
40 |   end.
41 | 
42 | (**
43 | m < n はすでにboolである。
44 | 
45 | ssrnat.vに、
46 | Link to the legacy comparison predicates.
47 | として、leP と ltP が定義されている。
48 | *)
49 | Theorem le_min'' : forall m n, m <= n -> min'' m n = m.
50 | Proof.
51 |   move=> n p H.                             (* H は bool *)
52 |   rewrite /min''.
53 |   move/leP in H.                            (* H は Prop *)
54 |   have Hnp : n <= p by apply/leP.           (* Hnp は bool *)
55 |     by rewrite Hnp.
56 | Qed.
57 | 
58 | (* END *)
59 | 


--------------------------------------------------------------------------------
/ex2014/ex43.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | # 第9回 タクティックの定義と利用/停止性証明 (2014/06/08)
 3 | 
 4 | http://qnighy.github.io/coqex2014/
 5 | 
 6 | ## 課題43 (種別:B / 締め切り : 2014/06/22)
 7 | 
 8 | ゴールがandの連なった形であるとき、これをandの形になっている限りsplitし続けるタクティックを
 9 | 定義せよ。課題41と違い、and以外の形の場合はsplitしてはいけない。
10 | 
11 | *)
12 | 
13 | Ltac split_all :=
14 |   match goal with
15 |     | _ : _ |- _ /\ _
16 |       => split; split_all
17 |     | _ => idtac
18 |   end.
19 | 
20 | (* 以下は動作確認用 *)
21 | 
22 | Lemma bar :
23 |   forall P Q R S : Prop,
24 |     R -> Q -> P -> S -> (P /\ R) /\ (S /\ Q).
25 | Proof.
26 |   intros P Q R S H0 H1 H2 H3.
27 |   split_all.
28 |   - assumption.
29 |   - assumption.
30 |   - assumption.
31 |   - assumption.
32 | Qed.
33 | 
34 | Lemma baz :
35 |   forall P Q R S T : Prop,
36 |     R -> Q -> P -> T -> S -> P /\ Q /\ R /\ S /\ T.
37 | Proof.
38 |   intros P Q R S T H0 H1 H2 H3 H4.
39 |   split_all.
40 |   - assumption.
41 |   - assumption.
42 |   - assumption.
43 |   - assumption.
44 |   - assumption.
45 | Qed.
46 | 
47 | Lemma quux :
48 |   forall P Q : Type, P -> Q -> P * Q.
49 | Proof.
50 |   intros P Q H0 H1.
51 |   split_all.
52 |   split.
53 |   - assumption.
54 |   - assumption.
55 | Qed.
56 | 
57 | (*
58 | ヒント
59 | 
60 | match goal with ... end 構文を使いましょう。この構文の使い方についてはマニュアルの9章の文法
61 | 定義を追うのがよいかと思います。*)
62 | 
63 | (* END *)
64 | 


--------------------------------------------------------------------------------
/pearl/ssr_lemmas.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | Mathcomp 知らないと使えない補題たち (Proof Pearl ##5)
 3 | ======
 4 | 2019/05/08
 5 | 
 6 | この文書のソースコードは以下にあります。
 7 | 
 8 | 
 9 | https://github.com/suharahiromichi/coq/blob/master/pearl/ssr_lemmas.v
10 | 
11 |  *)
12 | 
13 | (**
14 | # 説明
15 | 
16 | *)
17 | 
18 | From mathcomp Require Import all_ssreflect.
19 | 
20 | Set Implicit Arguments.
21 | Unset Strict Implicit.
22 | Unset Printing Implicit Defensive.
23 | (* Set Printing All. *)
24 | 
25 | (**
26 | # eqE eqbE eqnE eqseqE
27 | *)
28 | 
29 | Lemma test1 : forall n, n.+1.+1 + 1 == n.+2 + 1.
30 | Proof.
31 |   move=> n.
32 |   rewrite !eqE /= -eqE.
33 |   done.
34 | Qed.
35 | 
36 | (**
37 | # eqP
38 |  *)
39 | 
40 | Lemma test2 : forall n m, n == m -> n.+1.+1 + 1 = m.+2 + 1.
41 | Proof.
42 |   move=> n m H.
43 |   Check eqP H.
44 |   rewrite (eqP H).
45 |   done.
46 | Qed.
47 | 
48 | (**
49 | # eqP ifP
50 |  *)
51 | 
52 | Lemma test4 : forall (n m : nat), if n == m then true else true.
53 | Proof.
54 |   move=> n m.
55 |   case: ifP => H.
56 |   Undo 1.
57 |   case: eqP => H.
58 |   - done.
59 |   - done.
60 | Qed.
61 | 
62 | (**
63 | # inE memE topredE
64 |  *)
65 | 
66 | (* rewrite inE *)
67 | 
68 | 
69 | (**
70 | # ffunP setP
71 |  *)
72 | 
73 | Lemma test5 : forall (s1 s2 : {set bool}), s1 = s2.
74 | Proof.
75 |   move=> s1 s2.
76 |   apply/setP.
77 |   move=> x.
78 | Admitted.
79 | 
80 | (* END *)
81 | 


--------------------------------------------------------------------------------
/math/ssr_multiset_coef_rising_fact.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | Require Import ssromega.
 3 | Require Import ssr_multiset_coefficient.
 4 | Require Import ssr_rising_fact.
 5 | 
 6 | Set Implicit Arguments.
 7 | Unset Strict Implicit.
 8 | Unset Printing Implicit Defensive.
 9 | (* Set Print All. *)
10 | 
11 | Section RFACT_MC.
12 |   
13 |   Lemma msc_small (m : nat) : 0 < m -> 'H(0, m) = 0. (* notu *)
14 |   Proof.
15 |     by case: m.
16 |   Qed.
17 |   
18 |   Lemma msc_rfact (n m : nat) : 'H(n, m) * m`! = n ^^ m.
19 |   Proof.
20 |     elim: m n => [| m IHm] n.
21 |     - by rewrite msc0 mul1n.
22 |     - rewrite factS mulnA ['H(n, m.+1) * m.+1]mulnC.
23 |       rewrite -mul_msc_diag -mulnA.
24 |         by rewrite IHm.
25 |   Qed.
26 |   
27 |   Lemma msc_rfactd n m : 'H(n, m) = (n ^^ m) %/ m`!.
28 |   Proof.
29 |       by rewrite -msc_rfact mulnK ?fact_gt0.
30 |   Qed.
31 |   
32 |   (* 別証明 *)
33 |   (* ffact に変換して証明する。 *)
34 |   
35 |   Lemma msc_rfactd' n m : 'H(n, m) = (n ^^ m) %/ m`!.  
36 |   Proof.
37 |     move: n m => [[| m] | n m] .
38 |     - done.                                 (* n,m = 0,0 *)
39 |     - rewrite msc0n.                        (* n,m = 0,m.+1 *)
40 |       rewrite rfact0n /=.
41 |         by rewrite div0n.
42 |     - by rewrite rfact_ffact msc_ffactd.    (* n,m = n.+1,m+1 *)
43 |   Qed.
44 | 
45 | End RFACT_MC.
46 | 
47 | (* END *)
48 | 


--------------------------------------------------------------------------------
/ssr/ssr_diag.v:
--------------------------------------------------------------------------------
 1 | (** 対角線論法の証明 *)
 2 | 
 3 | From mathcomp Require Import all_ssreflect.
 4 | 
 5 | Set Implicit Arguments.
 6 | Unset Strict Implicit.
 7 | Import Prenex Implicits.
 8 | 
 9 | Axiom Excluded_Middle : forall (P : Prop), P \/ ~P. (* 排中律 *)
10 | Axiom Absurd : forall (P : Prop), ~ P /\ P -> False.
11 | 
12 | Section DIAG.
13 |   Variable φ : nat -> nat -> bool.         (* 自己参照1 *)
14 |   
15 |   Definition diag (n : nat) : bool := ~~ φ n n. (* 対角線関数 *)
16 |   
17 |   Goal exists (g : nat -> bool),
18 |       forall (n : nat), φ n <> g. (* 自己参照2 *)
19 |   Proof.
20 |     exists diag.
21 |     move=> n Hc.
22 |     case: (Excluded_Middle (φ n n = diag n)).
23 |     (* φ n n = diag n -> False *)
24 |     (* diag をその定義で展開する。 *)
25 |     - rewrite /diag => H1.
26 |       by case H2 : (φ n n); rewrite H2 in H1.
27 |     (* φ n n <> diag n -> False *)
28 |     (* diag をHcで展開する。 *)
29 |     - by rewrite Hc.
30 |   Qed.
31 |   
32 |   Goal exists (g : nat -> bool),
33 |       forall (n : nat), φ n <> g. (* 自己参照2 *)
34 |   Proof.
35 |     exists diag.
36 |     move=> n Hc.
37 |     apply: (@Absurd (φ n n = diag n)).
38 |     split.
39 |     - rewrite /diag => H1.
40 |       by case H2 : (φ n n); rewrite H2 in H1.
41 |     - by rewrite Hc.
42 |   Qed.
43 |   
44 |   (* refine ((_ : φ n n <> diag n) (_ : φ n n = diag n)). *)
45 |   (* absurd (F n n = diag F n). *)
46 | End DIAG.
47 | 
48 | (* END *)
49 | 


--------------------------------------------------------------------------------
/prog/coq_list.v:
--------------------------------------------------------------------------------
 1 | Require Import Omega.
 2 | Require Import List.
 3 | Require Import Arith.
 4 | Require Import Program.
 5 | 
 6 | Set Implicit Arguments.
 7 | 
 8 | Section List.
 9 |   Variable A : Type.
10 |   
11 |   (* l <> [] は Obligationに必要 *)
12 |   Program Definition hd (l : list A | l <> []) :
13 |     { a : A | exists l', a :: l' = l } :=
14 |     match l with
15 |     | [] => !
16 |     | a :: l' => a
17 |     end.
18 |   Obligation 2.
19 |   Proof.
20 |     now exists l'.
21 |   Defined.
22 | 
23 |   Program Definition tl (l : list A | l <> []) :
24 |     { l' : list A | exists a, a :: l' = l } :=
25 |     match l with
26 |     | [] => !
27 |     | a :: l' => l'
28 |     end.
29 |   Obligation 2.
30 |   Proof.
31 |     now exists a.
32 |   Defined.
33 | 
34 | End List.
35 | 
36 | Definition data : { l : list nat | l <> [] }.
37 | Proof.
38 |   now exists [1; 2].
39 | Defined.
40 | 
41 | Compute ` (hd data).                        (* 1 *)
42 | Compute ` (tl data).                        (* [2] *)
43 | 
44 | Extraction hd.                        (** val hd : 'a1 list -> 'a1 **)
45 | (*
46 | let hd = function
47 | | Nil -> assert false (* absurd case *)
48 | | Cons (a, _) -> a
49 | *)
50 | 
51 | Extraction tl.                   (** val tl : 'a1 list -> 'a1 list **)
52 | (*
53 | let tl = function
54 | | Nil -> assert false (* absurd case *)
55 | | Cons (_, l') -> l'
56 | *)
57 | 
58 | (* END *)
59 | 


--------------------------------------------------------------------------------
/ex2014/ex42.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | # 第9回 タクティックの定義と利用/停止性証明 (2014/06/08)
 3 | 
 4 | http://qnighy.github.io/coqex2014/
 5 | 
 6 | ## 課題42 (種別:A / 締め切り : 2014/06/15)
 7 | 
 8 | 自然数におけるlog関数(底は2)を以下のテンプレートに従って定義せよ。
 9 | テンプレートを改変しているので、このままで応募してはいけない。
10 | *)
11 | 
12 | Require Import Arith.
13 | Require Import Omega.
14 | Require Import Recdef.
15 | 
16 | (* 定理としてどこかにあると思うのだが。 *)
17 | (* http://www.cse.chalmers.se/research/group/logic/TypesSS05/resources/coq/CoqArt/gen-rec/SRC/chap15.v *)
18 | Theorem lt_Acc : forall n:nat, Acc lt n.
19 | Proof.
20 |  induction n.
21 |  split; intros p H; inversion H.
22 |  split. 
23 |  intros y H0.
24 |  case (le_lt_or_eq _ _ H0).
25 |  intro; apply Acc_inv with n; auto with arith.
26 |  intro e; injection e; intro e1; rewrite e1; assumption. 
27 | Qed.
28 | 
29 | Function log(n:nat) {wf lt n} :=
30 |   if le_lt_dec n 1 then
31 |     0
32 |   else
33 |     S (log (Div2.div2 n)).
34 | Proof.
35 |   intros.
36 |   Search (Div2.div2 _ < _).
37 |   Check Div2.lt_div2.
38 |   apply Div2.lt_div2.
39 |   omega.
40 |   Search well_founded.
41 |   unfold well_founded.
42 |   apply lt_Acc.
43 | Qed.
44 | 
45 | (*
46 | ヒント
47 | 
48 | Fixpointでは構造に基づく帰納法しか書けませんでした。Coqが自動的に停止性を判断できないような
49 | 関数の定義をするために、Functionコマンドが用意されています。停止性はwf (パラメーターのうち
50 | の1つが整礎的な関係に従って降下していくことを示す) または measure (パラメーターのうちの1つ
51 | に自然数の重みを定める関数があり、再帰呼び出しはこの重みが減る方向に進むということを示す)
52 | の2つの方法があります。
53 | 
54 | *)
55 | 
56 | (* END *)
57 | 


--------------------------------------------------------------------------------
/math-comp-book/suhara.ch7-windrose.v:
--------------------------------------------------------------------------------
 1 | (* 7. Hierarchies *)
 2 | (* 7.5 Linking a custom data type to the library *)
 3 | 
 4 | From mathcomp Require Import all_ssreflect.
 5 | 
 6 | (* Inductive windrose : Type := N | S | E | W. *)
 7 | Inductive windrose : predArgType := N | S | E | W.
 8 | 
 9 | Definition w2o (w : windrose) : 'I_4 :=
10 |   match w with
11 |   | N => inord 0
12 |   | S => inord 1
13 |   | E => inord 2
14 |   | W => inord 3
15 |   end.
16 | 
17 | Definition o2w (o : 'I_4) : option windrose :=
18 |   match val o with
19 |   | 0 => Some N
20 |   | 1 => Some S
21 |   | 2 => Some E
22 |   | 3 => Some W
23 |   | _ => None
24 |   end.
25 | 
26 | Lemma pcan_wo4 : pcancel w2o o2w.
27 | Proof.
28 |     by case; rewrite /o2w /= inordK.
29 | Qed.
30 | 
31 | Definition windrose_eqMixin := PcanEqMixin pcan_wo4.
32 | Canonical windrose_eqType := EqType windrose windrose_eqMixin.
33 | Definition windrose_choiceMixin := PcanChoiceMixin pcan_wo4.
34 | Canonical windrose_choiceType := ChoiceType windrose windrose_choiceMixin.
35 | Definition windrose_countMixin := PcanCountMixin pcan_wo4.
36 | Canonical windrose_countType := CountType windrose windrose_countMixin.
37 | Definition windrose_finMixin := PcanFinMixin pcan_wo4.
38 | Canonical windrose_finType := FinType windrose windrose_finMixin.
39 | 
40 | (* predArgType にしないとエラーになる。 *)
41 | Check (N != S) && (N \in windrose) && (#| windrose | == 4).
42 | 
43 | (* END *)
44 | 


--------------------------------------------------------------------------------
/math4/ssr_fib_fibonacci_equiv.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | From mathcomp Require Import ssrZ zify ring lra.
 3 | 
 4 | (**
 5 | 普通の定義
 6 | *)
 7 | Fixpoint fibonacci n :=
 8 |   match n with
 9 |   | 0 => 0
10 |   | 1 => 1
11 |   | (m.+1 as pn).+1 => fibonacci m + fibonacci pn
12 |   end.
13 | 
14 | Lemma fibonacci_add n : fibonacci n + fibonacci n.+1 = fibonacci n.+2.
15 | Proof.
16 |   done.
17 | Qed.
18 | 
19 | (**
20 | 高速計算版
21 | *)
22 | Fixpoint loop n :=
23 |   match n with
24 |   | 0 => (0, 1)
25 |   | m.+1 => let: p := loop m in (p.2, p.1 + p.2)
26 |   end.
27 | Definition fib n := (loop n).1.
28 | 
29 | Goal [seq fib x | x <- [:: 0; 1; 2; 3; 4; 5]] = [:: 0; 1; 1; 2; 3; 5].
30 | Proof.
31 |   done.
32 | Qed.
33 | 
34 | Lemma fib_add n : fib n + fib n.+1 = fib n.+2.
35 | Proof.
36 |   by rewrite /fib /loop.
37 | Qed.
38 | 
39 | (**
40 | 普通の定義と高速計算版が同じ結果を返すことを証明する。
41 | *)
42 | Lemma fibonacci_equiv : fibonacci =1 fib.
43 | Proof.
44 |   move=> m.
45 |   case: (ubnPgeq m);
46 |     elim: m => [n | n IHn [// | [// |]] m H].
47 |   - by rewrite leqn0 => /eqP ->.
48 |   - rewrite -fib_add -fibonacci_add.
49 |     congr (_ + _); apply: IHn; lia.
50 | Qed.
51 | 
52 | (**
53 | MathComp風、完全帰納法の結果：
54 | 
55 |   n : nat
56 |   IHn : forall n0 : nat, n0 <= n -> fibonacci n0 = fib n0
57 |   m : nat
58 |   H : m.+1 < n.+1
59 |   ============================
60 |   fibonacci m.+2 = fib m.+2
61 | *)
62 | 
63 | (* END *)
64 | 


--------------------------------------------------------------------------------
/coq_fixed_point.v:
--------------------------------------------------------------------------------
 1 | (*
 2 |    固定小数点演算の検証
 3 |    その、はじめの一歩
 4 |    *)
 5 | 
 6 | 
 7 | Require Import ZArith.
 8 | Open Scope Z_scope.
 9 | 
10 | 
11 | Inductive FP (n:nat) :=
12 | | mkFP : Z -> FP n.
13 | 
14 | 
15 | Check mkFP 2 7.
16 | Eval cbv in mkFP 2 7.
17 | 
18 | 
19 | Definition FP_body (n : nat) : FP n -> Z.
20 | Proof.
21 |   intros.
22 |   inversion H.
23 |   exact H0.
24 | Defined.
25 | Check FP_body.
26 | Implicit Arguments FP_body.
27 | Eval cbv in FP_body (mkFP 2 7).
28 | 
29 | 
30 | Definition FP_add (n : nat) : FP n -> FP n -> FP n.
31 | Proof.
32 |   intros n H1 H2.
33 |   inversion H1 as [H11].
34 |   inversion H2 as [H12].
35 |   apply (mkFP n (H11 + H12)).
36 | Defined.
37 | Implicit Arguments FP_add.
38 | Check FP_add.
39 | Eval cbv in FP_add (mkFP 2 7) (mkFP 2 7).
40 | 
41 | 
42 | Definition FP_mult_2 (n : nat) : FP n -> FP n.
43 | Proof.
44 |   intros n H1.
45 |   inversion H1 as [H11].
46 |   apply (mkFP n (2 * H11)).
47 | Defined.
48 | Implicit Arguments FP_mult_2.
49 | Check FP_mult_2.
50 | Eval cbv in FP_mult_2 (mkFP 2 7).
51 | 
52 | 
53 | Lemma eq_FP : forall x y n, x = y -> mkFP n x = mkFP n y.
54 | Proof.
55 |   intros.
56 |   rewrite H.
57 |   reflexivity.
58 | Qed.
59 | 
60 | 
61 | Lemma add_mult_FP : forall n (x : FP n), FP_add x x = FP_mult_2 x.
62 | Proof.
63 |   intros n x.
64 |   inversion x.
65 |   case x.
66 |   intros z.
67 |   unfold FP_add.
68 |   unfold FP_mult_2.
69 |   apply eq_FP.
70 |   ring.
71 | Qed.
72 | 
73 | 
74 | (* END *)


--------------------------------------------------------------------------------
/gitcrc/Mat.v:
--------------------------------------------------------------------------------
 1 | (* Require Export Ring. *)
 2 | Set Implicit Arguments. 
 3 | Section mat.                                (* matrices. *)
 4 |   Variables (A:Type)
 5 |             (zero one : A) 
 6 |             (plus mult minus : A -> A -> A)
 7 |             (sym : A -> A).
 8 |   Notation "0" := zero.  Notation "1" := one.
 9 |   Notation "x + y" := (plus x y).  
10 |   Notation "x * y " := (mult x y).
11 |   
12 |   
13 |   Structure M2 : Type := {c00 : A;  c01 : A;
14 |                           c10 : A;  c11 : A}.
15 |   
16 |   
17 |   Definition Zero2 : M2 := Build_M2 0 0 0 0.
18 |   Definition Id2 : M2 := Build_M2  1 0 0 1.
19 |   
20 |   Definition M2_mult (m m':M2) : M2 :=
21 |     Build_M2 (c00 m * c00 m' + c01 m * c10 m')
22 |              (c00 m * c01 m' + c01 m * c11 m')
23 |              (c10 m * c00 m' + c11 m * c10 m')
24 |              (c10 m * c01 m' + c11 m * c11 m').
25 |   
26 |   
27 |   Definition M2_plus (m m' : M2) : M2 :=
28 |     @Build_M2 (c00 m + c00 m')
29 |               (c01 m + c01 m')
30 |               (c10 m + c10 m')
31 |               (c11 m + c11 m').
32 |   
33 |   Lemma M2_eq_intros :
34 |     forall m m':M2, c00 m = c00 m' ->
35 |                     c01 m = c01 m' ->
36 |                     c10 m = c10 m' ->
37 |                     c11 m = c11 m' -> m = m'.
38 |     destruct m;destruct m';simpl.
39 |     intros H H1 H2 H3;rewrite H ,H1, H2, H3;trivial.
40 |   Qed.
41 | End mat.                                    (* matrices. *)
42 | 
43 | 
44 | 


--------------------------------------------------------------------------------
/fp/ssrstar.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | 
 3 | Set Implicit Arguments.
 4 | Unset Strict Implicit.
 5 | Unset Printing Implicit Defensive.
 6 | 
 7 | Inductive star (T : Type) : Type :=
 8 | | S_NIL
 9 | | S_ATOM of T
10 | | S_CONS of star T & star T.
11 | 
12 | Fixpoint eqStar {T : eqType} (x y : star T) : bool :=
13 |   match (x, y) with
14 |   | (S_NIL, S_NIL) => true
15 |   | (S_ATOM a, S_ATOM b) => (a == b :> T)   (* eqType *)
16 |   | (S_CONS x1 y1, S_CONS x2 y2) => eqStar x1 x2 && eqStar y1 y2
17 |   | _ => false
18 |   end.
19 | 
20 | Lemma eqCons {T : eqType} (x y x' y' : star T) :
21 |   (x = x' /\ y = y') -> @S_CONS T x y = @S_CONS T x' y'.
22 | Proof.
23 |   case=> Hx Hy.
24 |     by rewrite Hx Hy.
25 | Qed.
26 | 
27 | Lemma star_eqP (T : eqType) (x y : star T) : reflect (x = y) (eqStar x y).
28 | Proof.
29 |   apply: (iffP idP).
30 |   - elim: x y.
31 |     + by elim.
32 |     + move=> x'.
33 |       elim=> y //=.
34 |         by move/eqP => <-.
35 |     + move=> x Hx y Hy.
36 |       elim=> //=.
37 |       move=> x' IHx y' IHy /andP.
38 |       case=> Hxx' Hyy'.
39 |       apply: eqCons.
40 |       split.
41 |       * by apply: (Hx x').
42 |       * by apply: (Hy y').
43 |   -  move=> <-.
44 |      elim: x => //=.
45 |      * move=> x Hx y' Hy /=.
46 |          by apply/andP; split.
47 | Qed.
48 | 
49 | Definition star_eqMixin (T : eqType) := EqMixin (@star_eqP T).
50 | Canonical star_eqType (T : eqType) := EqType (star T) (star_eqMixin T).
51 | 
52 | Arguments S_NIL [T].
53 | 
54 | (* END *)
55 | 


--------------------------------------------------------------------------------
/iii/ssr_coqt4.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | プログラミング Coq --- 自然数を扱う
 3 | 
 4 | http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt4.html
 5 | をSSReflectに書き直した。
 6 | *)
 7 | 
 8 | Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
 9 | 
10 | Set Implicit Arguments.
11 | Unset Strict Implicit.
12 | Unset Printing Implicit Defensive.
13 | Set Print All.
14 | 
15 | Goal forall (n : nat), n = n + 0.
16 | Proof.
17 |   by [].
18 | Qed.
19 | 
20 | Goal forall (n : nat),
21 |        (exists m : nat, n = m * 4) -> exists k : nat, n = k * 2.
22 | Proof.
23 |   move=> n.
24 |   elim=> m H.               (* 仮定の H : exists m : nat, n = m * 4 を H : n = x * 4 に *)
25 |   exists (m * 2).           (* サブゴールの exists に x * 2 を与える *)
26 |   by rewrite -mulnA.        (* x * 2 * 2 を x * (2 * 2) に *)
27 | Qed.
28 | 
29 | Theorem lt_Snm_nm : forall (n m : nat), S n < m -> n < m.
30 | Proof.
31 |   move=> n m H.
32 |   Check @ltn_trans n.
33 |   apply: (@ltn_trans (S n)).                (* 最初の引数が m < n < p の n  *)
34 |   + by apply ltnSn.
35 |   + by [].
36 | Qed.
37 | 
38 | (* 前回の答え *)
39 | 
40 | Theorem rev_involute : forall (A : Type)(l : seq A), rev (rev l) = l.
41 | Proof.
42 |   move=> A.
43 |   elim=> [//= | a l IHl].
44 |   rewrite -cat1s 2!rev_cat.
45 |   by rewrite IHl.
46 | Qed.
47 | 
48 | Theorem fold_right_app : forall (A B : Type) (f : B -> A -> A) (l l' : seq B) (i : A),
49 |       foldr f i (l ++ l') = foldr f (foldr f i l') l.
50 | Proof.
51 |   move=> A B f l l' i.
52 |   elim: l => [//= | a l IHl /=].
53 |   by congr (f a _).
54 | Qed.
55 | 
56 | (* END *)
57 | 


--------------------------------------------------------------------------------
/ex2014/ex41.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | # 第9回 タクティックの定義と利用/停止性証明 (2014/06/08)
 3 | 
 4 | http://qnighy.github.io/coqex2014/
 5 | 
 6 | ## 課題41 (種別:A / 締め切り : 2014/06/15)
 7 | 
 8 | splitを試し、成功したら生成された全てのサブゴールで再帰的に
 9 | splitを試し続けるタクティックを定義せよ。
10 | *)
11 | 
12 | Ltac split_all :=
13 |   try (split; split_all); idtac.
14 | 
15 | (* 以下は動作確認用 *)
16 | 
17 | Lemma bar :
18 |   forall P Q R S : Prop,
19 |     R -> Q -> P -> S -> (P /\ R) /\ (S /\ Q).
20 | Proof.
21 |   intros P Q R S H0 H1 H2 H3.
22 |   split_all.
23 |   - assumption.
24 |   - assumption.
25 |   - assumption.
26 |   - assumption.
27 | Qed.
28 | 
29 | Lemma baz :
30 |   forall P Q R S T : Prop,
31 |     R -> Q -> P -> T -> S -> P /\ Q /\ R /\ S /\ T.
32 | Proof.
33 |   intros P Q R S T H0 H1 H2 H3 H4.
34 |   split_all.
35 |   - assumption.
36 |   - assumption.
37 |   - assumption.
38 |   - assumption.
39 |   - assumption.
40 | Qed.
41 | 
42 | Lemma quux :
43 |   forall P Q : Type, P -> Q -> P * Q.
44 | Proof.
45 |   intros P Q H0 H1.
46 |   split_all.
47 |   - assumption.
48 |   - assumption.
49 | Qed.
50 | 
51 | Record foo := {
52 |   x : (False -> False) /\ True /\ (False -> False);
53 |   y : True;
54 |   z : (False -> False) /\ True
55 | }.
56 | 
57 | Lemma hogera : foo.
58 | Proof.
59 |   split_all.
60 |   - intros H; exact H.
61 |   - intros H; exact H.
62 |   - intros H; exact H.
63 | Qed.
64 | 
65 | (**
66 | ヒント
67 | 
68 | マニュアルの8章はタクティック集、9章はタクティック言語の文法など、
69 | 10章は3つの発展的なタクティックの詳細です。これらが一次資料です。
70 | 
71 | Ltac はタクティックの再帰的定義ができます。
72 | つまり、定義されたタクティックの中で自分自身を呼ぶことができます。
73 | try タクティカルを使いましょう。
74 | *)
75 | 
76 | (* END *)
77 | 


--------------------------------------------------------------------------------
/math-comp-book/suhara.enum.v:
--------------------------------------------------------------------------------
 1 | (* 4.1 enum: 値の列挙 に関連して *)
 2 | 
 3 | From mathcomp Require Import all_ssreflect.
 4 | 
 5 | (* mem_pred の引数は T ではないようだ。 *)
 6 | Definition enum_mem' T (mA : mem_pred _) := filter mA (Finite.EnumDef.enum T).
 7 | 
 8 | (*
 9 | Definition enum' A := (enum_mem' _ (mem A)).
10 | これはエラーになる。「_」に A を書いてはいけない。
11 |  *)
12 | Notation enum' A := (enum_mem' _ (mem A)).
13 | 
14 | Check enum_mem' : forall T : finType, mem_pred T -> seq T.
15 | (*
16 | Check enum' : forall A : finType, seq A.
17 | *)
18 | 
19 | Compute enum bool_finType.
20 | Compute enum (ordinal_finType 3).
21 | 
22 | Check (enum_mem (mem [:: false])).
23 | Check enum [:: false].
24 | 
25 | Compute enum' bool_finType.
26 | Compute enum' (ordinal_finType 3).
27 | 
28 | Check (enum_mem' _ (mem [:: false])).
29 | Check enum' [:: false].
30 | 
31 | (* END *)
32 | 
33 | (* #|T| = size (enum T) *)
34 | Lemma cardT : forall A : finType, card (mem A) = size (enum A).
35 | Proof.
36 |   move=> A.
37 |   by rewrite cardE.
38 | Qed.
39 | 
40 | Check @inord 4 3 : 'I_5.
41 | Check inord 3 : 'I_5.
42 | 
43 | (* ord_enum の定義について *)
44 | Definition ord_enum (n : nat) : seq 'I_n := pmap insub (iota 0 n).
45 | Check ord_enum 5.
46 | 
47 | Check @insub : forall (T : Type) (P : pred T) (sT : subType (T:=T) P), T -> option sT.
48 | Check (fun i => i < 3) : pred nat.
49 | 
50 | Definition test (n : nat) : option 'I_n :=
51 |   @insub nat (fun i => i < n) (ordinal_subType n) n.
52 | Definition test' (n : nat) : option 'I_n := insub n.
53 | 
54 | Print test.
55 | Check test 3. (* option 'I_3. *)
56 | 
57 | (* END *)
58 | 


--------------------------------------------------------------------------------
/pnp/ssr_cls_poset.v:
--------------------------------------------------------------------------------
 1 | Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
 2 | Require Import fintype finfun finset.
 3 | 
 4 | Set Implicit Arguments.
 5 | Unset Strict Implicit.
 6 | Unset Printing Implicit Defensive.
 7 | 
 8 | Module POSETDef.
 9 |   Class POSET (T : Type) :=
10 |     Mixin
11 |       {
12 |         rel_op : T -> T -> bool;
13 |         refl (x : T) : rel_op x x;
14 |         asym (x y : T) : rel_op x y -> rel_op y x -> x = y;
15 |         trans (y x z : T) : rel_op x y -> rel_op y z -> rel_op x z
16 |       }.
17 |   Notation "x <== y" := (rel_op x y) (at level 70, no associativity).
18 | End POSETDef.  
19 | Export POSETDef.
20 | 
21 | Section NatPosetExamples.
22 |   Check leqnn : forall n : nat, n <= n.
23 |   Lemma eqn_leq' : forall m n, m <= n -> n <= m -> m = n.
24 |   Proof.
25 |     move=> m n.
26 |     elim: m n => [|m IHm] [|n] //.
27 |       move=> H1 H2; congr (_ .+1); move: H1 H2.
28 |       by apply (IHm n).
29 |   Qed.
30 |   Check leq_trans : forall n m p : nat, m <= n -> n <= p -> m <= p.
31 |   
32 |   Instance natPOSET : POSET nat :=
33 |     {
34 |     (* *** *)
35 |     }.
36 |   Proof.
37 |     by apply leqnn.
38 |     by apply eqn_leq'.
39 |     by apply leq_trans.
40 |   Qed.
41 |   
42 |   Variables x y z : nat.
43 |   
44 |   Goal x <== x.
45 |   Proof.
46 |     by apply: refl.
47 |   Qed.
48 | 
49 |   Goal x <== y -> y <== x -> x = y.
50 |   Proof.
51 |     by apply: asym.
52 |   Qed.
53 |   
54 |   Goal x <== y -> y <== z -> x <== z.
55 |   Proof.
56 |     by apply: trans.
57 |   Qed.
58 | End NatPosetExamples.
59 | 
60 | (* END *)
61 | 


--------------------------------------------------------------------------------
/htpl/htpi_existence_uniqueness.v:
--------------------------------------------------------------------------------
 1 | Section ExistsUnique.
 2 | 
 3 |   Variables (A : Type) (P : A -> Prop).
 4 |   
 5 |   (*                
 6 | Example 3.6.1
 7 | 
 8 | 1. ∃x(P(x) ∧ ∀y(P(y) → y = x))                (= ∃!x P(x))
 9 | 2. ∃x∀y(P(y) ↔ y = x).
10 | 3. ∃x P(x) ∧ ∀y∀z((P(y) ∧ P(z)) → y = z).
11 |    *)
12 |   
13 |   (* 1 -> 2 *)
14 |   Goal (exists ! x, P x) -> (exists x, forall y, P y <-> x = y).
15 |   Proof.
16 |     unfold unique.
17 |     intros.
18 |     destruct H as [x0].
19 |     destruct H as [H1 H2].
20 |     (* Givens and Goal p.147 *)
21 |     exists x0.
22 |     intros.
23 |     split.
24 |     - now apply H2.
25 |     - intros Hx0y.
26 |       now rewrite <- Hx0y.
27 |   Qed.
28 |   
29 |   (* 2 -> 3 *)
30 |   Goal (exists x, forall y, P y <-> x = y) ->
31 |   (exists x, P x /\ (forall y z, P y /\ P z -> y = z)).
32 |   Proof.
33 |     intros.
34 |     destruct H as [x0].
35 |     exists x0.
36 |     split.
37 |     - destruct (H x0).
38 |       now apply H1.
39 |     - intros y z [H1 H2].
40 |       (* Givens and Goal p.148 *)
41 |       destruct (H y) as [H3 H4].
42 |       destruct (H z) as [H5 H6].
43 |       now rewrite <- H3, <- H5.
44 |   Qed.
45 |   
46 |   (* 3 -> 1 *)
47 |   Goal (exists x, P x /\ (forall y z, P y /\ P z -> y = z)) ->
48 |   (exists ! x, P x).
49 |   Proof.
50 |     unfold unique.
51 |     intros H.
52 |     destruct H as [x0].
53 |     destruct H as [H1 H2].
54 |     exists x0.
55 |     (* Givens and Goal p.148 *)
56 |     split.
57 |     - easy.
58 |     - intros y H3.
59 |       now apply (H2 x0 y).
60 |   Qed.
61 |   
62 | End ExistsUnique.
63 | 


--------------------------------------------------------------------------------
/csm/README.md:
--------------------------------------------------------------------------------
  1 | # 2章 使ってみよう
  2 | 
  3 | csm_2_2_modusponens.v
  4 | 
  5 | csm_2_3_hilbert_s.v
  6 | 
  7 | csm_2_4_natural_number.v
  8 | 
  9 | csm_2_5_logic.v
 10 | 
 11 | 
 12 | # 3章 命令
 13 | 
 14 | csm_3_4_case.v
 15 | 
 16 | csm_3_5_elim.v
 17 | 
 18 | csm_3_6_3_simpl.v
 19 | 
 20 | csm_3_7_view.v
 21 | 
 22 | csm_3_9_definition.v
 23 | 
 24 | - Recordを使ったマグマの形式化
 25 | 
 26 | csm_3_15_magma_2.v
 27 | 
 28 | - カノニナル宣言も使う
 29 | 
 30 | csm_ex_3_no_answer.v
 31 | 
 32 | 
 33 | # 4章 MathCompライブラリの基本ファイル
 34 | 
 35 | csm_4_1_ssrbool.v
 36 | 
 37 | csm_4_2_eqtype.v
 38 | 
 39 | csm_4_3_ssrnat.v
 40 | 
 41 | - ``n == 0`` や ``0 <= n`` ``0 < n`` に関連する補足説明
 42 | 
 43 | csm_4_3_x_eq0.v
 44 | 
 45 | csm_4_4_seq.v
 46 | 
 47 | - リストの最初の要素と最後の要素の扱い
 48 | 
 49 | csm_4_4_x_seq_head_last.v
 50 | 
 51 | csm_4_5_fintype.v
 52 | 
 53 | csm_4_6_bigop.v
 54 | 
 55 | - 自然数の割り算 ``div.v``
 56 | 
 57 | csm_4_a_div.v
 58 | 
 59 | 
 60 | # 5章 集合の形式化
 61 | 
 62 | csm_5_set_theory.v
 63 | 
 64 | csm_5_set_theory_axiom.v
 65 | 
 66 | csm_5_set_theory_class_prop.v
 67 | 
 68 | - ``mySet M := M -> bool`` で定義した例
 69 | 
 70 | csm_5_set_theory_class.v
 71 | 
 72 | csm_5_set_theory_finset.v
 73 | 
 74 | csm_5_set_theory_fintype.v
 75 | 
 76 | 
 77 | # 6章 代数学の形式化
 78 | 
 79 | csm_6_1_ztoring.v
 80 | 
 81 | csm_6_1_ztoring_new.v
 82 | 
 83 | csm_6_1_ztoring_not_canonical.v
 84 | 
 85 | csm_6_2_1_fingroup.v
 86 | 
 87 | csm_6_2_from_mathcomp_intro.v
 88 | 
 89 | csm_6_2_lagrange.v
 90 | 
 91 | - 3次対称群
 92 | 
 93 | csm_6_2_x_permutation.v
 94 | 
 95 | 
 96 | # 7章 確率論と情報理論の形式化
 97 | 
 98 | csm_7_2_expected_value_variance.v
 99 | 
100 | 以上
101 | 


--------------------------------------------------------------------------------
/ssr/ssr_pigeonhole.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | SSReflectによる鳩の巣原理の証明
 3 | ======
 4 | 
 5 | @suharahiromichi
 6 | 
 7 | 
 8 | プログラミング Coq 自然数を扱う
 9 | http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt4.html
10 | 
11 | 
12 | で解説されている鳩の巣原理の証明をSSReflectに移してみました。
13 | 証明の内容はまったく同じなので、比べるとおもしろいとおもいます。
14 |  *)
15 | 
16 | Require Import ssreflect ssrbool ssrnat seq.
17 | 
18 | Lemma lt_S_n : forall (n m : nat), S n < S m -> n < m.
19 | Proof.
20 |   by [].
21 | Qed.
22 | 
23 | Lemma lt_Snm_nm : forall (n m : nat), S n < m -> n < m.
24 | Proof.
25 |   move=> n m.
26 |   by apply (@ltn_trans n.+1 n m).
27 | Qed.
28 | 
29 | Inductive InList (A : Type)(a : A) : list A -> Prop :=
30 | | headIL : forall xs, InList A a (a::xs)                     (* 1 *)
31 | | consIL : forall x xs, InList A a xs -> InList A a (x::xs). (* 2 *)
32 | 
33 | Theorem pigeonhole : forall (xs : list nat),
34 |                        size xs < foldr plus 0 xs ->
35 |                        exists x : nat, InList nat x.+2 xs.
36 | Proof.
37 |   elim.
38 |   (* xs = [] の場合 *)
39 |     by [].
40 |   (* xs = x :: xs' の場合 *)
41 |   elim.
42 |     (* a = 0 の場合 *)
43 |     move=> xs IHxs H; apply lt_Snm_nm, IHxs in H.
44 |     by elim: H => x; exists x; constructor.
45 | 
46 |   elim.
47 |     (* a = 1 の場合 *)
48 |     move=> _ xs IHxs H; apply lt_S_n, IHxs in H.
49 |     by elim: H => x; exists x; constructor.
50 | 
51 |   (* a >= 2 の場合 *)
52 |   move=> a.
53 |   by exists a; constructor.
54 | Qed.
55 | 
56 | (**
57 | 注意：「ソフトウェアの基礎」の練習問題とは、異なるので注意してください。
58 | 
59 | http://proofcafe.org/sf/Logic_J.
60 |  *)
61 | 
62 | (* $Id: ssr_pigeonhole.v,v 1.21 2014/04/30 04:25:03 suhara Exp suhara $ *)
63 | 


--------------------------------------------------------------------------------
/ex2014/ex42_2.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | # 第9回 タクティックの定義と利用/停止性証明 (2014/06/08)
 3 | 
 4 | http://qnighy.github.io/coqex2014/
 5 | 
 6 | ## 課題42 (種別:A / 締め切り : 2014/06/15)
 7 | 
 8 | 自然数におけるlog関数(底は2)を以下のテンプレートに従って定義せよ。
 9 | テンプレートを改変しているので、このままで応募してはいけない。
10 | *)
11 | 
12 | Require Import ssreflect ssrbool ssrnat div eqtype.
13 | Require Import Recdef.
14 | 
15 | (*
16 | Require Import Arith.
17 | Require Import Omega.
18 | Require Import Recdef.
19 | *)
20 | 
21 | Require Import Lt.
22 | 
23 | (* http://gcg00467.xii.jp/wp/archives/891 *)
24 | (* http://www.cse.chalmers.se/research/group/logic/TypesSS05/resources/coq/CoqArt/gen-rec/SRC/chap15.v *)
25 | Theorem lt_Acc : forall n:nat, Acc lt n.
26 | Proof.
27 |  induction n.
28 |  split; intros p H; inversion H.
29 |  split. 
30 |  intros y H0.
31 |  case (le_lt_or_eq _ _ H0).
32 |  intro; apply Acc_inv with n; auto with arith.
33 |  intro e; injection e; intro e1; rewrite e1; assumption. 
34 | Qed.
35 | 
36 | Function log (n:nat) {wf lt n} :=
37 |   match n with
38 |     | 0 => 0
39 |     | 1 => 0
40 |     | n => (log (n %/ 2)).+1
41 |   end.
42 | Proof.
43 |   + move=> n2 n1 n Hn1 Hn2.
44 |     rewrite -!Hn2.
45 |     apply/leP.
46 |     Search (_ %/ _ < _).
47 |     apply ltn_Pdiv.
48 |       - by [].
49 |       - by rewrite Hn2.
50 |   + rewrite /well_founded.
51 |     by apply lt_Acc.
52 | Qed.
53 | 
54 | (*
55 | ヒント
56 | 
57 | Fixpointでは構造に基づく帰納法しか書けませんでした。Coqが自動的に停止性を判断できないような
58 | 関数の定義をするために、Functionコマンドが用意されています。停止性はwf (パラメーターのうち
59 | の1つが整礎的な関係に従って降下していくことを示す) または measure (パラメーターのうちの1つ
60 | に自然数の重みを定める関数があり、再帰呼び出しはこの重みが減る方向に進むということを示す)
61 | の2つの方法があります。
62 | 
63 | *)
64 | 
65 | (* END *)
66 | 


--------------------------------------------------------------------------------
/ex2014/ex10.v:
--------------------------------------------------------------------------------
 1 | Require Import ssreflect.
 2 | 
 3 | (**
 4 | # 第2回 証明済みの定理の利用・量化や等式を含む命題に関する証明 (2014/04/13)
 5 | 
 6 | http://qnighy.github.io/coqex2014/ex2.html
 7 | 
 8 | ## 課題10 (種別:C / 締め切り : 2014/05/04)
 9 | 
10 | 次の定理を証明せよ。
11 | *)
12 | 
13 | Parameter G : Set.
14 | Parameter mult : G -> G -> G.
15 | Notation "x * y" := (mult x y).
16 | Parameter one : G.
17 | Notation "1" := one.
18 | Parameter inv : G -> G.
19 | Notation "/ x" := (inv x).
20 | (* Notation "x / y" := (mult x (inv y)). *) (* 使ってもよい *)
21 | 
22 | Axiom mult_assoc : forall x y z, x * (y * z) = (x * y) * z.
23 | Axiom one_unit_l : forall x, 1 * x = x.
24 | Axiom inv_l : forall x, / x * x = 1.
25 | 
26 | (*
27 | 証明の内容は、以下に忠実なものである。
28 | 
29 | [Coq][Math] From left unit and left inverse to right unit and inverse.
30 | 
31 | http://study-func-prog.blogspot.jp/2014/04/coqmath-from-left-unit-and-left-inverse.html
32 | *)
33 | 
34 | Lemma inv_r : forall x, x * / x = 1.
35 | Proof.
36 |   move=> x.
37 |   rewrite -{1}(one_unit_l x).
38 |   rewrite -{1}(inv_l (inv x)).
39 |   rewrite -[/ / x * / x * x]mult_assoc.
40 |   rewrite (inv_l).
41 |   rewrite -mult_assoc.
42 |   rewrite one_unit_l.
43 |   rewrite inv_l.
44 |   by [].
45 | Qed.
46 | 
47 | Lemma one_unit_r : forall x, x * 1 = x.
48 | Proof.
49 |   move=> x.
50 |   rewrite -{1}(one_unit_l x).
51 |   rewrite -{1}(inv_l (inv x)).
52 |   rewrite -{1}(inv_l x).
53 |   rewrite mult_assoc.
54 |   rewrite -[/ / x * / x * x]mult_assoc.
55 |   rewrite (inv_l).
56 |   rewrite -mult_assoc.
57 |   rewrite -mult_assoc.
58 |   rewrite one_unit_l.
59 |   rewrite mult_assoc.
60 |   rewrite (inv_l (/ x)).
61 |   by [].
62 | Qed.
63 | 
64 | (* END *)
65 | 


--------------------------------------------------------------------------------
/ex2014/ex38.v:
--------------------------------------------------------------------------------
 1 | Require Import ssreflect.
 2 | 
 3 | (**
 4 | # 第8回
 5 | 
 6 | http://qnighy.github.io/coqex2014/ex6.html
 7 | 
 8 | ## 課題38 (種別:A / 締め切り : 2014/06/01)
 9 | 
10 | モノイドを型クラスとして定義する。以下の空欄を埋めよ。
11 | *)
12 | 
13 | (* モノイド *)
14 | Class Monoid (T : Type) := {
15 |   mult : T -> T -> T
16 |     where "x * y" := (mult x y);
17 |   one : T
18 |     where "1" := one;
19 |   mult_assoc x y z : x * (y * z) = (x * y) * z;
20 |   mult_1_l x : 1 * x = x;
21 |   mult_1_r x : x * 1 = x
22 | }.
23 | 
24 | Delimit Scope monoid_scope with monoid.
25 | Local Open Scope monoid_scope.
26 | 
27 | Notation "x * y" := (mult x y) : monoid_scope.
28 | Notation "1" := one : monoid_scope.
29 | 
30 | (* モノイドのリストの積 *)
31 | Require Import List.
32 | Check @fold_right bool bool.
33 | Check @mult.
34 | 
35 | Definition product_of {T : Type} {M : Monoid T} : list T -> T :=
36 |   fun (l : list T) => fold_right mult 1 l.
37 | (* @fold_right T T (@mult T M) 1 l *)
38 | 
39 | 
40 | (* 自然数の最大値関数に関するモノイド *)
41 | Require Import Arith.
42 | Check max.
43 | Program Instance MaxMonoid : Monoid nat :=
44 |   {|
45 |     mult x y := max x y;
46 |     one := 0
47 |   |}.
48 | Next Obligation.                            (* max x (max y z) = max (max x y) z *)
49 |   by rewrite Max.max_assoc.
50 | Qed.
51 | Next Obligation.                            (* max x 0 = 0 *)
52 |   by rewrite Max.max_0_r.
53 | Qed.
54 | 
55 | Eval compute in product_of (3 :: 2 :: 6 :: 4 :: nil). (* => 6 *)
56 | Eval compute in product_of (@nil nat). (* => 0 *)
57 | 
58 | (**
59 | ヒント
60 | 
61 | Classの実体はRecordです。Classとして宣言すると、型クラスのように自動でインスタンスを探しに
62 | 行くようになり、インスタンスを明示する必要がなくなります。SetoidやProperもクラスです。
63 | 
64 | *)
65 | 
66 | (* END *)
67 | 


--------------------------------------------------------------------------------
/ssr/ssr_zakky.v:
--------------------------------------------------------------------------------
 1 | (* mzpさんの真偽値のみの言語における決定性の証明コード(Coq) *)
 2 | (* TAPL Nagoya 2014 #1 *)
 3 | Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
 4 | 
 5 | Inductive Term : Set :=
 6 |  | T
 7 |  | F
 8 |  | TIf (_ : Term) (_ : Term) (_ : Term).
 9 |  
10 | Inductive Step : Term -> Term -> Prop :=
11 |  | EIfTrue  : forall (t1 t2 : Term), Step (TIf T t1 t2) t1
12 |  | EIfFalse : forall (t1 t2 : Term), Step (TIf F t1 t2) t2
13 |  | EIf      : forall (t1 t1' t2 t3 : Term),
14 |                 Step t1 t1' -> Step (TIf t1 t2 t3) (TIf t1' t2 t3).
15 |  
16 | (* by mzp *)
17 | Lemma dec: forall (t t' t'' : Term),
18 |   Step t t' -> Step t t'' -> t' = t''.
19 | Proof.
20 |   Check Step_ind.
21 |   intros t t' t'' Q.
22 |  
23 |   generalize t''.
24 |   apply Step_ind with (t:=t) (t0:=t'); intros; auto.
25 |     inversion H; auto.
26 |     subst.
27 |     inversion H4.
28 |  
29 |     inversion H; auto.
30 |     inversion H4.
31 |  
32 |     destruct t1.
33 |       inversion H.
34 |       inversion H.
35 |  
36 |       inversion H1.
37 |       apply H0 in H6.
38 |       rewrite H6.
39 |       reflexivity.
40 | Qed.
41 | 
42 | Lemma dec' : forall (t t' t'' : Term),
43 |   Step t t' -> Step t t'' -> t' = t''.
44 | Proof.
45 |   move=> t t' t'' Q.
46 |   elim: Q t''.
47 |   - move=> t1 t2 t'' H.
48 |     inversion H.
49 |     + by [].
50 |     + by inversion H4.
51 |   - move=> t1 t2 t'' H.
52 |     inversion H.
53 |     + by [].
54 |     + by inversion H4.
55 |   - move=> t1 t1' t2 t3 H H1 t'' H2.
56 |     destruct t1.                            (* XXX *)
57 |     + inversion H.
58 |     + inversion H.
59 |     + inversion H2.
60 |       by rewrite (H1 t1'0).
61 | Qed.
62 | 
63 | (* END *)
64 | 


--------------------------------------------------------------------------------
/coq_cps_fact.v:
--------------------------------------------------------------------------------
 1 | (*
 2 |    CPS
 3 |    2010_10_29
 4 |    *)
 5 | 
 6 | 
 7 | (* 階乗の再帰版 *)
 8 | Fixpoint fact (n : nat) : nat :=
 9 |   match n with
10 |     | 0 => 1
11 |     | (S n') => n * fact n'
12 |   end.
13 | Eval cbv in fact 6.                         (* 720 *)
14 | 
15 | 
16 | (* CPS 版で書くとこうなる。*)
17 | Fixpoint fact_cps (n : nat) (cont : nat -> nat) : nat :=
18 |   match n with
19 |     | 0 => cont 1
20 |     | (S n') => fact_cps n' (fun (a : nat) => cont (n * a))
21 |   end.
22 | Eval cbv in fact_cps 6 (fun a => a).        (* 720 *)
23 | 
24 | 
25 | Lemma fact_Sn :
26 |   forall n,
27 |     fact (S n) = (S n) * fact n.
28 | Proof.
29 |   reflexivity.
30 | Qed.
31 | 
32 | 
33 | Lemma fact_cps_Sn :
34 |   forall n f,
35 |     fact_cps (S n) f =
36 |     fact_cps n (fun (r:nat) => (f (S n * r))).
37 | Proof.
38 |   intros.
39 |   simpl.
40 |   reflexivity.
41 | Qed.
42 | 
43 | 
44 | (* fact_cps_Sn の実験 *)
45 | Eval cbv in fact_cps 6 (fun (r:nat) => r).  (* 720 *)
46 | Eval cbv in fact_cps 5 (fun (r:nat) => (6 * r)). (* 720 *)
47 | 
48 | 
49 | Lemma eq_fact_fact_cps_aux :
50 |   forall (n:nat),
51 |     (forall f, f (fact n) = fact_cps n f) /\
52 |     (forall g, g (fact (S n)) = fact_cps (S n) g).
53 | Proof.
54 |   intros.
55 |   induction n.
56 |   (* 再帰の底 *)
57 |   auto.
58 |   
59 |   destruct IHn.
60 |   split.
61 |   (* /\の左 *)
62 |   apply H0.
63 |   
64 |   (* /\の右 *)
65 |   intro g.
66 |   rewrite fact_cps_Sn.
67 |   rewrite <- H0.
68 |   rewrite fact_Sn.
69 |   reflexivity.
70 | Qed.
71 | 
72 | 
73 | Theorem eq_fact_fact_cps :
74 |   forall n f, f (fact n) = fact_cps n f.
75 | Proof.
76 |   intros.
77 |   destruct (eq_fact_fact_cps_aux n).
78 |   apply H.
79 | Qed.
80 | 
81 | (* END *)
82 | 


--------------------------------------------------------------------------------
/ssr/ssr_fold_symmetric.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | プログラミング Coq 「証明ができない！ こんなとき」
 3 | http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt6.html
 4 | 
 5 | 帰納法に注意 における、generalize の説明をSSReflectに移してみる。
 6 | @suharahiromichi
 7 | *)
 8 | 
 9 | Require Import ssreflect ssrbool ssrnat seq.
10 | 
11 | (* Coqでの説明に忠実な例 *)
12 | Theorem fold_symmetric :
13 |   forall (A:Type) (f:A -> A -> A),
14 |     (forall x y z:A, f x (f y z) = f (f x y) z) ->
15 |     (forall x y:A, f x y = f y x) ->
16 |     forall (a:A) (l:list A), foldl f a l = foldr f a l.
17 | Proof.
18 |   move=> A f H  H0 a l.
19 |   case: l.
20 |   done.
21 | 
22 |   simpl.
23 |   move=> a0 l.
24 |   move: a a0.                               (* generalize *)
25 |   elim l.
26 |     simpl.
27 |     apply H0.
28 | 
29 |     simpl. clear l.
30 |     move=> a1 l IHl a3 a2.
31 |     rewrite H.
32 |     replace (f (f a3 a2) a1) with (f a3 (f a2 a1)).
33 |     apply IHl.  
34 |     apply H.
35 | Qed.
36 | 
37 | (* より みなおした例 *)
38 | Theorem fold_symmetric' :
39 |   forall (A:Type) (f:A -> A -> A),
40 |     (forall x y z:A, f x (f y z) = f (f x y) z) ->
41 |     (forall x y:A, f x y = f y x) ->
42 |     forall (a:A) (l:list A), foldl f a l = foldr f a l.
43 | Proof.
44 |   move=> A f H H0 a l. move: a.
45 |   case: l.
46 |     (* l = [] のとき。 *)
47 |     by [].
48 |     
49 |   (* l = a :: l のとき。 *)
50 |   move=> a0 l.
51 |   elim: l a0 => a1 l.                  (* 「:」の右の a0 が 必須のgeneralize。 *)
52 |   (* move: a0; elim: l => a1 l. と同じ。*)
53 |   
54 |     (* l = a1 :: [] のとき。 *)
55 |     by apply H0.
56 | 
57 |   (* l = a2 :: a1 :: l のとき。 *)
58 |   move=> IHl a2 a3.
59 |   rewrite /= H.
60 |   replace (f (f a3 a2) a1) with (f a3 (f a2 a1)).
61 |     by apply IHl. 
62 | 
63 |   (* replace できることを証明する。 *)
64 |   by apply H.
65 | Qed.
66 | 
67 | (* END *)
68 | 


--------------------------------------------------------------------------------
/csm/csm_5_set_theory_finset.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | 
 3 | Set Implicit Arguments.
 4 | Unset Strict Implicit.
 5 | Unset Printing Implicit Defensive.
 6 | Set Print All.
 7 | 
 8 | (* csm_5_set_theory.v は不使用である。 *)
 9 | 
10 | Section ライブラリfinsetの利用.
11 |   Variable M : finType.
12 | 
13 |   Check setP : forall (T : finType) (A B : {set T}), A =i B <-> A = B. (* 定理 *)
14 |   
15 |   (* 有限集合の ∪ (:|:) と ∩ (:&:) を ∈ (\in) と || と && にする。 *)
16 |   Check in_setU : forall (T : finType) (x : T) (A B : {set T}),
17 |       (x \in A :|: B) = (x \in A) || (x \in B).
18 |   
19 |   Check in_setI : forall (T : finType) (x : T) (A B : {set T}),
20 |       (x \in A :&: B) = (x \in A) && (x \in B).
21 |   
22 |   (* 実際は、inEだけ覚えておけばよい。 *)
23 |   Check inE.                                (* 略 *)
24 |   
25 |   Lemma demorgan (A B C : {set M}) : (A :&: B) :|: C = (A :|: C) :&: (B :|: C).
26 |   Proof.
27 |     (* = を =i に変換する。 *)
28 |     (* ``P =i Q`` は ``∀x, x \in P = x \in Q`` の構文糖衣である。 *)
29 |     apply/setP => x.
30 |     (* Goal : A :&: B :|: C =i (A :|: C) :&: (B :|: C) *)
31 |     (* Goal : (x \in A :&: B :|: C) = (x \in (A :|: C) :&: (B :|: C)) *)
32 | 
33 |     (* Goal : (x \in A :&: B :|: C) = (x \in (A :|: C) :&: (B :|: C)) *)
34 |     (* :|: と :&: を || と && に変換する。 *)
35 | (*
36 |     rewrite !in_setU.
37 |     rewrite !in_setI.    
38 |     rewrite !in_setU.
39 |     Undo 3.
40 | *)    
41 |     rewrite !inE.
42 |     (* Goal : (x \in A) && (x \in B) || (x \in C) =
43 |        ((x \in A) || (x \in C)) && ((x \in B) || (x \in C)) *)
44 |     
45 |     (* || と && の ド・モルガンの定理 *)
46 |     Check orb_andl : forall x y z : bool, x && y || z = (x || z) && (y || z).
47 |       by rewrite -orb_andl.
48 |   Qed.
49 |   
50 | End ライブラリfinsetの利用.
51 | 
52 | (* END *)
53 | 


--------------------------------------------------------------------------------
/ssr/ssr_set_a_a_b__b_qitta.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | リフレクションを使って集合の問題を解いてみる
 3 | =========
 4 | 2014/04/29 @suharahiromichi
 5 |  *)
 6 | 
 7 | (**
 8 | # はじめに
 9 | 
10 | リフレクションというと、論理式とbool式の関係が重要だが、
11 | それ以外にも集合演算と論理演算の関係も馴染み深い。
12 | もちろん、SSReflectはその機能を持っている。
13 | そのリフレクションを使って問題を解いてみる。
14 |  *)
15 | 
16 | (**
17 | # 定理：B ⊆ A のとき、A - (A - B) = B を証明する。
18 |  *)
19 | 
20 | Require Import ssreflect ssrbool ssrnat.
21 | Require Import fintype finset.
22 | 
23 | Variable T : finType.
24 | 
25 | Theorem a_a_b__b (A B : {set T}) : B \subset A -> (A :\: (A :\: B)) = B.
26 | Proof.
27 |   (** (B ⊆ A) -> (A - (A - B)) = B *)
28 |   move/setIidPr/setP => H. apply/setP; move: H.
29 |   rewrite /eq_mem.
30 | 
31 |   (** (x ∈ (A ∩ B)) = (x ∈ B) -> (x ∈ A - (A - B)) = (x ∈ B) *)
32 |   move=> H x; rewrite -(H x) {H}; apply/setDP/idP.
33 | 
34 |     (** ((x ∈ A) /\ ~(x ∈ (A - B)) -> (x ∈ A ∩ B) *)
35 |     rewrite -in_setC setDE setCI => [[H]].
36 |     move/setUP => H_ab; apply/setIP.
37 |     by split; [ |
38 |                 case: H_ab => [H_a | H_b];
39 |                 [move/setCP in H_a | rewrite setCK in H_b]].
40 | 
41 |   (** (x ∈ A ∩ B) -> ((x ∈ A) /\ ~(x ∈ (A - B)) *)
42 |   rewrite -in_setC => /setIP [Ha Hb].
43 |   by split; [ |
44 |               apply/setCP; rewrite /not => /setDP; elim => [_ H_b]; 
45 |               move: H_b; rewrite -in_setC => /setCP].
46 | Qed.
47 | 
48 | (**
49 | # finset内の補題を使って証明する。
50 | *)
51 | 
52 | (**
53 | 実は、finsetの中の補題を使用すると、reflectionを使わずに解けてしまう。
54 | もちろん、これらの定理はreflectionで証明されているのだけれど。
55 |  *)
56 | 
57 | Theorem a_a_b__b' (A B : {set T}) : B \subset A -> (A :\: (A :\: B)) = B.
58 | Proof.
59 |   move=> H.
60 |   rewrite setDDr setDv set0U.
61 |   by apply/setIidPr.
62 | Qed.
63 | 
64 | (**
65 | 注意：このふたつの証明の間に相互の対応はない。
66 |  *)
67 | 
68 | (* $Id:$ *)
69 | 


--------------------------------------------------------------------------------
/lisp/ssr_string.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | Set Implicit Arguments.
 3 | Unset Strict Implicit.
 4 | Unset Printing Implicit Defensive.
 5 | Set Print All.
 6 | 
 7 | Require Import Ascii.
 8 | Require Import String.
 9 | 
10 | Section SSRAscii.
11 | 
12 |   Definition eqAscii (a b : ascii) : bool :=
13 |     match ascii_dec a b with
14 |     | left _ => true
15 |     | right _ => false
16 |     end.
17 | 
18 |   Compute eqAscii "a" "a".                  (* true *)
19 |   Compute eqAscii "a" "b".                  (* false *)
20 |   
21 |   Lemma ascii_eqP (a b : ascii) : reflect (a = b) (eqAscii a b).
22 |   Proof.
23 |     rewrite /eqAscii.
24 |     (* reflect (a = b) (if ascii_dec a b then true else false) *)
25 |     apply: (iffP idP); by case: (ascii_dec a b).
26 |   Qed.
27 |   
28 |   Definition ascii_eqMixin := @EqMixin ascii eqAscii ascii_eqP.
29 |   Canonical ascii_eqType := @EqType ascii ascii_eqMixin.
30 |   
31 | End SSRAscii.
32 |   
33 | Section SSRString.
34 |   
35 |   Definition eqString (s t : string) : bool :=
36 |     match string_dec s t with
37 |     | left _ => true
38 |     | right _ => false
39 |     end.
40 |   
41 |   Compute eqString "aaaa"%string "aaaa"%string. (* true *)
42 |   Compute eqString "aaaa"%string "aa"%string.   (* false *)
43 |   
44 |   Lemma string_eqP (x y : string) : reflect (x = y) (eqString x y).
45 |   Proof.
46 |     rewrite /eqString.
47 |     apply: (iffP idP); by case: (string_dec x y).
48 |   Qed.        
49 |   
50 |   Definition string_eqMixin := @EqMixin string eqString string_eqP.
51 |   Canonical string_eqType := @EqType string string_eqMixin.
52 | 
53 | End SSRString.
54 | 
55 | Check "aaa"%string = "aaa"%string : Prop.
56 | Check "aaa"%string == "aaa"%string : bool.
57 | Check "aaa"%string == "aaa"%string : Prop.
58 | 
59 | (* END *)
60 | 


--------------------------------------------------------------------------------
/math-comp-book/suhara.ch6-finset.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | From mathcomp Require Import perm.
 3 | 
 4 | Check [set: bool] : {set bool}.
 5 | Compute true \in [set: bool].
 6 | Compute false \in [set: bool].
 7 | 
 8 | Check finset (fun x => x \in [set: bool]).
 9 | 
10 | 
11 | 
12 | (* predArgType のひとつのみかた *)
13 | 
14 | (* これまで勉強してきた型は predArgType として定義されている。 *)
15 | Check 'I_3               : predArgType.
16 | Check {tuple 3 of nat}   : predArgType.
17 | Check {ffun bool -> nat} : predArgType.
18 | Check {set  'I_3} : predArgType.
19 | Check {perm 'I_3} : predArgType.
20 | 
21 | (* 任意の型を predArgType にすることもできる。 *)
22 | Check {: bool}    : predArgType.
23 | Check {: nat}     : predArgType.
24 | 
25 | (* predArgType の要素のひとつの見方は、pred T の T になることができる。 *)
26 | (* pred T は、T -> bool の決定可能な述語である。 *)
27 | Check pred {: nat} : Type.
28 | 
29 | (* predArgType から pred へのコアーションがある。 *)
30 | Print Graph.
31 | (* [pred_of_argType] : predArgType >-> simpl_pred *)
32 | 
33 | Check pred_of_argType : forall T : predArgType, pred T.
34 | Print pred_of_argType.                      (* = [eta @predT] *)
35 | (* = @predT *)
36 | (* = fun {T : predArgType} (x : T) => true *)
37 | (* predT は、任意の引数にたいして true だけを返す関数だが、 *)
38 | (* 省略可能な第一引数で指定した型と一致しなければ、ならない。 *)
39 | 
40 | Check pred_of_argType {: nat} : pred {: nat}.
41 | Check pred_of_argType {: nat} : pred nat.
42 | Check {: nat}                 : pred {: nat}.
43 | Check {: nat}                 : pred nat.
44 | Check pred_of_argType nat : pred {: nat}.
45 | Check pred_of_argType nat : pred nat.
46 | Fail Check nat                 : pred {: nat}.
47 | Fail Check nat                 : pred nat.
48 | 
49 | (* 実行してみると。 *)
50 | Check {: nat} 1 : bool.
51 | Compute {: nat} 1.                          (* true しか返さない。 *)
52 | Fail Compute {: nat} bool.                  (* エラーになる。 *)
53 | 
54 | (* END *)
55 | 


--------------------------------------------------------------------------------
/fp/ssr_cpl_1.md:
--------------------------------------------------------------------------------
 1 | Categorical Programming Language (CPL, 圏論プログラミング言語) の情報
 2 | 
 3 | # オリジナルの情報
 4 | 
 5 | ## 論文
 6 | 
 7 | - Hagino, A Categorical Programming Language
 8 | http://web.sfc.keio.ac.jp/~hagino/thesis.pdf ○
 9 | 
10 | - カテゴリー理論的関数型プログラミング言語
11 | https://ci.nii.ac.jp/naid/110003743564 ○
12 | 
13 | - 不動点をめぐって：3. 情報工学に見られる不動点論の散策 3.3 プログラム理論と不動点 -表示的意味論における不動点の役割-
14 | https://ci.nii.ac.jp/naid/110002762687 ○
15 | 
16 | - 随伴関手を用いた圏論的結合子の導出
17 | https://ci.nii.ac.jp/naid/110002721963 ○
18 | 
19 | 
20 | ## 萩野先生の講義
21 | 
22 | - 慶應義塾大学 2020年度 秋学期 情報数学
23 | https://web.sfc.keio.ac.jp/~hagino/mi20/
24 | 第11回にて言及
25 | 
26 | 
27 | # 最近の情報
28 | 
29 | ## Wikipedia
30 | 
31 | - CPL (圏論プログラミング言語)
32 | https://ja.wikipedia.org/wiki/CPL_(圏論プログラミング言語)
33 | 
34 | 
35 | ## 酒井さん
36 | 
37 | - CPL: An interpreter of Hagino's Categorical Programming Language (CPL) - Hackage
38 | https://hackage.haskell.org/package/CPL
39 | 
40 | - ヒビルテ [CPL]
41 | https://msakai.jp/d/?category=CPL
42 | 
43 | - How to translate combinators into CPL
44 | https://msakai.jp/d/data/200301/memo-0125.pdf  ○
45 | 
46 | - Introduction to Categorical Programming (revised)
47 | https://msakai.jp/d/data/200909/HAMA-CPL-revised.pdf ○
48 | 
49 | 
50 | ## Ryuseiさん
51 | 
52 | - 圏論プログラミング言語 CPL - Ryusei’s Notes (a.k.a. M59のブログ)
53 | https://mandel59.hateblo.jp/entry/2015/02/02/110621
54 | お団子図
55 | 
56 | 
57 | ## うさぎ小屋さん
58 | 
59 | - 圏論プログラミング言語CPL入門 - うさぎ小屋
60 | https://kimiyuki.net/blog/2015/06/10/introduction-to-categorical-programming-language-cpl/
61 | 
62 | - ackermann関数をcplで - うさぎ小屋
63 | https://kimiyuki.net/blog/2015/06/12/ackermann-function-in-cpl/
64 | 
65 | - 素数列をcplで - うさぎ小屋
66 | https://kimiyuki.net/blog/2015/06/12/sequence-of-primes-in-cpl/
67 | 
68 | 
69 | # simh で動かす
70 | 
71 | - simhでCategorical Programming Languageを動かす
72 | https://qiita.com/dico_leque/items/b25f210eb0ff3156a8f3
73 | 
74 | 以上
75 | 


--------------------------------------------------------------------------------
/intro/1-1.v:
--------------------------------------------------------------------------------
 1 | (* Suhara for PF *)
 2 | (* About integer powers (monomorphic version) *)
 3 | 
 4 | Set Implicit Arguments.
 5 | 
 6 | Require Import ZArith.
 7 | 
 8 | Require Import Div2.
 9 | 
10 | Require Import Program.
11 | 
12 | Open Scope Z_scope.
13 | 
14 | Fixpoint power (a:Z)(n:nat) :=
15 |   match n with
16 |   | 0%nat => 1
17 |   | S p =>  a * power a p
18 |   end.
19 | 
20 | Eval vm_compute in power 2 40.              (* = 1099511627776 : Z *)
21 | 
22 | Require Import Recdef.
23 | Function binary_power_mult' (acc x:Z) (n:nat) {measure (fun i => i) n} : Z :=
24 |   match n with 
25 |     | 0%nat => acc
26 |     | _ => if Even.even_odd_dec n
27 |            then binary_power_mult' acc (x * x) (div2 n)
28 |            else binary_power_mult' (acc * x) (x * x) (div2 n)
29 |   end.
30 | Proof.
31 |   intros.
32 |   Check lt_div2 : forall n : nat, (0 < n)%nat -> (Nat.div2 n < n)%nat.
33 |   apply lt_div2.
34 |   debug auto with arith.
35 |   Undo 1.
36 |   now apply Nat.lt_0_succ.
37 |   
38 |   (* おなじ *)
39 |   intros.
40 |   apply lt_div2.
41 |   (* 0 < S n0 *)
42 |   omega.
43 | Qed.
44 | 
45 | Program
46 | Fixpoint binary_power_mult (acc x:Z) (n:nat) {measure n} : Z
47 |   (* acc * (power x n) *) :=
48 |   match n with 
49 |     | 0%nat => acc
50 |     | _ => if Even.even_odd_dec n
51 |            then binary_power_mult acc (x * x) (div2 n)
52 |            else binary_power_mult (acc * x) (x * x) (div2 n)
53 |   end.
54 | Solve Obligations with program_simpl; intros; apply lt_div2; omega. (* auto with arith. *)
55 | 
56 | 
57 | Definition binary_power (x:Z)(n:nat) := binary_power_mult 1 x n.
58 | 
59 | Eval vm_compute in binary_power 2 40.       (* = 1099511627776 : Z *)
60 | 
61 | Goal binary_power 2 234 = power 2 234.
62 |   reflexivity.
63 | Qed.
64 | (* binary_powe function and the naive power function are pointwise equivalent. *)
65 | 
66 | (* END *)
67 | 


--------------------------------------------------------------------------------
/iii/ssr_coqt3.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | プログラミング Coq --- リストを扱う
 3 | 
 4 | http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt3.html
 5 | をSSReflectに書き直した。
 6 | *)
 7 | 
 8 | Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
 9 | 
10 | Set Implicit Arguments.
11 | Unset Strict Implicit.
12 | Unset Printing Implicit Defensive.
13 | Set Print All.
14 | 
15 | Theorem app_assoc : forall (A : Type) (l1 l2 l3 : seq A),
16 |                       l1 ++ l2 ++ l3 = (l1 ++ l2) ++ l3.
17 | Proof.
18 |   move=> A.
19 |   elim=> [// | a l l1 l2 l3 /=].
20 |     by congr (a :: _).
21 | Qed.
22 | 
23 | Fixpoint rev (A : Type)(l : list A) : list A :=
24 |   match l with
25 |   | nil => nil
26 |   | x :: xs => rev xs ++ (x :: nil)
27 |   end.
28 | 
29 | Theorem rev_app_distr : forall (A : Type) (l1 l2 : seq A),
30 |                           rev (l1 ++ l2) = rev l2 ++ rev l1.
31 | Proof.
32 |   move=> A.
33 |   elim=> [/= l2 | a l IHl l2 /=].
34 |   + by rewrite cats0.
35 |   + by rewrite catA; congr (_ ++ _).
36 | Qed.
37 | 
38 | 
39 | (* 前回の答え。 *)
40 | 
41 | Theorem problem2 : forall (P Q R : Prop),
42 |                      (P -> Q) -> (Q -> R) -> P -> R.
43 | Proof.
44 |   move=> P Q R H H0 H1.
45 |   by apply/H0/H/H1.
46 | Qed.
47 | 
48 | Theorem problem3 : forall (P : Prop), ~ (P /\ ~ P).
49 | Proof.
50 |   rewrite /not => P.
51 |   case=> H H0.
52 |   by apply/H0/H.
53 | Qed.
54 | 
55 | Theorem problem4 : forall (P Q : Prop),
56 |                      ~ P \/ ~ Q -> ~ (P /\ Q).
57 | Proof.
58 |   rewrite /not => P Q H.
59 |   case=> H0 H1.
60 |   by case H => H2.
61 | Qed.
62 | 
63 | Theorem problem5 : forall (P : Prop),
64 |                      (forall (P : Prop), ~ ~ P -> P) -> P \/ ~ P.
65 | Proof.
66 |   rewrite /not => P H.
67 |   apply: H => H0.
68 |   apply: (H0).                              (* H0 を前提に残す。 *)
69 |   right=> H1.
70 |   apply: H0.
71 |   by left.
72 | Qed.
73 | 
74 | (* END *)
75 | 


--------------------------------------------------------------------------------
/common/ssrstring.v:
--------------------------------------------------------------------------------
 1 | From HB Require Import structures.          (* MathComp2 *)
 2 | From mathcomp Require Import all_ssreflect.
 3 | 
 4 | Set Implicit Arguments.
 5 | Unset Strict Implicit.
 6 | Unset Printing Implicit Defensive.
 7 | Set Print All.
 8 | 
 9 | Require Import Ascii.
10 | Require Import String.
11 | Export Ascii.
12 | Export String.
13 | 
14 | Section SSRAscii.
15 | 
16 |   Definition eqAscii (a b : ascii) : bool :=
17 |     match ascii_dec a b with
18 |     | left _ => true
19 |     | right _ => false
20 |     end.
21 | 
22 |   Compute eqAscii "a" "a".                  (* true *)
23 |   Compute eqAscii "a" "b".                  (* false *)
24 |   
25 |   Lemma ascii_eqP (a b : ascii) : reflect (a = b) (eqAscii a b).
26 |   Proof.
27 |     rewrite /eqAscii.
28 |     (* reflect (a = b) (if ascii_dec a b then true else false) *)
29 |     apply: (iffP idP); by case: (ascii_dec a b).
30 |   Qed.
31 | 
32 |   HB.instance Definition _ := hasDecEq.Build ascii ascii_eqP. (* MathComp2 *)
33 | End SSRAscii.
34 | 
35 | Check "a"%char : ascii : eqType.
36 | 
37 | Section SSRString.
38 |   
39 |   Definition eqString (s t : string) : bool :=
40 |     match string_dec s t with
41 |     | left _ => true
42 |     | right _ => false
43 |     end.
44 |   
45 |   Compute eqString "aaaa"%string "aaaa"%string. (* true *)
46 |   Compute eqString "aaaa"%string "aa"%string.   (* false *)
47 |   
48 |   Lemma string_eqP (x y : string) : reflect (x = y) (eqString x y).
49 |   Proof.
50 |     rewrite /eqString.
51 |     apply: (iffP idP); by case: (string_dec x y).
52 |   Qed.        
53 |   
54 |   HB.instance Definition _ := hasDecEq.Build string String.eqb_spec. (* MathComp2 *)
55 | End SSRString.
56 | 
57 | Check "aaa"%string : string : eqType.
58 | 
59 | Check "aaa"%string = "aaa"%string : Prop.
60 | Check "aaa"%string == "aaa"%string : bool.
61 | Check "aaa"%string == "aaa"%string : Prop.
62 | 
63 | (* END *)
64 | 


--------------------------------------------------------------------------------
/coq_cps_len.v:
--------------------------------------------------------------------------------
 1 | (*
 2 |    CPS その1、リストの長さ (len_cps)
 3 |    2010_10_29
 4 |    *)
 5 | 
 6 | 
 7 | Require Export List.
 8 | Require Export Arith.
 9 | 
10 | 
11 | (**************)
12 | (* Len        *)
13 | (**************)
14 | 
15 | 
16 | (* 再帰関数 *)
17 | Fixpoint len (lst : list nat) :=
18 |    match lst with 
19 |      | nil => 0
20 |      | hd :: tl => S (len tl)
21 |    end.
22 | Eval cbv in len (1::2::3::4::nil).
23 | 
24 | 
25 | (* CPS版 *)
26 | Fixpoint len_cps (lst : list nat) (cont : nat -> nat) :=
27 |    match lst with 
28 |      | nil => cont 0
29 |      | hd :: tl => len_cps tl (fun x => cont (S x))
30 |    end.
31 | Eval cbv in len_cps (1::2::3::4::nil) (fun n:nat => n).
32 | 
33 | 
34 | Lemma len_Sn :
35 |   forall n l, len (n::l) = S (len l).
36 | Proof.
37 |   reflexivity.
38 | Qed.
39 | 
40 | 
41 | Eval cbv in len_cps (1::2::3::4::nil) (fun (r:nat) => r).  (* 4 *)
42 | Eval cbv in len_cps (2::3::4::nil) (fun (r:nat) => S r).   (* 4 *)
43 | 
44 | 
45 | Lemma len_cps_Sn :
46 |   forall n l f,
47 |     len_cps (n::l) f =
48 |     len_cps l (fun (r:nat) => f (S r)).
49 | Proof.
50 |   intros.
51 |   simpl.
52 |   (* ここでGoalの左辺が右辺とおなじになるように、定理を用意するのだ。*)
53 |   reflexivity.
54 | Qed.
55 | 
56 | 
57 | Lemma eq_len_len_cps_aux :
58 |   forall (l : list nat) (a : nat),
59 |     (forall f, f (len l) = (len_cps l f)) /\
60 |     (forall g, g (len (a::l)) = len_cps (a::l) g).
61 | Proof.
62 |   intros.
63 |   induction l.
64 |   auto.
65 | 
66 | 
67 |   destruct IHl.
68 |   split.
69 |   apply H0.
70 |   
71 |   intros.
72 |   rewrite len_cps_Sn.
73 |   rewrite len_Sn.
74 |   simpl.
75 |   rewrite <- H.
76 |   reflexivity.
77 | Qed.
78 | Check eq_len_len_cps_aux.
79 | 
80 | 
81 | Theorem eq_len_len_cps :
82 |   forall (l : list nat) (n : nat) (f : nat -> nat), f (len l) = (len_cps l f).
83 | Proof.
84 |   intros.
85 |   destruct (eq_len_len_cps_aux l n).
86 |   apply H.
87 | Qed.
88 | 
89 | 
90 | (* END *)
91 | 


--------------------------------------------------------------------------------
/ssr/ssr_well_founded.v:
--------------------------------------------------------------------------------
 1 | (** 二項関係「<」が整礎であることの証明 *)
 2 | (* 2015_01_08 @suharahiromichi *)
 3 | 
 4 | Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
 5 | Require Import div prime.
 6 | 
 7 | Set Implicit Arguments.
 8 | Unset Strict Implicit.
 9 | Unset Printing Implicit Defensive.
10 | 
11 | (* well_founded の引数は Prop である必要がある。
12 | コアーションが効いて (n < m) = true になる。
13 | だから、well_founded ltn ではだめである。 *)
14 | Lemma well_founded_ltn : well_founded (fun n m => n < m).
15 | Proof.
16 |   move=> x.
17 |   elim: x {1 3}x (leqnn x) => [| n IHn] x H; apply: Acc_intro.
18 |   - by case: x H.
19 |   - by move=> y H0; apply/IHn/(leq_trans H0 H).
20 | Defined.                                    (* Qedでも。 *)
21 | 
22 | (** Prop の場合は、lt_wf として定理があるが、自分で証明してみる。 *)
23 | Search well_founded.
24 | 
25 | Require Import Arith.                       (* Lt *)
26 | (* Coq/Arith/ の定理を使っている。 *)
27 | 
28 | Lemma well_founded_lt : well_founded lt.
29 | Proof.
30 |   move=> x.
31 |   elim: x {1 3}x (le_refl x) => [| n IHn] x H; apply: Acc_intro.
32 |   - case: x H => [|x] H1 x' H2.
33 |     + by inversion H2.
34 |     + exfalso.
35 |       apply le_not_lt in H1.
36 |       apply H1.
37 |       by apply lt_0_Sn.
38 |   - move=> y H0.
39 |     apply IHn.
40 |     apply lt_n_Sm_le.
41 |     by apply (lt_le_trans y x n.+1 H0 H).
42 | Defined.                                    (* Qedでも。 *)
43 | 
44 | (* 整礎帰納法の使い方の例 *)
45 | Goal forall c : nat, c ^ 2 >= 0.
46 | Proof.
47 |   move=> c.
48 |   move: c (well_founded_ltn c).
49 |   refine (Acc_ind _ _) => c.
50 |   case: c.
51 |     (* 
52 |    (forall y : nat, y < 0 -> Acc (fun n m : nat => n < m) y) ->
53 |    (forall y : nat, y < 0 -> 0 <= y ^ 2) -> 0 <= 0 ^ 2
54 |      *)
55 |   by [].
56 |     (* 
57 |    forall n : nat,
58 |    (forall y : nat, y < n.+1 -> Acc (fun n0 m : nat => n0 < m) y) ->
59 |    (forall y : nat, y < n.+1 -> 0 <= y ^ 2) -> 0 <= n.+1 ^ 2
60 |      *)
61 |   by [].
62 | Qed.
63 | 
64 | (* END *)
65 | 


--------------------------------------------------------------------------------
/ssr/ssr_callcc_classic.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | call/ccと古典論理
 3 | ======
 4 | 2015/08/22
 5 | 
 6 | @suharahiromichi
 7 | 
 8 | # はじめに
 9 | 
10 | 継続は古典論理との意味をもって語られることが多いけれど、
11 | 実は ``call/cc`` の型（p型を返すとする）、
12 | ``((p→void)→p)→p`` が、Curry-Howard同型から、
13 | ``forall P, ((P -> False) -> P) -> P)`` という論理式にみなせる、
14 | ということだ（からだとおもう）。
15 | 
16 | それがどうして古典論理と関係するかというと、
17 | この論理式と排中律や二重否定除去定理が同値だからである。
18 | 
19 | ここでは、実際にその証明をしてみたい。
20 | 
21 | 証明はSSReflectを使うが、あまり省略しないようにした。
22 | *)
23 | 
24 | Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq.
25 | Set Implicit Arguments.
26 | Unset Strict Implicit.
27 | 
28 | (**
29 | ``call/cc``と排中律が同値であるこを証明する。
30 |  *)
31 | Goal (forall (P : Prop), ((P -> False) -> P) -> P) <->
32 | (forall (P : Prop), P \/ ~P).
33 | Proof.
34 |   split.
35 |   - move=> Callcc P.
36 |     apply: (Callcc (P \/ ~P)).
37 |     move=> H.
38 |     right=> H1.
39 |     apply: H.
40 |     left.
41 |     by apply: H1.
42 |   - move=> Em P.
43 |     case: (Em P)=> HP H1.
44 |     + by apply: HP.
45 |     + apply: H1.
46 |       by apply: HP.
47 | Qed.  
48 | 
49 | (**
50 | ``call/cc``と二重否定除去が同値であることを証明する。
51 |  *)
52 | Goal (forall (P : Prop), ((P -> False) -> P) -> P) <->
53 | (forall (P : Prop), ~ ~ P -> P).
54 | Proof.
55 |   split.
56 |   - move=> Callcc P.
57 |     apply: Callcc => H1 H2.
58 |     exfalso.
59 |     apply: H2 => HP.
60 |     apply: H1 => H3.
61 |     by apply: HP.
62 |   - move=> Dn P H1.
63 |     apply: (Dn P) => HnP.
64 |     apply HnP.
65 |     apply H1 => HP.
66 |     apply HnP.
67 |     by apply HP.
68 | Qed.
69 | 
70 | (**
71 | ``call/cc``とパースの論理式が同値であるこを証明する。
72 |  *)
73 | Goal (forall (P : Prop), ((P -> False) -> P) -> P) <->
74 | (forall (P Q : Prop), ((P -> Q) -> P) -> P).
75 | Proof.
76 |   split.
77 |   - move=> Callcc P Q H1.
78 |     apply: Callcc => H2.
79 |     apply: H1 => HP.
80 |     exfalso.
81 |     apply: H2.
82 |     by apply: HP.
83 |   - move=> Pe P.
84 |     by apply (Pe P False).
85 | Qed.
86 | 
87 | (* END *)
88 | 


--------------------------------------------------------------------------------
/coq_sumbool_2.v:
--------------------------------------------------------------------------------
 1 | (** sumbool は、Bool.Sumbool で定義さてているが、
 2 |    ここではすべて自分で定義してみる。 *)
 3 | 
 4 | Variable A : Type.
 5 | Hypothesis Aeq_dec :
 6 |   forall a b : A, {a = b} + {a <> b}.
 7 | 
 8 | (* 標準ライブラリ Sumbool.v *)
 9 | Definition bool_of_sumbool :
10 |   forall x y:Prop, {x} + {y} -> {b : bool | if b then x else y}.
11 | intros x y H.
12 |   elim H; intro; [exists true | exists false]; assumption.
13 | Defined.
14 | 
15 | (* 標準ライブラリ List.v *)
16 | Inductive list (a : Type) : Type :=
17 | | nil : list a
18 | | cons : a -> list a -> list a.
19 | 
20 | Fixpoint In (a:A) (l:list A) : Prop :=
21 |   match l with
22 |     | nil => False
23 |     | (cons b m) => b = a \/ In a m
24 |   end.
25 | 
26 | Theorem in_nil : forall a : A, ~ In a (nil _).
27 | Proof.
28 |   unfold not; intros a H; inversion_clear H.
29 | Qed.
30 | 
31 | Theorem in_dec :
32 |   (forall x y:A, {x = y} + {x <> y}) ->
33 |   forall (a:A) (l:list A), {In a l} + {~ In a l}.
34 | Proof.
35 |   intro H; induction l as [| a0 l IHl].
36 |   right; apply in_nil.
37 |   destruct (H a0 a); simpl; auto.
38 |   destruct IHl; simpl; auto.
39 |   right; unfold not; intros [Hc1 | Hc2]; auto.
40 | Defined.
41 | 
42 | (* Init/Specif.v
43 |    つねにRequireされているので、proj1_sigは定義済み。*)
44 | Definition proj1'_sig (a : Type) (P : a -> Prop) (e:sig P) :=
45 |   match e with
46 |     | exist a b => a
47 |   end.
48 | 
49 | (* erutuf さんの diff.v *)
50 | (* boolを返すin関数を定義する。 *)
51 | Definition in_bool (a : A)(l : list A) : bool :=
52 |   proj1'_sig _ _ (bool_of_sumbool _ _ (in_dec Aeq_dec a l)).
53 | 
54 | (* in_bool と In が、同値であることを証明する。 *)
55 | Lemma in_bool_impl_In :
56 |   forall a l, in_bool a l = true -> In a l.
57 | Proof.
58 |   unfold in_bool.
59 |   intros a l H.
60 |   destruct (in_dec Aeq_dec a l); simpl in *; congruence.
61 | Qed.
62 | 
63 | Lemma In_impl_in_bool :
64 |   forall a l, In a l -> in_bool a l = true.
65 | Proof.
66 |   unfold in_bool.
67 |   intros a l H.
68 |   destruct (in_dec Aeq_dec a l); simpl in *; congruence.
69 | Qed.
70 | 
71 | (* END *)
72 | 


--------------------------------------------------------------------------------
/math-comp-book/ssr_irrelevance.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | 
 3 | Set Implicit Arguments.
 4 | Unset Strict Implicit.
 5 | Unset Printing Implicit Defensive.
 6 | 
 7 | (**
 8 | sigma type は、証人と証拠の組のことだが、証拠がboolの式であるとき、 
 9 | boolean sigma type (sigma type with boolean specifiations) という。
10 |  *)
11 | 
12 | Check odd : pred nat.
13 | 
14 | Definition odds := {x : nat | odd x}.       (* booelan sigma type *)
15 | 
16 | (**
17 | 証人(witness) が同じでも、証拠の異なるふたつの数、one_odd1とone_odd2 がある。
18 |   *)
19 | Definition one_odd1 : odds.
20 | Proof.
21 |     by exists 1.
22 | Defined.
23 | Print one_odd1.    (* = exist (fun x : nat => odd x) 1 is_true_true *)
24 | Print is_true_true.
25 | Print erefl.
26 | Print Logic.eq_refl.                        (* ∀x. x = x *)
27 | 
28 | Definition one_odd2 : odds.
29 | Proof.
30 |     by exists 1; rewrite -(addn0 1) addn0.  (* 1+0-0 *)
31 | Defined.
32 | Print one_odd2.    (* = exist (fun x : nat => odd x) 1 ...略... *)
33 | 
34 | (**
35 | one_odd1 の証拠は is_true_true すなわち true = true 。
36 | one_odd2 の証拠も同様に boolの等式の形である。
37 | （同じ型の）等式どうしは等しいという定理 irrelevance を使って証明できる。
38 | 
39 | 的外れ、見当違いの意味。
40 |  *)
41 | 
42 | Goal one_odd1 = one_odd2.
43 |   try reflexivity.                       (* still not convertible *)
44 |   congr exist.                           (* (true = true) = 略 *)
45 |   by apply: bool_irrelevance.
46 | Qed.
47 | 
48 | (**
49 | Mathcomp では、次の irrelevance が使える。
50 | より一般的な eqType について証明されていて、natとboolはそれを使って証明している。
51 | *)
52 | Check eq_irrelevance   : forall (T : eqType) (x y : T)    (e1 e2 : x = y), e1 = e2.
53 | Check bool_irrelevance : forall              (x y : bool) (E  E' : x = y), E = E'.
54 | Check nat_irrelevance  : forall              (x y : nat)  (E  E' : x = y), E = E'.
55 | 
56 | (**
57 | 不等式についても成り立つ。
58 |  *)
59 | Check le_irrelevance :
60 |   forall (m n : nat) (le_mn1 le_mn2 : (m <= n)%coq_nat), le_mn1 = le_mn2.
61 | Check lt_irrelevance :
62 |   forall (m n : nat) (lt_mn1 lt_mn2 : (m < n)%coq_nat),  lt_mn1 = lt_mn2.
63 | 
64 | (* END *)
65 | 


--------------------------------------------------------------------------------
/intro/2.v:
--------------------------------------------------------------------------------
 1 | (** ProofCafe Coq入門 #2 *)
 2 | (** 2017/8/19 @suharahiromichi  *)
 3 | 
 4 | Set Implicit Arguments.
 5 | 
 6 | (* 自然数 *)
 7 | Require Import Arith.
 8 | 
 9 | Goal forall x y z : nat, x * (y * z) = x * y * z.
10 | Proof.
11 |   intros.
12 |   Search (_ * (_ * _)).
13 |   (* Search では Notation は見つからない。 *)
14 |   now rewrite mult_assoc.                   (* Notation *)
15 |   Undo 1.
16 |   now rewrite Nat.mul_assoc.
17 |   Undo 1.
18 |   ring.
19 | Qed.
20 | 
21 | Goal forall x : nat, 1 * x = x.
22 | Proof.
23 |   intros.
24 |   now rewrite mult_1_l.                     (* Notation *)
25 |   Undo 1.
26 |   now rewrite Nat.mul_1_l.
27 |   Undo 1.
28 |   ring.
29 | Qed.
30 | 
31 | Goal forall x : nat, x * 1 = x.
32 | Proof.
33 |   intros.
34 |   now rewrite mult_1_r.                     (* Notation *)
35 |   Undo 1.
36 |   now rewrite Nat.mul_1_r.
37 |   Undo 1.
38 |   ring.
39 | Qed.
40 | 
41 | (* 整数 *)
42 | Require Import ZArith.
43 | Open Scope Z.
44 | 
45 | (* Scope については、以下を参照のこと。
46 | 
47 |    Coq RM
48 |    Chapter 12  Syntax extensions and interpretation scopes
49 |    12.2  Interpretation scopes
50 | 
51 |    https://coq.inria.fr/refman/Reference-Manual014.html
52 | 
53 |    主なコマンドは、Bind Scope, Open Scope, Close Scoep.
54 |    省略時解釈は、core_scope, type_scope, nat_scope の順番である。
55 |  *)
56 | 
57 | Goal forall x y z : Z, x * (y * z) = x * y * z.
58 | Proof.
59 |   intros.
60 |   now rewrite Zmult_assoc.                  (* Notation *)
61 |   Undo 1.
62 |   Search (_ * (_ * _)).                     (* Scope はSearchに影響するよう。 *)
63 |   now rewrite Z.mul_assoc.
64 |   Undo 1.
65 |   ring.
66 | Qed.
67 | 
68 | Goal forall x : Z, 1 * x = x.
69 | Proof.
70 |   intros.
71 |   now rewrite Zmult_1_l.                    (* Notation *)
72 |   Undo 1.
73 |   now rewrite Z.mul_1_l.
74 |   Undo 1.
75 |   ring.
76 | Qed.
77 | 
78 | Goal forall x : Z, x * 1 = x.
79 | Proof.
80 |   intros.
81 |   now rewrite Zmult_1_r.                    (* Notation *)
82 |   Undo 1.
83 |   now rewrite Z.mul_1_r.
84 |   Undo 1.
85 |   ring.
86 | Qed.
87 | 
88 | (* END *)
89 | 


--------------------------------------------------------------------------------
/gpt/gpt_list_app_assoc.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | ChatGPTにCoqのコードを書かせてみた（その2）
 3 | ==============================
 4 | 2023/05/20
 5 | 
 6 | 
 7 | @suharahiromichi
 8 | 
 9 | 
10 | ChatGPTにCoqのコードを書かせてみました。
11 | 
12 | ソフトウェアの基礎 ``https://proofcafe.org/sf/Lists_J.html``
13 | にある非形式的な証明を与えて、そこから形式的な証明をつくるように指示しました。
14 | 
15 | その結果が、「Coqを使って、上記の定理を形式化した証明を以下に示します。」から、
16 | 「この証明を実行すると、Coqが定理を証明し、証明が完了するはずです。」までです。
17 | 
18 | Coqのコードは修正不要で正しいもので、テキストの例とほぼ同じものでした。
19 | また、コード中のコメントは、ChatGPTの生成したコードに最初から含まれていました。
20 | *)
21 | 
22 | (**
23 | # 質問
24 | 
25 | 「
26 | 
27 | 定理証明支援系Coqを使って、以下の定理の証明を形式化してください。
28 | 
29 | 定理: 任意のリスト l1、 l2、 l3 について、 (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3) が成り立つ。
30 | 
31 | 証明: l1 についての帰納法で証明する
32 | まず、 l1 = [] と仮定して
33 |        ([] ++ l2) ++ l3 = [] ++ (l2 ++ l3)
34 | 
35 | を示す。これは ++ の定義から自明である。
36 | 
37 | 次に l1 = n::l1' かつ
38 |        (l1' ++ l2) ++ l3 = l1' ++ (l2 ++ l3)
39 | 
40 | （帰納法の仮定）と仮定して
41 |        ((n :: l1') ++ l2) ++ l3 = (n :: l1') ++ (l2 ++ l3)
42 | 
43 | を示す。 ++ の定義から、この式は以下のように変形できる。
44 |        n :: ((l1' ++ l2) ++ l3) = n :: (l1' ++ (l2 ++ l3))
45 | 
46 | これは帰納法の仮定から直接導かれる。 ☐
47 | 
48 | 」
49 | *)
50 | 
51 | (**
52 | # 回答
53 | 
54 | 「
55 | 
56 | Coqを使って、上記の定理を形式化した証明を以下に示します。
57 |  *)
58 | 
59 | Require Import Coq.Lists.List.
60 | 
61 | Theorem append_assoc : forall (l1 l2 l3 : list nat),
62 |   (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
63 | Proof.
64 |   intros l1 l2 l3.
65 |   induction l1 as [| n l1' IH].
66 |   - (* l1 = [] *)
67 |     simpl. reflexivity.
68 |   - (* l1 = n::l1' *)
69 |     simpl.
70 |     rewrite IH.
71 |     reflexivity.
72 | Qed.
73 | 
74 | (**
75 | この証明では、Coqのタクティクを使用して帰納法を適用しています。
76 | 最初にintrosタクティクを使用して、リストl1、l2、l3を仮定します。
77 | 次に、inductionタクティクを使用して、リストl1についての帰納法を開始します。2つのサブゴールが生成されます。
78 | 
79 | 最初のサブゴールでは、l1が空リスト[]の場合を扱っています。
80 | この場合、simplタクティクを使用して式を簡約し、reflexivityタクティクを使用して両辺が等しいことを示します。
81 | 
82 | 2番目のサブゴールでは、l1がn::l1'の形をしている場合を扱っています。simplタクティクを使用して
83 | 式を簡約し、rewriteタクティクを使用して帰納法の仮定IHを適用します。
84 | 最後に、reflexivityタクティクを使用して両辺が等しいことを示します。
85 | 
86 | この証明を実行すると、Coqが定理を証明し、証明が完了するはずです。
87 | 
88 | 」
89 |  *)
90 | 
91 | (* END *)
92 | 


--------------------------------------------------------------------------------
/math4/ssr_doubtimplication.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | 
 3 | Set Implicit Arguments.
 4 | Unset Strict Implicit.
 5 | Unset Printing Implicit Defensive.
 6 | 
 7 | Section DoubtImplication.
 8 |   
 9 |   (** 含意が満たすべき性質を満たす「何か」 *)
10 |   Variable Imp : bool -> bool -> bool.
11 | 
12 |   (** 含意っぽい記法の導入 `v` は `virtual` の略 *)
13 |   Notation "x ->v y" := (Imp x y) (at level 98, left associativity).
14 | 
15 |   Section a.
16 |     
17 |     Variable p q r : bool.
18 |     
19 |     (** 含意は反射的。前提 p が真だろうと偽だろうと「p ならば p」は正しい。 *)
20 |     Axiom imp_reflexive : p ->v p.
21 |     
22 |     (** 含意は推移的 *)
23 |     Axiom imp_transitive : p ->v q -> q ->v r -> p ->v r.
24 |     
25 |     (** モーダスポネンス。「p ならば q」は、p が正しければ q が成り立つことを意味する。 *)
26 |     Axiom imp_elim : p ->v q -> p ==> q.
27 |     
28 |     (** 結論が無条件に正しいなら、仮定をつけても正しい *)
29 |     Axiom imp_intro : q -> p ->v q.
30 |     
31 |     (** ある前提から `q` と `r` が導出できるなら、`q ∧ r` も導出できる *)
32 |     Axiom intro_and : p ->v q -> p ->v r -> p ->v (q && r).
33 |     
34 |     (** ある前提から `q ∧ r` が導出できるなら、`q` も導出できる *)
35 |     Axiom elim_and_left : p ->v (q && r) -> p ->v q.
36 |     
37 |     (** ある前提から `q ∧ r` が導出できるなら、`r` も導出できる *)
38 |     Axiom elim_and_right : p ->v (q && r) -> p ->v r.
39 |     
40 |     (** ある前提から `q` が導出できるなら、`q ∨ r` が導出できる *)
41 |     Axiom intro_or_left : p ->v q -> p ->v (q || r).
42 |     
43 |     (** ある前提から `r` が導出できるなら、`q ∨ r` が導出できる *)
44 |     Axiom intro_or_right : p ->v r -> p ->v (q || r).
45 |     
46 |   End a.
47 | 
48 |   (* 爆発定理を証明する。 *)
49 |   Lemma imp_explosion (p : bool) : false ->v p.
50 |   Proof.
51 |     apply: (@elim_and_left false p false).
52 |     rewrite andbF.
53 |     apply: imp_reflexive.
54 |   Qed.
55 |   
56 |   (* 証明したいもの。 *)
57 |   Theorem imp_valid (p q : bool) : (p ->v q) <-> (p ==> q).
58 |   Proof.
59 |     split.
60 |     - by apply: imp_elim.
61 |     - rewrite /implb.
62 |       case: ifP.
63 |       + move=> HP.
64 |         by apply: imp_intro.
65 |       + move=> HnP _.
66 |         by apply: imp_explosion.
67 |   Qed.
68 |   
69 | End DoubtImplication.
70 | 
71 | (* END *)
72 | 


--------------------------------------------------------------------------------
/ssr/ssr_set_a_a_b__b.v:
--------------------------------------------------------------------------------
 1 | Require Import ssreflect ssrbool ssrnat.
 2 | Require Import ssrfun fintype finset.
 3 | 
 4 | Variable T : finType.
 5 | 
 6 | (* B ⊆ A のとき、A - (A - B) = B を証明する。 *)
 7 | 
 8 | (* finsetの中の定理を使用する。 *)
 9 | Lemma a_a_b__b (A B : {set T}) : B \subset A -> (A :\: (A :\: B)) = B.
10 | Proof.
11 |   move=> H.
12 |   rewrite setDDr setDv set0U.
13 |   by apply/setIidPr.
14 | Qed.
15 | 
16 | (* 一旦 x \in A にして、論理式にリフレクトして証明する。 *)
17 | Lemma a_a_b__b' (A B : {set T}) : B \subset A -> (A :\: (A :\: B)) = B.
18 | Proof.
19 |   move/setIidPr.
20 |   move/setP => H.
21 |   apply/setP. move: H.
22 |   rewrite /eq_mem => H x.
23 |   (* x \in A の形式になる。 *)
24 |   rewrite -(H x) {H}.
25 |   apply/setDP/idP.
26 |   (* -> *)
27 |   rewrite -in_setC setDE setCI in_setU.
28 |   case=> H1. move/orP=> H2. apply/setIP.
29 |   (* 論理式にばらした。 *)
30 |   case H2 => H3 {H2}.
31 |   split.
32 |   by [].
33 |   by move/setCP in H3.
34 |   by rewrite setCK in H3.
35 |   (* <- *)  
36 |   move/setIP.
37 |   case=> H1 H2.
38 |   rewrite -in_setC.
39 |   split.
40 |   by [].
41 |   apply/setCP.
42 |   unfold not=> H3.
43 |   move/setDP in H3.
44 |   destruct H3.
45 |   rewrite -in_setC in H0.
46 |   move/setCP in H0.
47 |   unfold not in H0.
48 |   by [].
49 | Qed.
50 | 
51 | (* Boolを経由しないようにする。 *)
52 | Lemma a_a_b__b'' (A B : {set T}) : B \subset A -> (A :\: (A :\: B)) = B.
53 | Proof.
54 |   move/setIidPr.
55 |   move/setP => H.
56 |   apply/setP. move: H.
57 |   rewrite /eq_mem => H x.
58 |   (* x \in A の形式になる。 *)
59 |   rewrite -(H x) {H}.
60 |   apply/setDP/idP.
61 |   (* -> *)
62 |   rewrite -in_setC setDE setCI.
63 |   case=> H1.
64 |   move/setUP => H2.
65 |   apply/setIP.
66 |   case H2 => H3 {H2}.
67 |   split.
68 |   by [].
69 |   by move/setCP in H3.
70 |   by rewrite setCK in H3.
71 |   (* <- *)  
72 |   move/setIP.
73 |   case=> H1 H2.
74 |   rewrite -in_setC.
75 |   split.
76 |   by [].
77 |   apply/setCP.
78 |   unfold not=> H3.
79 |   move/setDP in H3.
80 |   destruct H3.
81 |   rewrite -in_setC in H0.
82 |   move/setCP in H0.
83 |   unfold not in H0.
84 |   by [].
85 | Qed.
86 | 
87 | (* END *)
88 | 
89 | 


--------------------------------------------------------------------------------
/gitcrc/coq_gitcrc_3_8_EMonoid.v:
--------------------------------------------------------------------------------
 1 | (* Examples of type classes and Setoids *)
 2 | 
 3 | Set Implicit Arguments.
 4 | Require Import List.
 5 | Require Import ZArith.
 6 | Require Import Morphisms Relations.
 7 | 
 8 | Require Import coq_gitcrc_3_digest.
 9 | Require Import coq_gitcrc_3_7_digest.
10 | 
11 | Class EMonoid (A:Type) (E_eq :relation  A) (dot : A->A->A) (one : A) :=
12 |   {
13 |     E_rel :> Equivalence E_eq; 
14 |     dot_proper :> Proper (E_eq ==> E_eq ==> E_eq) dot; 
15 |     E_dot_assoc : forall x y z:A, E_eq (dot x (dot y z)) (dot (dot x y) z);
16 |     E_one_left : forall x, E_eq (dot one  x) x;
17 |     E_one_right : forall x, E_eq (dot x  one) x
18 |   }.
19 | 
20 | Generalizable Variables A E_eq dot one.
21 | 
22 | Fixpoint Epower `{M: EMonoid } (a:A) (n:nat) :=
23 |   match n with
24 |     | 0%nat => one
25 |     | S p => dot a (Epower a p)
26 |   end.
27 | 
28 | Instance Route : EMonoid route_equiv (@app _) nil.
29 | Proof.
30 |   split.
31 |   apply route_equiv_Equiv.
32 |   apply app_route_Proper.
33 |   intros x y z P;repeat rewrite route_compose; trivial.
34 |   intros x P;repeat rewrite route_compose; trivial.
35 |   intros x P;repeat rewrite route_compose; trivial.
36 | Qed.
37 | 
38 | Program Instance Route' : EMonoid route_equiv (@app _) nil.
39 | Next Obligation.
40 | Proof.
41 |   intros P; repeat rewrite route_compose; trivial.
42 | Qed.
43 | Next Obligation.
44 | Proof.
45 |   intros P; repeat rewrite route_compose; trivial.
46 | Qed.
47 | Next Obligation.
48 |   intros P; repeat rewrite route_compose; trivial.
49 | Qed.
50 | 
51 | Goal forall n, Epower (South::North::nil) n =r= nil.
52 | Proof.
53 |   induction n; simpl.
54 |   - reflexivity.
55 |   - rewrite IHn.
56 |     route_eq_tac.
57 | Qed.
58 | 
59 | (* ****** *)
60 | 
61 | Class Abelian_EMonoid `(M:EMonoid ) :=
62 |   {
63 |     Edot_comm : forall x y, E_eq (dot x  y)  (dot y  x)
64 |   }.
65 | 
66 | Instance AbelianRoute : Abelian_EMonoid Route. 
67 |   split;  apply app_comm.
68 | Qed.
69 | 
70 | Program Instance AbelianRoute' : Abelian_EMonoid Route. 
71 | Next Obligation.
72 |   apply app_comm.
73 | Qed.
74 | 
75 | (* END *)
76 | 


--------------------------------------------------------------------------------
/coq_sumbool_2_not_use_variable.v:
--------------------------------------------------------------------------------
 1 | (** sumbool は、Bool.Sumbool で定義さてているが、
 2 |    ここではすべて自分で定義してみる。 *)
 3 | 
 4 | (* 標準ライブラリ Sumbool.v *)
 5 | Hypothesis Aeq_dec :
 6 |   forall A : Type, forall a b : A, {a = b} + {a <> b}.
 7 | 
 8 | Definition bool_of_sumbool :
 9 |   forall A B:Prop, {A} + {B} -> {b : bool | if b then A else B}.
10 |   intros A B H.
11 |   elim H; intro; [exists true | exists false]; assumption.
12 | Defined.
13 | 
14 | (* 標準ライブラリ List.v *)
15 | Inductive list (A : Type) : Type :=
16 | | nil : list A
17 | | cons : A -> list A -> list A.
18 | 
19 | Fixpoint In (A:Type) (a:A) (l:list A) : Prop :=
20 |   match l with
21 |     | nil => False
22 |     | (cons b m) => b = a \/ In _ a m
23 |   end.
24 | 
25 | Theorem in_nil : forall A:Type, forall a : A, ~ In _ a (nil _).
26 | Proof.
27 |   unfold not; intros A a H; inversion_clear H.
28 | Qed.
29 | 
30 | Theorem in_dec :
31 |   (forall (A:Type) (x y:A), {x = y} + {x <> y}) ->
32 |   forall (A:Type) (a:A) (l:list A), {In _ a l} + {~ In _ a l}.
33 | Proof.
34 |   intro H; induction l as [| a0 l IHl].
35 |   right; apply in_nil.
36 |   destruct (H A a0 a); simpl; auto.
37 |   destruct IHl; simpl; auto.
38 |   right; unfold not; intros [Hc1 | Hc2]; auto.
39 | Defined.
40 | 
41 | (* Init/Specif.v
42 |    つねにRequireされているので、proj1_sigは定義済み。*)
43 | Definition proj1'_sig (A : Type) (P : A -> Prop) (e:sig P) :=
44 |   match e with
45 |     | exist a b => a
46 |   end.
47 | 
48 | (* erutuf さんの diff.v *)
49 | (* boolを返すin関数を定義する。 *)
50 | Definition in_bool (A : Type) (a : A)(l : list A) : bool :=
51 |   proj1'_sig _ _ (bool_of_sumbool _ _ (in_dec Aeq_dec _ a l)).
52 | 
53 | (* in_bool と In が、同値であることを証明する。 *)
54 | Lemma in_bool_impl_In :
55 |   forall A:Type, forall a l, in_bool A a l = true -> In A a l.
56 | Proof.
57 |   unfold in_bool.
58 |   intros a l H.
59 |   destruct (in_dec Aeq_dec a l); simpl in *; congruence.
60 | Qed.
61 | 
62 | Lemma In_impl_in_bool :
63 |   forall A:Type, forall a l, In A a l -> in_bool A a l = true.
64 | Proof.
65 |   unfold in_bool.
66 |   intros a l H.
67 |   destruct (in_dec Aeq_dec a l); simpl in *; congruence.
68 | Qed.
69 | 
70 | (* END *)
71 | 


--------------------------------------------------------------------------------
/ssr/ssr_state_monad.v:
--------------------------------------------------------------------------------
 1 | (** The Hoare State Monad - Proof Pearl, Wouter Swierstra *)
 2 | (** その前半部分 State Monad *)
 3 | (* @suharahiromichi 2014_01_13 *)
 4 | 
 5 | From mathcomp Require Import ssreflect ssrbool ssrnat seq eqtype.
 6 | From mathcomp Require Import ssrfun.
 7 | Require Import String.                      (* Error *)
 8 | Require Import Program.                     (* Program *)
 9 | 
10 | Set Implicit Arguments.
11 | Unset Strict Implicit.
12 | Unset Printing Implicit Defensive.
13 | 
14 | Inductive Tree (a : Set) : Set :=
15 | | Leaf : a -> Tree a
16 | | Node : Tree a -> Tree a -> Tree a.
17 | 
18 | Fixpoint relabel' (a : Set) (t : Tree a) (s : nat) : Tree nat * nat
19 |   :=
20 |     match t with
21 |       | Leaf _ =>
22 |         (Leaf s, s.+1)
23 |       | Node l r =>
24 |         let (l , s ) := relabel' l s in
25 |         let (r , s ) := relabel' r s in
26 |         (Node l r , s )
27 |    end.
28 | 
29 | Section state_monad.
30 | 
31 | Variable st : Set.
32 |   
33 | Definition State (a : Set) : Type :=
34 |   st -> a * st.
35 | 
36 | Definition ret {a : Set} : a -> State a := fun x s => (x , s).
37 | 
38 | Definition bind {a b : Set} : State a -> (a -> State b) -> State b
39 |   := fun c1 c2 s1 =>
40 |        let (x , s2 ) := c1 s1 in c2 x s2 .
41 | 
42 | Definition bind2 {a b : Set} : State a -> State b -> State b
43 |   := fun p1 p2 =>
44 |        bind p1 (fun _ => p2).               (* p1 >>= (fun _ => p2) *)
45 | 
46 | Definition get : State st :=
47 |   fun s => (s, s).
48 | 
49 | Definition put : st -> State unit :=
50 |   fun s _ => (tt, s).
51 | 
52 | End state_monad.
53 | Infix ">>=" := bind (right associativity, at level 71).
54 | Infix ">>>" := bind2 (right associativity, at level 71).
55 | 
56 | Fixpoint relabel {a : Set} (t : Tree a) : State nat (Tree nat)
57 |   :=
58 |     match t with
59 |       | Leaf _ =>
60 |         @get nat >>=
61 |             fun n => @put nat n.+1 >>>
62 |                           ret (Leaf n)
63 |       | Node l r =>
64 |         relabel l >>=
65 |         fun l => relabel r >>=
66 |                  fun r => ret (Node l r)
67 |     end.
68 | 
69 | (* END *)
70 | 


--------------------------------------------------------------------------------
/tools/line-edit.pl:
--------------------------------------------------------------------------------
 1 | #! /usr/local/bin/perl
 2 | 
 3 | # ファイルにおいて、一致する1行とその前後の空行を削除する。
 4 | # 一致する行は、1箇所だけとする（繰り返し実行すればよい）。
 5 | # 末尾に空行がある場合、その一つ前とマッチしても、空行は削除しない。
 6 | # 全体で2行以上あるものとする。1行だけのファイルは対応しない。
 7 | 
 8 | # 使い方
 9 | #  ./line-edit.pl SUPRESS_ALL < test.txt| 
10 | #
11 | 
12 | my $pat = shift;
13 |     
14 | my $debug = 1;
15 | 
16 | my $line1 = "top";
17 | my $line2 = "top";
18 | my $line3 = "top";
19 | 
20 | my $data1;
21 | my $data2;
22 | my $data3;
23 | 
24 | while (<>) {
25 |     $line1 = $line2;
26 |     $line2 = $line3;
27 |     if ($_ =~ /^\s*$/) {
28 |         $line3 = "nul";                     # 空行
29 |     } elsif ($_ =~ /$pat/) {
30 |         $line3 = "cmp";
31 |     } else {
32 |         $line3 = "oth";
33 |     }
34 |     
35 |     $data1 = $data2;
36 |     $data2 = $data3;
37 |     $data3 = $_;
38 | 
39 | if ($debug) {    
40 |     printf ("lines %s %s %s\n", $line1, $line2, $line3);
41 | }
42 |     if ($line2 eq "cmp") {
43 |         if      ($line1 eq "top" && $line3 eq "nul") {
44 |             ;
45 |         } elsif ($line1 eq "top" && $line3 eq "oth") {
46 |             print $data3;
47 |         } elsif ($line1 eq "nul" && $line3 eq "nul") {
48 |             print $data1;                   # NULLを出力する。
49 |         } elsif ($data1 eq "nul" && $line3 eq "oth") {
50 |             print $data3;
51 |         } elsif ($line1 eq "oth" && $line3 eq "nul") {
52 |             print $data1;
53 |         } elsif ($line1 eq "oth" && $line3 eq "oth") {
54 |             print $data1, $data3;
55 |         }
56 |         # 残り物の処理
57 |         while (<>) {
58 |             print $_;
59 |         }
60 |         exit 1;
61 |     } else {
62 |         print $data1;
63 |     }
64 | }
65 | 
66 | if ($debug) {
67 |     printf ("------\n");
68 |     printf ("lines %s %s %s\n", $line1, $line2, $line3);
69 | }
70 | 
71 | # シフトしていない。
72 | if ($line3 eq "cmp") {
73 |     if      ($line2 eq "top") {
74 |         ;
75 |     } elsif ($line2 eq "nul") {
76 |         print $data2;                       # NULLを出力する。
77 |     } elsif ($line2 eq "oth") {
78 |         print $data2;
79 |     }
80 |     exit 1;
81 | } else {
82 |     print $data2;
83 |     print $data3;
84 |     exit 0;
85 | }
86 | 
87 | # END
88 | 


--------------------------------------------------------------------------------
/coq_ex_sig_sumbool.v:
--------------------------------------------------------------------------------
 1 | (* 2011_01_22 *)
 2 | 
 3 | 
 4 | (* 依存積 *)
 5 | (* Prop型 *)
 6 | Inductive my_ex (A : Type) (P : A -> Prop) : Prop :=
 7 | | my_ex_intro : forall x : A, P x -> my_ex A P.
 8 | Notation "'exists' x : A, P" := (my_ex (fun A (x : A) => P x)) (at level 190).
 9 | 
10 | 
11 | (* 関数型 *)
12 | Inductive my_sig (A : Type) (P : A -> Prop) : Type :=
13 | | my_exist : forall x : A, P x -> my_sig A P.
14 | Notation "{ x : A, P }" := (my_sig (fun A (x : A) => P x)) (at level 190).
15 | 
16 | 
17 | 
18 | 
19 | (* 依存和 *)
20 | (* Prop型 （普通の or） *)
21 | Inductive my_or (A B : Prop) : Prop :=
22 | | my_or_introl : A -> my_or A B
23 | | my_or_intror : B -> my_or A B.
24 | Notation " A \/ B " := (my_or A B).
25 | 
26 | 
27 | (* 関数型 *)
28 | Inductive my_sumbool (A B : Prop) : Set :=
29 | | my_left  : A -> my_sumbool A B
30 | | my_right : B -> my_sumbool A B.
31 | Notation "{ A } + { B }" := (my_sumbool A B).
32 | 
33 | 
34 | (*
35 |    sumboolで left と rightタクティクスが使える理由：
36 |    
37 |    タクティクス left は、constructor 1
38 |    タクティクス right は、constructor 2
39 |    の略記で、それぞれ1番めと2番めのコンストラクタをapplyする。
40 |    my_right, my_left の順番に書くと
41 |    タクティクス left が、apply my_right になってしまう。
42 | *)
43 | 
44 | 
45 | (********)
46 | (* 応用 *)
47 | (********)
48 | 
49 | 
50 | (* exists n, 0 <= n : Prop
51 |    と同じものを定義する。
52 |    ただし、my_ex を使ったわけではない。
53 |    *)
54 | Inductive my_le_zero : nat -> Prop :=
55 | | my_le_0 : my_le_zero 0
56 | | my_le_S : forall n : nat,
57 |   my_le_zero n -> my_le_zero (S n).
58 | 
59 | 
60 | Goal my_le_zero 1.                          (* 1 *)
61 | Proof.
62 |   apply my_le_S.
63 |   apply my_le_0.
64 | Qed.
65 | 
66 | 
67 | 
68 | 
69 | (* zerop :
70 |    {n = 0} + {0 < n} と同じものを定義する
71 |    *)
72 | Require Import Arith.                       (* gt_le_S など *)
73 | Definition my_zerop n : my_sumbool (n = 0) (0 < n).
74 | destruct n.
75 | apply my_left; apply refl_equal.
76 | apply my_right; change (1 <= S n);
77 |   apply gt_le_S; change (0 < S n);
78 |     apply lt_O_Sn.
79 | Defined.                                    (* Defined *)
80 | 
81 | 
82 | Eval compute in (match my_zerop 1 with
83 |                    | my_left _ => 0
84 |                    | my_right _ => 100 end). (* 100 *)
85 | 
86 | 
87 | (* END *)


--------------------------------------------------------------------------------
/tools/mkmd.pl:
--------------------------------------------------------------------------------
 1 | #! /usr/bin/perl
 2 | # $Id:$
 3 | 
 4 | my $filename = $ARGV[0];
 5 | 
 6 | if ($filename =~ /\.v$/) {
 7 |     $lang = "coq";
 8 | } elsif ($filename =~ /\.swi$/) {
 9 |     $lang = "prolog";
10 | } elsif ($filename =~ /\.[ch]$/) {
11 |     $lang = "C";
12 | }
13 | 
14 | my $debug = 0;
15 | 
16 | my $istext = 0;                             # Markdownの地のテキストである。
17 | 
18 | my $isprog = 0;                             # Markdownのプログラム引用である。
19 | my $lastisprog = 0;
20 | 
21 | my $ispint = 0;         # Markdownの地のテキストの中のプログラムや数式である。
22 | 
23 | while (<>) {
24 |     chop;
25 | 
26 |     # プログラムの部分かどうかを判定する。
27 |     if (/^\s*$/) {
28 |         printf("\n");
29 |         next;
30 |     } elsif (/^\(\* END \*\)/i || /^\/\* END \*\//i) {
31 |         next;
32 |     } elsif (/^\(\*\* \s* $ /x || /^\/\*\* \s* $ /x) {
33 |         $isprog = 0;
34 |         next;
35 |     } elsif ($isprog == 0 && (/^\s*\*\)/ || /^\s*\*\//)) {
36 |         $isprog = 1;
37 |         printf("\n");
38 |         next;
39 |     }
40 | 
41 |     # テキストの部分かどうかを判定する。
42 |     # Markdownの指示記号から始まる行は、テキストに含めない。
43 |     if ($isprog == 0 && /^\S/ && /^[^0-9#%=@\*\+\-\>\`\|]/) {
44 |         $istext = 1;
45 |     } else {
46 |         $istext = 0;
47 |     }
48 | 
49 |     # 数式かどうかを判定する。
50 |     if ($ispint == 0 && /^```/) {
51 |         $ispint = 1;
52 |     } elsif ($ispint == 1 && /^```/) {
53 |         $ispint = 0;
54 |     }
55 | 
56 |     # プログラムの部分を```でくくる。
57 |    if ($lastisprog == 0 && $isprog == 1) {       # 開始か？
58 |        printf("\n\n```%s:\n", $lang);            # ```開く。
59 |     } elsif ($lastisprog == 1 && $isprog == 0) { # 終了か？
60 |         printf("\n\n```\n");                     # ```閉じる。
61 |     }
62 |     
63 |     if ($debug == 1) {
64 |         printf("\n");
65 |         printf("%d %d %d", $isprog, $istext, $ispint);
66 |     }
67 | 
68 |     # 行をつなげる。
69 |     if ($isprog == 0 && $istext == 1 && $ispint == 0) {
70 |         ;                               # つなげるために、改行しない。
71 |     } else {
72 |         printf("\n");                     # つなげるために、改行する。
73 |     }
74 |     
75 |     printf("%s", $_);
76 |     
77 |     $lastisprog = $isprog;
78 | }
79 | 
80 | if ($isprog == 1) {
81 |     printf("\n```\n");
82 | }
83 | 
84 | # END
85 | 


--------------------------------------------------------------------------------
/pearl/ssr_ex_card.v:
--------------------------------------------------------------------------------
  1 | (**
  2 | 有限集合の濃度の存在を証明する
  3 | ======
  4 | 2019/05/01
  5 | 
  6 | この文書のソースコードは以下にあります。
  7 | 
  8 | 
  9 | https://github.com/suharahiromichi/coq/blob/master/pearl/ssr_ex_card.v
 10 | 
 11 |  *)
 12 | 
 13 | (**
 14 | OCaml 4.07.1, Coq 8.9.0, MathComp 1.9.0
 15 |  *)
 16 | 
 17 | (**
 18 | # 説明
 19 | 
 20 | へんなタイトルですが、MathComp を使った定理の証明の問題です。
 21 | 
 22 | 有限集合の濃度、すなわち要素の個数は、適当な自然数に一意的に決まります。
 23 | 濃度を ``#| _ |`` で表すとすると、
 24 | 
 25 | ``∃ i : nat, #| p | = i``
 26 | 
 27 | 
 28 | ですね。これ自体は自明なのですが、MathComp で証明しようとすると、
 29 | 取り付く島もないように見えます。
 30 | 
 31 | でも、すこし考えてみると、
 32 | MathComp の場合、集合は有限型(finType)をドメインとするbooleanな関数で
 33 | 表されます。すなわち、``T : finType`` とすると、
 34 | 
 35 | ``p : pred T``
 36 | 
 37 | 
 38 | なお、``pred T`` は単に ``T -> bool`` の Notation (構文糖衣) です。
 39 | 
 40 | pが、常にtrueを返す場合が全集合、常にfalseを返す場合が空集合になります。
 41 | このように、集合pと関数pが同一視されるので、集合pの濃度は、
 42 | 「型Tの要素のうち、関数pがtrueを返す要素の数」
 43 | ということになります。
 44 | 
 45 | このことから、
 46 | 型Tの要素の全体をしめす finType の enum フィールドの中身 (リスト、seq型) について、
 47 | 関数pでフィルタした結果のサイズが決まることを証明すればよいことになります。
 48 | 
 49 | 型 T から、その enum フィールドの中身を取り出すのは、次のようにします。
 50 | 
 51 | ``Finite.enum T``
 52 | 
 53 | 
 54 | 後の証明は、単にリストの要素についての帰納法です。
 55 | 
 56 | ほとんど自明であるがゆえに、
 57 | MathCompにおける実装の裏側を知らないと解けない問題の例といえるでしょうか。
 58 |  *)
 59 | 
 60 | (**
 61 | # コード例
 62 |  *)
 63 | 
 64 | From mathcomp Require Import all_ssreflect.
 65 | 
 66 | Set Implicit Arguments.
 67 | Unset Strict Implicit.
 68 | Unset Printing Implicit Defensive.
 69 | (* Set Print All. *)
 70 | 
 71 | Section Test.
 72 |   
 73 |   Variable T : finType.
 74 |   Variable p : pred T.                      (* T -> bool *)
 75 | 
 76 |   Lemma ex_card : exists (i : nat), #| p | = i.
 77 |   Proof.
 78 |     rewrite unlock /card /enum_mem.
 79 |     elim: (Finite.enum T).
 80 |     - by exists 0.
 81 |     - move=> x s /= [i IHs].
 82 |       case: ifP => /=.
 83 |       + exists i.+1.
 84 |           by rewrite IHs.
 85 |       + by exists i.
 86 |   Qed.
 87 | 
 88 | End Test.
 89 | 
 90 | (**
 91 | # 最初に使った箇所
 92 | 
 93 | 単一化の証明 http://fetburner.hatenablog.com/entry/2015/12/06/224619
 94 | 
 95 | Unify.v を MathComp への移植するときに必要になりました。移植例：
 96 | 
 97 | https://github.com/suharahiromichi/coq/blob/master/unify/ssr_unify_bool_3.v
 98 | *)
 99 | 
100 | (* END *)
101 | 


--------------------------------------------------------------------------------
/coq_cps_fib.v:
--------------------------------------------------------------------------------
 1 | (**
 2 |    CPS
 3 |    フィボナッチ数
 4 |    2012_11_02
 5 | 
 6 |    参考：
 7 |    「CPS変換されたフィボナッチ関数の証明をしてみた」
 8 |    http://d.hatena.ne.jp/yoshihiro503/20100830#p2
 9 |    *)
10 | 
11 | (** 普通のフィボナッチ関数の定義 *)
12 | Fixpoint fib (n: nat) {struct n} : nat :=
13 |   match n with
14 |       | 0 => 1
15 |       | 1 => 1
16 |       | S (S m as sm) => fib sm + fib m
17 |   end.
18 | Eval cbv in fib 5.                          (* 8 *)
19 | Eval cbv in fib 6.                          (* 13 *)
20 | 
21 | (** CPS変換されたフィボナッチ関数の定義 *)
22 | Fixpoint fib_cps (n : nat) (cont : nat -> nat) {struct n} : nat :=
23 |   match n with
24 |     | 0 =>  cont 1
25 |     | 1 =>  cont 1
26 |     | S ((S m) as sm) =>
27 |       fib_cps sm (fun r1 => fib_cps m (fun r2 => cont (r1 + r2)))
28 |   end.
29 | Eval cbv in fib_cps 5 (fun r => r).
30 | Eval cbv in fib_cps 6 (fun r => r).
31 | 
32 | (** 補題: fib_cpsの定義の三番目の節を取り出したもので、
33 |    fib_cpsの計算を一段進めるのに使う。 *)
34 | Lemma fib_cps_SSn : forall n f,
35 |   fib_cps (S (S n)) f =
36 |   fib_cps (S n) (fun r1 => fib_cps n (fun r2 => f (r1 + r2))).
37 | Proof.
38 |   reflexivity.
39 | Qed.
40 | 
41 | (** より強い定理 *)
42 | Theorem eq_fib_fib_cps_aux : forall n,
43 |   (forall f, f (fib n) = fib_cps n f) /\
44 |   (forall g, g (fib (S n)) = fib_cps (S n) g).
45 | Proof.
46 |   induction n.
47 | 
48 |   (* 0 のとき *)
49 |   split.                                   (* Goalのandを分解する。 *)
50 |   (** andの左 *)
51 |   intro f.
52 |   simpl.                                 (* f (fib 0) = fib_cps 0 f *)
53 |   reflexivity.
54 |   (** andの右 *)
55 |   intro g.
56 |   simpl.                                 (* g (fib 1) = fib_cps 1 g *)
57 |   reflexivity.
58 | 
59 |   (* Sn のとき *)
60 |   destruct IHn as [Hf Hg].                 (* 前提のandを分解する。 *)
61 |   split.                                   (* Goalのandを分解する。 *)
62 |   (** andの左 *)
63 |   intro f.
64 |   apply Hg.
65 |   (** andの右 *)
66 |   intro g.
67 |   rewrite fib_cps_SSn.
68 |   rewrite <- Hg.
69 |   rewrite <- Hf.
70 |   simpl.               (* g (fib (S (S n))) = g (fib (S n) + fib n) *)
71 |   reflexivity.
72 | Qed.
73 | Print eq_fib_fib_cps_aux.
74 | 
75 | (** 証明するべきもの *)
76 | Theorem eq_fib_fib_cps : forall n f, f (fib n) = fib_cps n f.
77 | Proof.
78 |   intros n f.
79 |   destruct (eq_fib_fib_cps_aux n).
80 |   apply H.
81 | Qed.
82 | Print eq_fib_fib_cps.
83 | 
84 | (* END *)
85 | 


--------------------------------------------------------------------------------
/pnp/ssr_htt_alter_x.v:
--------------------------------------------------------------------------------
 1 | (** Programs and Proofs Ilya Sergey *)
 2 | (* http://ilyasergey.net/pnp/ *)
 3 | 
 4 | (** * 「Hoare Type Theory の基礎」から抜粋 *)
 5 | (** * Elements of Hoare Type Theory *)
 6 | 
 7 | Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
 8 | Add LoadPath "./../htt".
 9 | Require Import prelude pred pcm unionmap heap heaptac
10 |         stmod stsep stlog stlogR.
11 | 
12 | Set Implicit Arguments.
13 | Unset Strict Implicit.
14 | Unset Printing Implicit Defensive.
15 | 
16 | (**
17 | Hoare Type とは、依存型に基づいて、
18 | Hoareスタイルのspecificationをコード化したもの。
19 |  *)
20 | (* All these observation resulted in a series of works on Hoare Type
21 | Theory (or just HTT), which defines a notion of an indexed Hoare monad
22 | (or, Hoare type) as a mechanism to encode Hoare-style specifications
23 | as dependent types and reduce the verification of effectful 
24 | progress to proving propositions in Coq. *)
25 | 
26 | (** * Structuring the program verification in HTT *)
27 | 
28 | (* NOTE: the current implementation of HTT does not support
29 | value/type dependencies in the logical variables (e.g., {T (x: T)}),
30 | so such cases won't be properly handled by the ghR lemma. *)
31 | 
32 | (** Hoare Type  *)
33 | Definition alter_x_tp A (x : ptr) (v : A) :=
34 |   (* Aは任意の型の意味。 *)
35 |   {(y : ptr) (Y : nat)},                    (* Y の型はなんでもいい。 *)
36 |   STsep (
37 |       (** pre-condition : heap -> Prop *)
38 |       fun h => exists B (w : B), h = x :-> w \+ y :-> Y,
39 |       (** post-condition : unit -> heap -> Prop
40 |           この場合、実行結果は unit（いわゆるvoid）である。 *)
41 |       [vfun (tt : unit) h => h = x :-> v \+ y :-> Y]
42 |     ).
43 | 
44 | (** 証明するもの。 *)
45 | Program Definition alter_x A (x : ptr) (v : A) : alter_x_tp x v :=
46 |   Do (x ::= v).                             (* 命令文 *)
47 | Next Obligation.
48 |   apply: ghR.                               (* y と Y を外に出す。 *)
49 |   
50 |   move=> h1 [y Y] [B] [w] H.                (* h1 はpre-condのheap *)
51 |   (* H は、h1 = ......  *)
52 |   rewrite H.                                (* h1 を展開する。 *)
53 |   move=> _ /=.                              (* .1 と .2 を計算する。 *)
54 | 
55 |   (* 「verify 前提のheap 命令文 実行結果」 のかたちになる。  *)
56 |   Search (verify _ (_ ::= _) _).
57 |   apply: val_writeR => _ /=.                (* validの項は捨ててよい。 *)
58 |   by [].
59 | (* 代わりに by heval. でもよい。 *)
60 | Qed.
61 | 
62 | (* END *)
63 | 


--------------------------------------------------------------------------------
/iii/ssr_transpose.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | プログラミング Coq 停止性が明らかでない関数を定義するには
 3 | http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt7.html
 4 | 
 5 | 練習問題をSSReflectに書き直した。
 6 | *)
 7 | 
 8 | Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
 9 | 
10 | Set Implicit Arguments.
11 | Unset Strict Implicit.
12 | Unset Printing Implicit Defensive.
13 | Set Print All.
14 | 
15 | Definition tail (A : Type) (l : list A) :=
16 |   match l with
17 |     | nil => nil
18 |     | a :: m => m
19 |   end.
20 | 
21 | Check head 0 : seq nat -> nat.
22 | Check last 0 : seq nat -> nat.
23 | Check map (head 0) : seq (seq nat) -> seq nat.
24 | Check @tail nat : seq nat -> seq nat.
25 | Check map (@tail nat) : seq (seq nat) -> seq (seq nat).
26 | Check @tail (seq nat) : seq (seq nat) -> seq (seq nat).
27 | Check map (@tail (seq nat)) : seq (seq (seq nat)) -> seq (seq (seq nat)).
28 | Check (fun (l : seq (seq nat)) => length (head nil l)).
29 | 
30 | Require Import Program.Wf.
31 | (* measure の次の括弧が要る。 *)
32 | Program Fixpoint transpose (l : seq (seq nat))
33 |         {measure ((fun l => length (head nil l)) l)} : seq (seq nat) :=
34 |   match l with
35 |     | nil => nil
36 |     | nil :: _ => nil
37 |     | (x :: xs) :: xss =>
38 |       map (head 0) l :: transpose (map (@tail nat) l)
39 |   end.
40 | (* No obligations *)
41 | 
42 | Check transpose : seq (seq nat) -> seq (seq nat).
43 | Eval compute in transpose [:: [::11; 12; 13]; 
44 |                             [:: 21; 22; 23; 24];
45 |                             [:: 31; 32]].
46 | (*  [:: [:: 11; 21; 31]; [:: 12; 22; 32]; [:: 13; 23; 0]] *)
47 | 
48 | Require Import Recdef.
49 | (* measure の次の括弧がいらない。 *)
50 | Function transpose' (l : seq (seq nat))
51 |          : seq (seq nat) :=
52 |   match l with
53 |     | nil => nil
54 |     | nil :: _ => nil
55 |     | (x :: xs) :: xss =>
56 |       map (head 0) l :: transpose (map (@tail nat) l)
57 |   end.
58 | (*
59 | Proof.
60 |   move=> l l' xss x xs //= H1 H2.
61 |   subst.
62 |   elim: xs => [| a l //= H].
63 |   - by [].
64 |   - apply/ltP.
65 |     by rewrite ltnS ltnSn.
66 | Defined.
67 | *)
68 | 
69 | Check transpose' : seq (seq nat) -> seq (seq nat).
70 | Eval compute in transpose' [:: [::11; 12; 13]; 
71 |                             [:: 21; 22; 23; 24];
72 |                             [:: 31; 32]].
73 | (*  [:: [:: 11; 21; 31]; [:: 12; 22; 32]; [:: 13; 23; 0]] *)
74 | 
75 | (* END *)
76 | 


--------------------------------------------------------------------------------
/math4/ssr_inhabited.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | From mathcomp Require Import all_classical.
 3 | Require Import Epsilon.                     (* epsilon_statement *)
 4 | Require Import FunctionalExtensionality.
 5 | 
 6 | Set Implicit Arguments.
 7 | Unset Strict Implicit.
 8 | Unset Printing Implicit Defensive.
 9 | 
10 | (**
11 | # MathComp を使う例
12 | *)
13 | Section a.
14 |   
15 |   Check inhabited : Type -> Prop.
16 |   Check inhabited_witness : forall T : Type, inhabited T -> T.
17 | 
18 |   (* 型Aの要素は存在する。 *)
19 |   Variable A : Type.
20 |   Variable H : inhabited A.
21 | 
22 |   (* 型Aの要素を取り出す。 *)
23 |   Check inhabited_witness H : A.
24 | End a.
25 | 
26 | (* 全く別なところで、定義されている。 *)
27 | About inhabited.                            (* Coq.Init.Logic.inhabited *)
28 | About inhabited_witness.                    (* mathcomp.classical.boolp.inhabited_witness *)
29 | 
30 | Print inhabited.
31 | (*
32 | Inductive inhabited (A : Type) : Prop :=
33 | | inhabits : A -> inhabited A.
34 | *)
35 | 
36 | Print inhabited_witness.                    (* ... *)
37 | 
38 | Section a1.
39 |   
40 |   Variable A : Type.
41 |   Variable H : inhabited A.
42 | 
43 |   Definition default : A.
44 |   Proof.
45 |     by apply: inhabited_witness.
46 |   Defined.
47 |   
48 | End a1.
49 | 
50 | (* 型Aに要素が存在するなら、その要素を返す。 *)
51 | Check default : forall A : Type, inhabited A -> A.
52 | 
53 | (**
54 | # バニラCoqの例
55 | *)
56 | Section b.
57 |   
58 |   Check inhabited : Type -> Prop.
59 |   (* 公理として提供 *)
60 |   (* 型Aに要素が存在するなら、弱い依存和として定義できる。 *)
61 |   Check epsilon_statement
62 |     : forall (A : Type) (P : A -> Prop), inhabited A -> {x : A | (exists x0 : A, P x0) -> P x}.
63 |   
64 |   (* 型Aの要素は存在する。 *)
65 |   Variable A : Type.
66 |   Variable H : inhabited A.
67 | 
68 |   (* 型Aの要素を取り出す。 *)
69 |   Check epsilon_statement _ H : {x : A | (exists x0 : A, _ x0) -> _ x}.
70 |   Check proj1_sig (epsilon_statement _ H) : A.
71 |   
72 |   Check epsilon_statement (fun=> true) H    (* 常に true を返す。 *)
73 |     : {x : A | (exists x0 : A, (fun=> true) x0) -> (fun=> true) x}.
74 | End b.
75 | 
76 | About epsilon_statement.     (* Coq.Logic.Epsilon.epsilon_statement *)
77 | 
78 | Section b2.
79 |   
80 |   Variable A : Type.
81 |   Variable H : inhabited A.
82 | 
83 |   Definition default' : A.
84 |   Proof.
85 |     apply: epsilon => //=.
86 |     Check xpredT : A -> Prop.
87 |     by apply: xpredT.
88 |   Qed.
89 | 
90 | End b2.
91 | 
92 | (* END *)
93 | 


--------------------------------------------------------------------------------
/ssr2/ch8.v:
--------------------------------------------------------------------------------
 1 | From elpi Require Import elpi.
 2 | From HB Require Import structures.
 3 | From mathcomp Require Import all_ssreflect.
 4 | 
 5 | Section s8_5.
 6 | 
 7 | Inductive windrose : predArgType := N | S | E | W.
 8 | (* predArgType は p.198 の末尾参照。finType で濃度を定義するために必要である。 *)
 9 | 
10 | Definition w2o w : 'I_4 :=
11 |   match w with
12 |   | N => inord 0
13 |   | S => inord 1
14 |   | E => inord 2
15 |   | W => inord 3
16 |   end.
17 | 
18 | Definition o2w (o : 'I_4) :=
19 |   match val o with
20 |   | 0 => N
21 |   | 1 => S
22 |   | 2 => E
23 |   | 3 => W
24 |   | _ => N
25 |   end.
26 | 
27 | (* pcan という名だが、cancel 述語を使っている。 *)
28 | Lemma pcan_wo4 : cancel w2o o2w.
29 | Proof.
30 |   by case; rewrite /o2w /= inordK.
31 | Qed.
32 | 
33 | Fail Check windrose : eqType.
34 | Fail Check windrose : choiceType.
35 | Fail Check windrose : countType.
36 | Fail Check windrose : finType.
37 | 
38 | (*
39 | HB.instance Definition _ : hasDecEq windrose    := CanEqMixin pcan_wo4.
40 | HB.instance Definition _ : hasChoice windrose   := CanChoiceMixin pcan_wo4.
41 | HB.instance Definition _ : isCountable windrose := CanCountMixin pcan_wo4.
42 | HB.instance Definition _ : isFinite windrose    := CanFinMixin pcan_wo4.
43 | *)
44 | 
45 | (* こちらのほうが、よりMathComp2的である。 *)
46 | (* cancel 述語を使っているので、can_type を使う。 *)
47 | Check can_type : forall (T T' : Type) (f : T -> T') (g : T' -> T), cancel f g -> Type.
48 | Check @can_type windrose 'I_4 w2o o2w pcan_wo4 : Type.
49 | 
50 | HB.instance Definition _ := Equality.copy  windrose (can_type pcan_wo4).
51 | HB.instance Definition _ := Choice.copy    windrose (can_type pcan_wo4).
52 | HB.instance Definition _ := Countable.copy windrose (can_type pcan_wo4).
53 | HB.instance Definition _ := Finite.copy    windrose (can_type pcan_wo4).
54 | 
55 | Check windrose : eqType.
56 | Check windrose : choiceType.
57 | Check windrose : countType.
58 | Check windrose : finType.
59 | 
60 | (* 使用例 *)
61 | 
62 | Check [finType of windrose] : finType.
63 | 
64 | Lemma ord4_is_w : cancel o2w w2o.
65 | Proof.
66 |   move=> x; apply: val_inj; case: x.
67 |   by do 5! [ case=> [?|//]; first by rewrite /= inordK ].
68 | Qed.
69 | 
70 | Goal (N != S) && (N \in windrose) && (#| windrose | == 4).
71 | Proof.
72 |   case: eqP => //= _; rewrite -[4]card_ord.
73 |   rewrite -(card_image (can_inj pcan_wo4)).
74 |   apply/eqP; apply: eq_card=> o; rewrite inE.
75 |   by apply/imageP; exists (o2w o) => //=; rewrite ord4_is_w.
76 | Qed.
77 | 
78 | End s8_5.
79 | 
80 | (* END *)
81 | 


--------------------------------------------------------------------------------
/prog/ssr_typed_interpreter.v:
--------------------------------------------------------------------------------
 1 | (**
 2 |    型付インタープリタ
 3 |    
 4 |    https://www.math.nagoya-u.ac.jp/~garrigue/lecture/2011_AW/coq7.pdf
 5 |  *)
 6 | 
 7 | From mathcomp Require Import all_ssreflect.
 8 | 
 9 | Set Implicit Arguments.
10 | Unset Strict Implicit.
11 | Unset Printing Implicit Defensive.
12 | 
13 | Inductive exp : Type -> Type :=
14 | | Nat : nat -> exp nat
15 | | Pair : forall t1 t2, exp t1 -> exp t2 -> exp (t1 * t2)
16 | | App : forall t1 t2, exp (t1 -> t2) -> exp t1 -> exp t2
17 | | Plus : exp (nat -> nat -> nat).
18 | 
19 | Fixpoint eval (t : Type) (e : exp t) : t :=
20 |   match e with
21 |   | Nat n => n
22 |   | Pair t1 t2 a b => (eval a, eval b) (* (@eval t1 a, @eval t2 b) *)
23 |   | App t1 t2 f g => (eval f) (eval g) (* (@eval (t1 -> t2) f) (@eval t1 g) *)
24 |   | Plus => addn
25 |   end.
26 | 
27 | Compute eval (App (App Plus (Nat 1)) (Nat 2)). (* 3 *)
28 | 
29 | Inductive evaluate : forall {t : Type}, exp t -> t -> Prop :=
30 | | e_nat n : evaluate (Nat n) n
31 | | e_pair t1 t2 (a : exp t1) (b : exp t2) (a' : t1) (b' : t2) :
32 |     evaluate a a' -> evaluate b b' -> evaluate (Pair a b) (a' , b')
33 | | e_app t1 t2 (f : exp (t1 -> t2)) (g : exp t1) (f' : t1 -> t2) (g' : t1) :
34 |     evaluate f f' -> evaluate g g' -> evaluate (App f g) (f' g')
35 | | e_plus : evaluate Plus plus.
36 | 
37 | #[global]
38 | Hint Constructors evaluate.
39 | 
40 | Goal evaluate (App (App Plus (Nat 1)) (Nat 2)) (plus 1 2).
41 | Proof.
42 |   apply: e_app.
43 |   - by apply: e_app.
44 |   - done.
45 | Qed.
46 | 
47 | Lemma eval_eval (t : Type) (e : exp t) (v : t) : evaluate e v <-> eval e = v.
48 | Proof.
49 |   split.
50 |   - elim=> //=.
51 |     + move=> t1 t2 a b a' b' H1 H2 H3 H4.
52 |       by subst.
53 |     + move=> t1 t2 a b a' b' H1 H2 H3 H4.
54 |       by subst.
55 |   - elim: e v => [n v H | t1 t2 e1 H1 e2 H2 v IH | t1 t2 f Hf g Hg v IH | v H];
56 |                    subst => //=.
57 |     + apply: e_pair.
58 |       * by apply: H1.
59 |       * by apply: H2.
60 |     + apply: e_app.
61 |       * by apply: Hf.
62 |       * by apply: Hg.
63 | Qed.
64 | 
65 | Require Import Program.
66 | Program Fixpoint eval' (t : Type) (e : exp t) : {v | evaluate e v} :=
67 |   match e with
68 |   | Nat n => n
69 |   | Pair t1 t2 a b => (eval' a, eval' b)
70 |   | App t1 t2 f g => (eval' f) (eval' g)
71 |   | Plus => addn
72 |   end.
73 | (* 証明責務はなし。 *)
74 | 
75 | Compute (eval (App (App Plus (Nat 1)) (Nat 2))).
76 | Compute (eval' (App (App Plus (Nat 1)) (Nat 2))).
77 | 
78 | (** END **)
79 | 


--------------------------------------------------------------------------------
/tcfm/tcfm_category_1.v:
--------------------------------------------------------------------------------
  1 | (**
  2 | いろいろな具象圏をCoqで実装してみた
  3 | ----------------------------------------------
  4 | *)
  5 | 
  6 | (**
  7 | 
  8 | # はじめに
  9 | 
 10 | ## Coqで圏論
 11 | 
 12 | Coqで圏論というと、 2016年にすでに素晴らしい記事[1]があり、
 13 | また[2]にもとづく[3]もあるので、
 14 | 私のようなものが書くことはないのですが、
 15 | 私の興味は[4][5]にあります。
 16 | 
 17 | つまり「〜が圏をなすこと」を形式的に証明したい、
 18 | さらに、いろいろなものが圏をなすことをいわば手当たり次第に証明できないか、
 19 | とも考えました。
 20 | 
 21 | プログラマの視点から、
 22 | いろいろな圏についてわかりやすく説明したものに[6]があり参考になります。
 23 | 
 24 | 
 25 | ## Class コマンド と Instance コマンド
 26 | 
 27 | 「しりとりゲームが圏をなす」、あるいは、集合と関数が圏をなす、半順序が圏をなす、
 28 | といった一連のことを証明するのであれば、なんらかの構造的な手法も併用できるはずです。
 29 | 
 30 | Coqにはファーストクラスのファシリティとして、Type Class (型クラス）があります[7]。
 31 | この Type Class 自体はHaskellに起源をもつものだそうです。
 32 | Classで仕様を記述し、Instanceで実体を構成します。
 33 | Coqなので、実体の構成には証明を記述することになります。
 34 | 
 35 | [8]には、数学への応用が解説されています。
 36 | 今回はその[8]の6章のCategoryの定義に基づいています。
 37 | 
 38 | 
 39 | ## Program コマンド
 40 | 
 41 | Coq の Programコマンドは、Definition や Fixpoint と組み合わせて使うことが普通ですが、
 42 | Instance と組み合わせて使うこともできます。
 43 | 
 44 | Program Instnce とすることで、実体を構成するときに大幅な自動化が行われ、
 45 | 証明責務(Obligation)として必要な箇所だけ、証明を埋めれば完成です。
 46 | 
 47 |  *)
 48 | 
 49 | (**
 50 | # 圏のClass定義
 51 | 
 52 | [8] の Class Cagegory の定義を以下にしめします。
 53 | Coq 8.8.1 で動作するように修正しています。
 54 | 
 55 | Relation と Morphims を使用しています。
 56 | Relation は Equivalence のために、
 57 | Morphisms は Proper のために使用します。
 58 | 後者については説明を省きますが[7]を参照してください。
 59 | ProofIrrelevance は後で説明します。
 60 |  *)
 61 | 
 62 | (**
 63 | 
 64 |  *)
 65 | 
 66 | (**
 67 | # 関手の定義
 68 | *)
 69 | 
 70 | 
 71 | (**
 72 | # まとめ
 73 | 
 74 | いくつかの具象圏について、
 75 | Coqの Class と Program Instance コマンドを使って、
 76 | 形式的かつ構造的に証明してみました。
 77 | 
 78 | Coqを使った形式的な定義というと、補題を積み重ねて定理を証明する、
 79 | という、いかにも数学的な流れであることが多いのですが、
 80 | 証明責務を埋めるやりかたも、おもしろいのではないでしょうか。
 81 | 
 82 | 最後になりましたが、表題は[4]に敬意を表わしたものです。
 83 | *)
 84 | 
 85 | 
 86 | 
 87 | (**
 88 | [1] https://qiita.com/mathink/items/2067c162fb7cf8f6c83f 
 89 | 
 90 | [2] https://global.oup.com/academic/product/category-theory-9780199237180?cc=jp&lang=en&
 91 | 
 92 | [3] http://www.megacz.com/berkeley/coq-categories/
 93 | 
 94 | [4] http://yosh.hateblo.jp/entry/20090425/p1
 95 | 
 96 | [5] http://d.hatena.ne.jp/m-hiyama/20060821/1156120185
 97 | 
 98 | [6] http://bitterharvest.hatenablog.com/archive/category/%E7%9B%AE%E6%AC%A1%28Haskell%29
 99 | 
100 | [7] A Gentle Introduction to Type Classes and Relations in Coq
101 | 
102 | [8] Type Classes for Mathematics in Type Theory
103 | 
104 | [9] https://coq.inria.fr/refman/addendum/program.html
105 | 
106 |  *)
107 | 


--------------------------------------------------------------------------------
/categories/Aw_2_1_EpicMinic.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
 2 | 
 3 | Set Implicit Arguments.
 4 | Unset Strict Implicit.
 5 | Unset Printing Implicit Defensive.
 6 | 
 7 | (* Generalizable All Variables. *)
 8 | Require Import Aw_0_Notations.
 9 | Require Import Aw_1_3_Categories.
10 | Require Import Aw_1_5_Isomorphisms.
11 | 
12 | (******************************************************************************)
13 | (* Chapter 2.1: Epic and Monic morphisms                                      *)
14 | (******************************************************************************)
15 | 
16 | (* Definition 2.1a *)
17 | Class Monic `{C : Category} {a b : C} (f : a ~> b) : Prop :=
18 |   monic : forall c (g1 g2 : c ~> a), f \\o g1 === f \\o g2 -> g1 === g2.
19 | (* Implicit Arguments monic [ C a b Ob Hom ]. *)
20 | 
21 | (* Definition 2.1b *)
22 | Class Epic `{C : Category} {a b : C} (f : a ~> b) : Prop := 
23 |   epic : forall c (g1 g2 : b~>c), g1 \\o f === g2 \\o f -> g1 === g2.
24 | (* Implicit Arguments epic [ C a b Ob Hom ]. *)
25 | 
26 | (* Proposition 2.6 *)
27 | (* すべての同型は、エピepiである。 *)
28 | Instance iso_epic `(i : Isomorphic) : Epic #i.
29 | Proof.
30 |   Check #i : a ~> b.
31 |   Check iso_forward i : a ~> b.
32 |   
33 |   rewrite /Epic => c g1 g2 H.
34 |   rewrite -[g1]right_identity -[g2]right_identity.
35 |   rewrite -iso_comp2 -2!associativity.
36 |   rewrite H.
37 |   reflexivity.
38 | Qed.
39 | 
40 | (* Proposition 2.6 *)
41 | (* すべての同型は、モノmonicである。 *)
42 | Instance iso_monic `(i : Isomorphic) : Monic #i.
43 | Proof.
44 |   rewrite /Monic => c g1 g2 H.
45 |   rewrite -[g1]left_identity -[g2]left_identity.
46 |   rewrite -iso_comp1 2!associativity.
47 |   rewrite H.
48 |   reflexivity.
49 | Qed.
50 | 
51 | (* a BiMorphism is an epic monic *)
52 | Class BiMorphism `{C : Category} {a b : C} (f : a ~> b) : Prop :=
53 |   {
54 |     bimorphism_epic  :> Epic  f;
55 |     bimorphism_monic :> Monic f
56 |   }.
57 | Coercion bimorphism_epic  : BiMorphism >-> Epic.
58 | Coercion bimorphism_monic : BiMorphism >-> Monic.
59 | 
60 | Class EndoMorphism `{C : Category} (A : C) :=
61 |   endo : A ~> A.
62 | 
63 | Class AutoMorphism `{C : Category} (A : C) : Type :=
64 |   {
65 |     auto_endo1 : EndoMorphism A;
66 |     auto_endo2 : EndoMorphism A;
67 |     auto_iso   : Isomorphism  (@endo _ _ _ _ auto_endo1) (@endo _ _ _ _ auto_endo2);
68 |   }.
69 | 
70 | (*Class Balanced `{C:Category} : Prop :=
71 |   balanced : forall (a b:C)(f:a~>b), BiMorphism f -> Isomorphism f.*)
72 | 
73 | 


--------------------------------------------------------------------------------
/coq_apply.v:
--------------------------------------------------------------------------------
  1 | (******************************************)
  2 | (* apply で証明することとはどういうことか *)
  3 | (******************************************)
  4 | 
  5 | 
  6 | (** 帰納型のチュートリアル **)
  7 | (** A Tutorial on [Co-]Inductive Types in Coq **)
  8 | 
  9 | 
 10 | (* 発展的内容 *)
 11 | (* 2.5 Relations as inductive types. *)
 12 | 
 13 | 
 14 | Print le.
 15 | 
 16 | 
 17 | (* 以下の証明は、coq内部的にはすべて同じ、Printで同じ結果になる。 *)
 18 | Theorem zero_leq_three: 0 <= 3.
 19 |   (* 普通の証明 *)
 20 |   constructor.
 21 |   constructor.
 22 |   constructor.
 23 |   constructor.
 24 |   Restart.
 25 | 
 26 | 
 27 |   (* applyを使った証明 *)
 28 |   apply le_S.
 29 |   apply le_S.
 30 |   apply le_S.
 31 |   apply le_n.
 32 |   Restart.
 33 | 
 34 | 
 35 |   (* applyにおける変数置き換えを省略せずに書いた証明 *)
 36 |   apply le_S with (n := 0) (m := 2).
 37 |   apply le_S with (n := 0) (m := 1).
 38 |   apply le_S with (n := 0) (m := 0).
 39 |   apply le_n with (n := 0).
 40 |   Restart.
 41 | 
 42 | 
 43 |   (* applyより先に、定数を適用しておく方法もある *)
 44 |   apply (le_S 0 2).
 45 |   apply (le_S 0 1).
 46 |   apply (le_S 0 0).
 47 |   apply (le_n 0).
 48 | Qed.
 49 | 
 50 | 
 51 | (* 0 <= 3 の証明 (Prop) を返す関数が定義された *)
 52 | Print zero_leq_three.                       (* 0 <= 3 *)
 53 | 
 54 | 
 55 | Lemma zero_leq_n (n : nat) : 0 <= n.
 56 |   intros n.
 57 |   elim n.                                   (* nat_indによる帰納の場合分け。 *)
 58 |   apply le_n.
 59 |   
 60 |   intros n0 H.
 61 |   apply le_S.
 62 |   apply H.
 63 | Qed.
 64 | 
 65 | 
 66 | Print zero_leq_n.
 67 | Eval compute in zero_leq_n 3.
 68 | 
 69 | 
 70 | (* 0 <= 3 の証明 (Prop) を返す関数が定義する。 *)
 71 | (* 直接定義する場合は、グローバルな定義として、Definitionを使う。 *)
 72 | Definition zero_leq_three' := zero_leq_n 3.
 73 | Print zero_leq_three'.                      (* 0 <= 3 *)
 74 | 
 75 | 
 76 | (* このような、別の定義もある。*)
 77 | Lemma zero_leq_three'' : 0 <= 3.
 78 |   apply zero_leq_n with (n := 3).           (* apply (zero_leq_n 3). でもよい。 *)
 79 | Qed.
 80 | Print zero_leq_three''.                     (* 0 <= 3 *)
 81 | 
 82 | 
 83 | (* このような、別の定義もある。*)
 84 | Lemma zero_leq_three''' : 0 <= 3.
 85 |   Proof zero_leq_n 3.
 86 | Print zero_leq_three'''.                     (* 0 <= 3 *)
 87 | 
 88 | 
 89 | (* Lemma を Defined、Qed を Defined としてもよい。 *)
 90 | 
 91 | 
 92 | 
 93 | 
 94 | Lemma zero_leq_four : 0 <= 4.
 95 |   apply le_S with (n := 0) (m := 3).
 96 |   apply zero_leq_n with (n := 3).
 97 | Qed.
 98 | Print zero_leq_four.                        (* 0 <= 4 *)
 99 | 
100 | 
101 | (* これは以下の定義と同じ *)
102 | Definition zero_leq_four' := le_S 0 3 (zero_leq_n 3). (* 0 <= 4 *)
103 | 
104 | 
105 | (* END *)


--------------------------------------------------------------------------------
/common/ssromega.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | Require Import Psatz.
 3 | 
 4 | Set Implicit Arguments.
 5 | Unset Strict Implicit.
 6 | Unset Printing Implicit Defensive.
 7 | (* Set Printing All. *)
 8 | 
 9 | (**
10 | ssromega を使えるようにする手順；
11 | 1. カレントディでクトリに置く場合：
12 | (1) coqc ssromega.v
13 | (2) Require Import ssromega. で読み込む。
14 | 
15 | 2. パスを通す場合：
16 | (1) ~/.coqrc に以下の行を追加する。
17 | Add LoadPath "~/WORK/coq/common" as common.
18 | (2) ~/WORK/coq/common/ の下で以下を実行する。
19 | coq_makefile -R . common ssromega.v > Makefile
20 | (3) make clean; make
21 | ssromega.vo ができている。
22 | (4) From common Require Import ssromega. で読み込む。
23 | *)
24 | 
25 | (* https://github.com/affeldt-aist/seplog/blob/master/lib/ssrnat_ext.v *)
26 | 
27 | Ltac ssromega :=
28 |   (repeat ssrnat2coqnat_hypo ;
29 |    ssrnat2coqnat_goal ;
30 |    lia)
31 | with ssrnat2coqnat_hypo :=
32 |   match goal with
33 |     | H : context [?L < ?R] |- _ => move/ltP: H => H
34 |     | H : context [?L <= ?R] |- _ => move/leP: H => H
35 |     | H : context [?L < ?M < ?R] |- _ => let H1 := fresh in case/andP: H => H H1
36 |     | H : context [?L <= ?M < ?R] |- _ => let H1 := fresh in case/andP: H => H H1
37 |     | H : context [?L <= ?M <= ?R] |- _ => let H1 := fresh in case/andP: H => H H1
38 |     | H : context [?L + ?R] |- _ => rewrite <- plusE in H
39 |     | H : context [?L * ?R] |- _ => rewrite <- multE in H
40 |     | H : context [?L - ?R] |- _ => rewrite <- minusE in H
41 |     | H : ?x == _ |- _ => match type of x with nat => move/eqP in H end; idtac x
42 |     | H : _ == ?x |- _ => match type of x with nat => move/eqP in H end; idtac x
43 |     | H : _ != ?x |- _ => match type of x with nat => move/eqP in H end
44 |   end
45 | with ssrnat2coqnat_goal :=
46 |   rewrite -?plusE -?minusE -?multE;
47 |   match goal with
48 |     | |- is_true (_ < _)%nat => apply/ltP
49 |     | |- is_true (_ <= _)%nat => apply/leP
50 |     | |- is_true (_ && _) => apply/andP; split; ssromega
51 |     | |- is_true (?x != _) => match type of x with nat => apply/eqP end
52 |     | |- is_true (_ != ?x) => match type of x with nat => apply/eqP end
53 |     | |- is_true (?x == _) => match type of x with nat => apply/eqP end
54 |     | |- is_true (_ == ?x) => match type of x with nat => apply/eqP end
55 |     | |- _ /\ _ => split; ssromega
56 |     | |- _ \/ _ => (left; ssromega) || (right; ssromega)
57 |     | |- _ => idtac
58 |   end.
59 | 
60 | (* Sample *)
61 | Goal forall x y : nat, x + 4 - 2 > y + 4 -> (x + 2) + 2 >= y + 6.
62 | Proof.
63 |   move=> x y H.
64 |   by ssromega.
65 | Qed.
66 | 
67 | (* END *)
68 | 


--------------------------------------------------------------------------------
/math-comp-book/suhara.ch6-tuples-subtype.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | 
 3 | (* 6. Sub-Types Terms with properties *)
 4 | (* 6.2.1 The sub-type kit *)
 5 | 
 6 | Check [tuple of [:: 1; 2; 3]] : 3.-tuple nat.
 7 | 
 8 | Check @tval 3 nat [tuple of [:: 1; 2; 3]] : seq nat.
 9 | Check tval        [tuple of [:: 1; 2; 3]] : seq nat.
10 | 
11 | Compute @tval 3 nat [tuple of [:: 1; 2; 3]]. (* [:: 1; 2; 3] *)
12 | 
13 | Print Graph.
14 | (* [tval] : tuple_of >-> list *)
15 | 
16 | Check             [tuple of [:: 1; 2; 3]] : seq nat. (* コアーション *)
17 | 
18 | 
19 | (* カノニカルが有効な例 *)
20 | Print Canonical Projections.
21 | (*
22 | tuple_of <- sub_sort ( tuple_subType )      (* SubType *)
23 | tuple_of <- Equality.sort ( tuple_eqType )
24 |  *)
25 | 
26 | (* insub - 引数をサブタイプのoption型に変換する。変換できなければNONEとする。 *)
27 | Print insub.
28 | (* fun (T : Type) (P : pred T) (sT : subType (T:=T) P) (x : T) =>
29 | match idP with
30 | | ReflectT Px => Some (Sub x Px)
31 | | ReflectF _ => None
32 | end
33 |  *)
34 | 
35 | Check insub : _ -> option _.
36 | Check @insub : forall (T : Type) (P : pred T) (sT : subType (T:=T) P), T -> option sT.
37 | 
38 | Check @insub (seq nat) (fun s => size s == 3) (tuple_subType 3 nat)
39 |       [::1;2;3] : option (tuple_subType 3 nat).
40 | 
41 |                                               (* ↓これは3.-tuple natにならない。 *)
42 | Check @insub (seq nat) [pred s | size s == 3] (tuple_subType 3 nat)
43 |       [::1;2;3] : option (3.-tuple nat).
44 | 
45 | Check insub [::1;2;3] : option (tuple_subType 3 nat).
46 | Check insub [::1;2;3] : option (3.-tuple nat).
47 | 
48 | 
49 | (* The insubd constructor takes a default sub-type value which it
50 | returns if the tests fails. *)
51 | Print insubd.
52 | 
53 | Check insubd : _ -> _ -> _.
54 | Check @insubd : forall (T : Type) (P : pred T) (sT : subType (T:=T) P), sT -> T -> sT.
55 | 
56 | Check @insubd (seq nat) [pred s | size s == 3] (tuple_subType 3 nat)
57 |       [tuple of [::1;1;1]] [::1;2;3] : 3.-tuple nat.
58 | Check insubd [tuple of [::1;1;1]] [::1;2;3] : 3.-tuple nat.
59 | 
60 | 
61 | (* おまけ *)
62 | 
63 | Lemma H23 : 2 < 3. Proof. done. Qed.
64 | Check Ordinal H23.
65 | Check @Ordinal 3 2 is_true_true : 'I_3.
66 | 
67 | Check tnth [tuple of [::1;2;3]] (@Ordinal 3 2 is_true_true).
68 | Compute tnth [tuple of [::1;2;3]] (@Ordinal 3 2 is_true_true). (* 3 *)
69 | 
70 | Check tnth [tuple of [::1;2;3]] (Ordinal H23).
71 | Compute tnth [tuple of [::1;2;3]] (Ordinal H23). (* 3 *)
72 | 
73 | Check [tnth [tuple of [::1;2;3]] 2].
74 | Compute [tnth [tuple of [::1;2;3]] 2].      (* 3 *)
75 | 
76 | (* END *)
77 | 


--------------------------------------------------------------------------------
/monad/ssr_cat_kleisli.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | Kleisli クライスリ圏
 3 |  *)
 4 | 
 5 | Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
 6 | 
 7 | Set Implicit Arguments.
 8 | Unset Strict Implicit.
 9 | Unset Printing Implicit Defensive.
10 | 
11 | Section Categories.
12 | 
13 |   Class Setoid :=
14 |     {
15 |       carrier : Type;
16 |       equiv : carrier -> carrier -> Prop
17 |     }.
18 |   Coercion carrier : Setoid >-> Sortclass.
19 |   Notation "x === z" := (equiv x z) (at level 70).
20 |   
21 |   Class Category :=
22 |     {
23 |       (* 対象の定義 *)
24 |       Obj : Type;                           (* Category -> Type *)
25 |       
26 |       (* 射の定義 *)      
27 |       Mor : Obj -> Obj -> Setoid;           (* Coersion が有効になる。 *)
28 |       
29 |       (* 恒等射の定義 *)
30 |       idC : forall {A : Obj}, Mor A A;
31 |       
32 |       (* 射の合成の定義 *)
33 |       composeC : forall {A B C : Obj}, Mor B C -> Mor A B -> Mor A C;
34 |       
35 |       (* 単位律の定義 *)
36 |       left_identity : forall (A B : Obj) (f : Mor A B), composeC idC f === f;
37 |       right_identity : forall (A B : Obj) (f : Mor A B), composeC f idC === f;
38 |       
39 |       (* 結合律の定義 *)
40 |       associativity : forall (A B C D : Obj)
41 |                              (f : Mor A B) (g : Mor B C) (h : Mor C D),
42 |                         composeC (composeC h g) f === composeC h (composeC g f)
43 |     }.
44 | 
45 |   Coercion Obj : Category >-> Sortclass.
46 |   Coercion Mor : Category >-> Funclass.
47 |   
48 |   Class Kleisli (C : Category) (T : C -> C) :=
49 |     {
50 |       pure: forall {X : C}, C X (T X);
51 |       bind: forall {X Y : C}, C X (T Y) -> C (T X) (T Y)
52 |     }.
53 | End Categories.
54 | 
55 | Section Monad.
56 |   
57 |   Instance EqMor : forall (A B : Set), Setoid :=
58 |     {
59 |       carrier := A -> B;
60 |       equiv := @eqfun B A
61 |     }.
62 |   
63 |   Instance Func : Category :=               (* Category *)
64 |     {
65 |       Obj := Set;
66 |       Mor := EqMor;
67 |       idC A := id;
68 |       composeC A B C := funcomp tt          (* compose *)
69 |     }.
70 |   Proof.
71 |     - by [].
72 |     - by [].
73 |     - by [].
74 |   Defined.
75 | 
76 |   About option.              (* Coq.Init.Datatypes.option *)
77 |   Check Some : forall A : Type, A -> option A.
78 |   Check @None : forall A : Type, option A.
79 |   
80 |   Instance Maybe : @Kleisli Func option :=
81 |     {
82 |       pure X x := Some x;
83 |       bind X Y f m :=
84 |         match m with
85 |           | Some x => f x
86 |           | _ => None
87 |         end
88 |     }.
89 | End Monad.
90 | 
91 | (* END *)
92 | 


--------------------------------------------------------------------------------
/elpi/coq_elpi_list.md:
--------------------------------------------------------------------------------
 1 | # ELPI 言語
 2 | 
 3 | ## オリジナルテキスト
 4 | 
 5 | https://lpcic.github.io/coq-elpi/tutorial_elpi_lang.html
 6 | 
 7 | https://github.com/LPCIC/coq-elpi/blob/master/examples/tutorial_elpi_lang.v
 8 | 
 9 | ## 和訳
10 | 
11 | https://qiita.com/suharahiromichi/private/62fd01d0000b29156d2e
12 | 
13 | https://gitlab.com/proofcafe/elpi/-/blob/main/tutorial_elpi_lang_jp.v
14 | 
15 | 
16 | 
17 | # HOAS
18 | 
19 | ## オリジナルテキスト
20 | 
21 | 
22 | https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_HOAS.html
23 | 
24 | https://github.com/LPCIC/coq-elpi/blob/master/examples/tutorial_coq_elpi_HOAS.v
25 | 
26 | 
27 | ## 和訳
28 | 
29 | 
30 | https://qiita.com/suharahiromichi/private/62359119f7f880f94d48
31 | 
32 | https://gitlab.com/proofcafe/elpi/-/blob/main/tutorial_elpi_lang_jp.v
33 | 
34 | 
35 | ## まとめ
36 | 
37 | ○ https://qiita.com/suharahiromichi/private/23ecf3c91204d43a8b81
38 | 
39 | ○ https://github.com/suharahiromichi/coq/blob/master/elpi/coq_elpi_hoas.v
40 | 
41 | 
42 | # Command
43 | 
44 | ## オリジナルテキスト
45 | 
46 | https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_command.html
47 | 
48 | https://github.com/LPCIC/coq-elpi/blob/master/examples/tutorial_coq_elpi_command.v
49 | 
50 | 
51 | ## 和訳
52 | 
53 | https://qiita.com/suharahiromichi/private/8e5d9824578a830e6af0
54 | 
55 | https://gitlab.com/proofcafe/elpi/-/blob/main/tutorial_coq_elpi_command_jp.v
56 | 
57 | 
58 | ## まとめ
59 | 
60 | ○ https://qiita.com/suharahiromichi/items/bef4ff2d7c2a15654c77
61 | 
62 | ○ https://qiita.com/suharahiromichi/items/61e3bc6bbb14ed9fce63
63 | 
64 | ○ https://github.com/suharahiromichi/coq/blob/master/elpi/coq_elpi_command.v
65 | 
66 | ○ https://github.com/suharahiromichi/coq/blob/master/elpi/coq_elpi_command_2.v
67 | 
68 | 
69 | # Tactic
70 | 
71 | ## オリジナルテキスト
72 | 
73 | https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_tactic.html
74 | 
75 | https://github.com/LPCIC/coq-elpi/blob/master/examples/tutorial_coq_elpi_tactic.v
76 | 
77 | ## 和訳
78 | 
79 | https://gitlab.com/proofcafe/elpi/-/blob/main/tutorial_coq_elpi_tactic_jp.v
80 | 
81 | https://qiita.com/suharahiromichi/private/2c02ac797fa99ce65d88
82 | 
83 | ## まとめ
84 | 
85 | https://qiita.com/suharahiromichi/items/4ca8805a5b21958aff87
86 | 
87 | https://qiita.com/suharahiromichi/items/31096ff47ab69f4ba4ea
88 | 
89 | https://qiita.com/suharahiromichi/private/8e572dc0c8fe48ffdfeb
90 | 
91 | https://github.com/suharahiromichi/coq/blob/master/elpi/coq_elpi_tactic_sample_1.v
92 | 
93 | https://github.com/suharahiromichi/coq/blob/master/elpi/coq_elpi_tactic_sample_1_2.v
94 | 
95 | https://github.com/suharahiromichi/coq/blob/master/elpi/coq_elpi_tactic_sample_2.v
96 | 
97 | 以上
98 | 


--------------------------------------------------------------------------------
/fp/ssr_fp_2.md:
--------------------------------------------------------------------------------
  1 | SCDマシンによる Backus' FPの実行
  2 | 
  3 | 2021/08/08
  4 | 
  5 | @suharahiromchi
  6 | 
  7 | 
  8 | コピーは浅いコピーでよい。
  9 | 
 10 | 
 11 | ## 基本操作
 12 | 
 13 | ### ``sel n``の実行
 14 | 
 15 | - Dのリストのn番めの要素をSにpushする。
 16 | 
 17 | 
 18 | ### ``constructor``の実行
 19 | 
 20 | 以下をn回繰り返す。
 21 | 
 22 | - Dをコピーする。
 23 | - 実行して結果をSにpushする。
 24 | - Dを捨てる。
 25 | 
 26 | - Sの個数分popしてリストをつくり、Sにpushする。
 27 | 
 28 | 
 29 | ### ``conposition`` の「p ○」実行
 30 | 
 31 | - Dを捨てる。                             (conpos)
 32 | - SをpopしてDに置く。                     (conpos)
 33 | - pを実行する。                           (conpos)
 34 | 
 35 | 
 36 | ### ``condition p1 p2 p3``
 37 | 
 38 | - Dをコピーする。
 39 | - p1 を実行して、結果をSにpushする。
 40 | - Dを捨てる。
 41 | 
 42 | - Dをコピーする。
 43 | - Sをpopしてtrueならp1, falseならp2を実行する。
 44 | - Dを捨てる。
 45 | 
 46 | 
 47 | 
 48 | ### 組込関数、定義関数
 49 | 
 50 | - Dを参照する。1引数ならD全体が引数である。
 51 | - Sのトップに結果をpushする。
 52 | 
 53 | 
 54 | 
 55 | ## 応用操作
 56 | 
 57 | ### ``slash p : <o1, o2,.., on-1, on> = p・[sel 1, p・[sel 2, sel 3]]``
 58 | 
 59 | Dが3個のリストの場合
 60 | 
 61 | - Dをコピーする。                       (constr1)
 62 | - sel1 を実行してSにpushする。           (constr1)
 63 | - Dを捨てる。                            (constr1)
 64 | 
 65 | - Dをコピーする。                       (constr1)
 66 | 
 67 | - Dをコピーする。                               (constr2)
 68 | - sel2 を実行してSにpushする。                  (constr2)
 69 | - Dを捨てる。                                   (constr2)
 70 | 
 71 | - Dをコピーする。                               (constr2)
 72 | - sel3 を実行してSにpushする。                  (constr2)
 73 | - Dを捨てる。                                   (constr2)
 74 | 
 75 | - Sの二つをpppして、consしてpushする。          (constr2)
 76 | 
 77 | - Dを捨てる。                                           (consps2)
 78 | - SをpopしてDに置く。                                   (conpos2)
 79 | - pを実行してSにpushする。                              (consps2)
 80 | 
 81 | - Dを捨てる。                            (constr1)
 82 | - Sの二つをpppして、consしてpushする。   (constr1)
 83 | 
 84 | - Dを捨てる。                            (compos1)
 85 | - SをpushしてDに置く。                   (compos1)
 86 | - pを実行する。                          (compps1)
 87 | 
 88 | 
 89 | # ``alpha p : <o1, o2,.., on> = [p・sel 1, p・sel 2,..., p・sel n]
 90 | 
 91 | Dがn個のリストの場合
 92 | 
 93 | - Dをコピーする。                       (constr)
 94 | - sel 1を実行する。                     (constr)
 95 | 
 96 | - Dを捨てる。                           (comps)
 97 | - Sのトップ(sel 1の結果)を Dに置く。     (comps)
 98 | - pを実行する。                         (comps)
 99 | 
100 | - Dを(sel 1の結果)捨てる。              (constr)
101 | 
102 | 繰り返す
103 | 
104 | - Sの個数分popしてリストをつくり、Sにpushする。(constr)
105 | 
106 | 
107 | ## 
108 | 
109 | 以上
110 | 


--------------------------------------------------------------------------------
/ex2014/ex32.v:
--------------------------------------------------------------------------------
 1 | Require Import ssreflect.
 2 | 
 3 | (**
 4 | # 第7回 ソースファイルの分割とコンパイル/SectionとModule (2014/05/18)
 5 | 
 6 | http://qnighy.github.io/coqex2014/ex7.html
 7 | 
 8 | ## 課題32 (種別:A / 締め切り : 2014/05/25)
 9 | 
10 | 半群とは、結合的な二項演算を持つ集合のことである。
11 | 
12 | 次のソースを埋めて、自然数の乗算のなす半群と、自然数の最大値関数のなす半群を定義せよ。また、
13 | 半群の直積を定義せよ。
14 | 
15 | G0とG1の(半群としての)直積とは、G0とG1の(集合としての)直積を台集合とし、二項演算は単に左側
16 | をG0の二項演算、右側をG1の二項演算で計算するものを入れたものである。
17 | *)
18 | 
19 | Require Import Arith.
20 | 
21 | Module Type SemiGroup.
22 |   Parameter G : Type.
23 |   Parameter mult : G -> G -> G.
24 |   Axiom mult_assoc :
25 |     forall x y z : G, mult x (mult y z) = mult (mult x y) z.
26 | End SemiGroup.
27 | 
28 | (**
29 | https://github.com/mzp/coq/blob/master/gallina.txt
30 | - ParameterにはDefinitionで定義を与える
31 | - AxiomにはTheoremで証明を与える。
32 | *)
33 | 
34 | Module NatMult_SemiGroup <: SemiGroup.      (* 乗算のなす半群 *)
35 |   Definition G := nat.
36 |   Definition mult := mult.                  (* Peano.mult, Arith/Mult.v *)
37 |   Theorem mult_assoc :
38 |     forall x y z : G, mult x (mult y z) = mult (mult x y) z.
39 |   Proof.
40 |     apply mult_assoc.                       (* Mult.mult_assoc *)
41 |   Qed.
42 | End NatMult_SemiGroup.
43 | 
44 | Module NatMax_SemiGroup <: SemiGroup.       (* 最大値関数のなす半群 *)
45 |   Definition G := nat.
46 |   Definition mult := max.                   (* Max.max *)
47 |   Theorem mult_assoc :
48 |     forall x y z : G, mult x (mult y z) = mult (mult x y) z.
49 |   Proof.
50 |     apply Max.max_assoc.                    (* Arith.Max.v *)
51 |   Qed.
52 | End NatMax_SemiGroup.
53 | 
54 | Module SemiGroup_Product (G0 G1 : SemiGroup) <: SemiGroup. (* 半群の直積 *)
55 |   Definition G := (G0.G * G1.G)%type.       (* natの掛け算ではない。prod G0.G G1.G と同じ。 *)
56 |   Definition mult :=
57 |     fun (a b : G) =>                        (* G は (G0.G * G1.G) と同じ。 *)
58 |       match a, b with
59 |         | (a0, a1), (b0, b1) => (G0.mult a0 b0, G1.mult a1 b1)
60 |       end.
61 |   Theorem mult_assoc :
62 |     forall (x y z : G) , mult x (mult y z) = mult (mult x y) z.
63 |   Proof.
64 |     move=> x y z.
65 |     case: x => [a0 a1].
66 |     case: y => [b0 b1].
67 |     case: z => [c0 c1].
68 |     rewrite /mult.
69 |     f_equal.
70 |     apply G0.mult_assoc.
71 |     apply G1.mult_assoc.
72 |   Qed.
73 | End SemiGroup_Product.
74 | 
75 | (**
76 | ヒント
77 | 
78 | モジュールの練習です。モジュールは、名前空間としての用途の他に、このように構造の入った型を
79 | 抽象化する働きもあります。
80 | 
81 | CoqのモジュールシステムはほぼOCamlのモジュールシステムと同じものです。OCamlのモジュールシス
82 | テムは有用ですが、Coqのモジュールシステムは他のCoqの機能(ClassやCanonical Structure)で代替
83 | できることが多く、OCamlのそれと比べるとやや存在感が薄いかもしれません。
84 | 
85 | なお、Module Type中で用いられているParameterやAxiomは公理扱いではありません。
86 | *)
87 | 
88 | (* END *)
89 | 


--------------------------------------------------------------------------------
/iii/ssr_coqt7.v:
--------------------------------------------------------------------------------
  1 | (**
  2 | プログラミング Coq --- 停止性が明らかでない関数を定義するには
  3 | 
  4 | http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt7.html
  5 | をSSReflectに書き直した。
  6 | *)
  7 | 
  8 | Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
  9 | Require Import Recdef.
 10 | 
 11 | Set Implicit Arguments.
 12 | Unset Strict Implicit.
 13 | Unset Printing Implicit Defensive.
 14 | Set Print All.
 15 | 
 16 | Fixpoint merge (l1 l2 : seq nat) :=
 17 |   (fix merge' l' :=
 18 |     match l1, l' with
 19 |     | nil, _ => l'
 20 |     | _, nil => l1
 21 |     | x::xs, y::ys => if x <= y then x :: merge xs l' else y :: merge' ys
 22 |     end
 23 |   ) l2.
 24 | 
 25 | Fixpoint split (l : seq nat) : seq nat * seq nat :=
 26 |   match l with
 27 |   | nil => (nil, nil)
 28 |   | x::nil => (x :: nil, nil)
 29 |   | x::y::zs => (fun l' => (x :: fst l', y :: snd l')) (split zs)
 30 |   end.
 31 | (*
 32 | Function msort (l : seq nat) {measure length l} : seq nat :=
 33 |   match l with
 34 |   | nil => nil
 35 |   | x::nil => x::nil
 36 |   | x::y::zs => (fun l' => merge (msort (fst l')) (msort (snd l'))) (split l)
 37 |   end.
 38 | Proof.
 39 |  (* length (snd (split (x::y::zs))) < length (x::y::zs) *)
 40 |  intros.
 41 |  simpl.
 42 |  subst.
 43 |  induction (split zs).
 44 |   simpl.
 45 |   constructor.
 46 |  
 47 |   simpl.
 48 |   constructor.
 49 |   admit.
 50 |  
 51 |   simpl.
 52 |   intros.
 53 |   apply lt_S.
 54 |   apply lt_n_S.
 55 |   apply IHp.
 56 | 
 57 |  (* length (fst (split (x::y::zs))) < length (x::y::zs) *)
 58 |  intros.
 59 |  subst.
 60 |  functional induction (split zs).
 61 |   simpl.
 62 |   constructor.
 63 | 
 64 |   simpl.
 65 |   constructor.
 66 | 
 67 |   simpl.
 68 |   apply lt_n_S.
 69 |   apply lt_S.
 70 |   apply IHp.
 71 | Defined.
 72 | *)
 73 | 
 74 | (* 問10. *)
 75 | 
 76 | (* stardard Coq の not_eq_S. と eq_S の両方 *)
 77 | Lemma eq_S_S (n m : nat) : n = m <-> n.+1 = m.+1.
 78 | Proof.
 79 |   split=> H.
 80 |   - by congr (_ .+1).
 81 |   - apply/eqP.
 82 |     rewrite -eqSS.
 83 |     apply/eqP.
 84 |     by apply H.
 85 | Qed.
 86 | 
 87 | Goal forall (n m : nat), n = m \/ n <> m.
 88 | Proof.
 89 |   elim=> [m | n IHn m].                     (* elim: n *)
 90 |   - by elim: m; [left | right].             (* elim: m *)
 91 |   - elim: m => [| m _].
 92 |     + by right.
 93 |     + elim: (IHn m); [left | right].
 94 |       * by congr (_ .+1).
 95 |       * by move/eq_S_S : H.                 (* move:H; move/eq_S_S *)
 96 | Qed.
 97 | 
 98 | (* 問11. *)
 99 | Goal forall (P Q : nat -> Prop),
100 |        (forall n, P n -> Q n) -> ((forall n, P n) -> (forall n, Q n)).
101 | Proof.
102 |   move=> P Q H H0 n.
103 |   by apply/H/H0.
104 | Qed.
105 | 
106 | (* END *)
107 | 


--------------------------------------------------------------------------------
/elpi/coq_elpi_tailrec.v:
--------------------------------------------------------------------------------
  1 | (**
  2 | 末尾再帰判定するコマンド
  3 | 
  4 | 2023_2_23
  5 | 
  6 | @suharahiromichi
  7 | 
  8 | see. prolog/elpi/minifp.elpi
  9 | *)
 10 | 
 11 | From elpi Require Import elpi.
 12 | 
 13 | Fixpoint fib (n : nat) : nat :=
 14 | 	match n with
 15 | 	| O => O
 16 | 	| S m => match m with
 17 | 			 | O => 1
 18 | 			 | S m' => fib m + fib m'
 19 | 			 end
 20 | 	end.
 21 | Compute fib 10.							(* 55 *)
 22 | 
 23 | Fixpoint trec_fib (n a b : nat) : nat :=
 24 | 	match n with
 25 | 	| 0 => a
 26 | 	| S m => trec_fib m b (a + b)
 27 | 	end.
 28 | Compute trec_fib 10 0 1.				(* 55 *)
 29 | 
 30 | Fixpoint fact (n : nat) : nat :=
 31 | 	match n with
 32 | 	| O => 1
 33 | 	| S m => n * fact m
 34 | 	end.
 35 | Compute fact 5.							(* 120 *)
 36 | 
 37 | Fixpoint trec_fact (n a : nat) :nat :=
 38 | 	match n with
 39 | 	| 0 => a
 40 | 	| S m => trec_fact m (n * a)
 41 | 	end.
 42 | Compute trec_fact 5 1.					(* 120 *)
 43 | 
 44 | (**
 45 | fix (f\ M) の f が、match(ネストしてもよい)の節の最外側に限って出現することをチェックする。
 46 | *)
 47 | Elpi Command tailrec.
 48 | Elpi Accumulate lp:{{
 49 | /**
 50 | app の先頭に出現するならば、successとする。
 51 | */
 52 | pred trec i:term i:term.
 53 | %trec F M :- coq.say "trec=" F "," M, fail.		% Check
 54 | trec F (fun _ _ M) :- pi n\ trec F (M n).
 55 | trec F (match _ _ L) :-	std.exists L (trec F).
 56 | trec F (app [F | _]).
 57 | trec F (app [N | _]) :- trec F N.
 58 | 
 59 | /**
 60 | app の先頭以外に出現するならば、successとする。
 61 | */
 62 | pred occr i:term i:term.
 63 | %occr F M :- coq.say "occr=" F "," M, fail.		% Check
 64 | occr F (fun _ _ M) :- pi n\ occr F (M n).
 65 | occr F (match _ _ L) :-	std.exists L (occr F).
 66 | % appの先頭にFが出現した場合は、それ以外の箇所だけでを見る。
 67 | occr F (app [F | L]) :- !, std.exists L (occr F).
 68 | occr F (app [N | L]) :- occr F N, !, std.exists L (occr F).
 69 | % appの先頭にFが出現ししない場合は、全体を見る。
 70 | occr F (app L) :- std.exists L (occr F).
 71 | occr F F.
 72 | 
 73 | /**
 74 | どこにでも出現するならば、successとする。(不使用)
 75 | */
 76 | pred in i:term i:term.
 77 | %in F M :- coq.say "in=" F "," M, fail.			% Check
 78 | in F (fun _ _ M) :- pi n\ in F (M n).
 79 | in F (match _ _ L) :- std.exists L (in F).
 80 | in F (app L) :- std.exists L (in F).
 81 | in F F.
 82 | 
 83 | main [str Name] :-
 84 | 	coq.locate Name (const Const),
 85 |   	coq.env.const Const (some Bo) Ty,
 86 |   	coq.say "tailrec=" Bo,						% Check
 87 | 	Bo = fix _ _ _ M,
 88 | 	pi f\ trec f (M f),
 89 | 	not (pi f\ occr f (M f)).					% おかしくなったらここを外す！
 90 | main [str Name] :-	
 91 | 	coq.say Name "IS NOT A RECURCEIVE FUNCTION.",
 92 | 	!, fail.
 93 | }}.
 94 | Elpi Typecheck.
 95 | 
 96 | Fail Elpi tailrec fib.
 97 | Elpi tailrec trec_fib.
 98 | Fail Elpi tailrec fact.
 99 | Elpi tailrec trec_fact.
100 | 
101 | (* END *)
102 | 


--------------------------------------------------------------------------------
/ex2014/ex31.v:
--------------------------------------------------------------------------------
 1 | Require Import ssreflect.
 2 | 
 3 | (**
 4 | # 第7回 ソースファイルの分割とコンパイル/SectionとModule (2014/05/18)
 5 | 
 6 | http://qnighy.github.io/coqex2014/ex7.html
 7 | *)
 8 | 
 9 | (**
10 | ## 課題31 (種別:A / 締め切り : 2014/05/25)
11 | 
12 | Sectionを使って、非空なリストを表すposlistを定義する。この定義を埋めよ。
13 | *)
14 | 
15 | (* Section の練習 *)
16 | 
17 | Section Poslist.
18 |   (* このセクションの中では、Aが共通の変数として使える。 *)
19 |   Variable A : Type.
20 |   (* 非空なリスト *)
21 |   Inductive poslist : Type :=
22 |   | base of A
23 |   | cons of A & poslist.
24 | 
25 |   Section Fold.
26 |     (* 二項演算 *)
27 |     Variable g : A -> A -> A.
28 | 
29 |    (* gによって畳み込む。
30 |     * 次のどちらかを定義すること。どちらでもよい。
31 |     * 左畳み込み : リスト [a; b; c] に対して (a * b) * c を計算する。
32 |     * 右畳み込み : リスト [a; b; c] に対して a * (b * c) を計算する。
33 |     *)
34 |     Definition fold : poslist -> A :=   (* 右畳み込み *)
35 |       fun l =>
36 |         (fix fold' (l' : poslist) : A :=
37 |            match l' with
38 |              | base a => a
39 |              | cons a l'' => g a (fold' l'')
40 |            end) l.
41 |   End Fold.
42 | 
43 |   Check poslist.                            (* : Type *)
44 |   Check base.                               (* : A -> poslist A *)
45 |   Check cons.                               (* : A -> poslist A -> poslist A *)
46 |   Check fold.         (* : (A -> A -> A) -> poslist A -> A  *)
47 | End Poslist.
48 | (* Poslistから抜けたことにより、poslistは変数Aについて量化された形になる。 *)
49 | 
50 | Check poslist.                              (* : Type -> Type *)
51 | Check base.                                 (* : forall A : Type, A -> poslist A *)
52 | Check cons.                                 (* : forall A : Type, A -> poslist A -> poslist A *)
53 | Check fold.           (* : forall A : Type, (A -> A -> A) -> poslist A -> A  *)
54 | 
55 | (* このリストに関するmap関数 *)
56 | Section PoslistMap.
57 |   Variable A B : Type.
58 |   Variable f : A -> B.
59 | 
60 |   Definition map : poslist A -> poslist B :=
61 |       fun l =>
62 |         (fix map' (l' : poslist A) : poslist B :=
63 |            match l' with
64 |              | base a => base B (f a)
65 |              | cons a l'' => cons B (f a) (map' l'')
66 |            end) l.
67 | 
68 |   Check map.                                (* : poslist A -> poslist B *)
69 | End PoslistMap.
70 | 
71 | Check map.        (* : forall A B : Type, (A -> B) -> poslist A -> poslist B *)
72 | 
73 | (**
74 | ヒント
75 | 
76 | 同じ変数や仮定を使いまわすときは、この例のようにSectionで囲うと便利です。
77 | 
78 | Sectionから抜けると、変数として仮定されていたものがforallの形でSection内の定義に自動的に付
79 | 加されます。
80 | 
81 | Section内の変数はVariable, Variablesで宣言します。仮定は、Hypothesis, Hypothesesで宣言しま
82 | す。(これらの効果は同じです。意味に応じて使い分けてください。)
83 | 
84 | Variableの亜種として、Contextというものもあります。Section内では、DefinitionとLetは異なる効
85 | 果を持ちます。気になる人は確認してみてください。
86 | 
87 | *)
88 | 


--------------------------------------------------------------------------------
/elpi/coq_elpi_examples_memo.md:
--------------------------------------------------------------------------------
  1 | https://github.com/LPCIC/coq-elpi/tree/master/examples
  2 | 
  3 | の下にある example_XXXX.v を攻略するためのメモ
  4 | 
  5 | 
  6 | 2023/1/7 @suharahiromichi
  7 | 
  8 | q
  9 | 
 10 | 
 11 | VSCodeでエラーになる場合は、VSCodeを再起動すること。
 12 | 
 13 | ##  example_curry_howard_tactics.v
 14 | 
 15 | - intro ダクティクの実装例
 16 | 
 17 | - auto ダクティクの実装例
 18 | 
 19 | 
 20 | ##  example_data_base.v
 21 | 
 22 | - Dbの一般的な使い方。
 23 | 
 24 | 
 25 | ##  example_fuzzer.v
 26 | 
 27 | - fuzzer コマンド
 28 | 
 29 | 与えられたプログラムの (?Op ?A ?B) を (AND ?A ?B) にするコマンドである。
 30 | 実際の ?Op は OR が該当する。
 31 | 
 32 | テストの手法のひとつに、文法的に正しいが、意味の壊れたコード与えるという方法がある。
 33 | このテストのことをfuzzingまたはfuzz-testといい、
 34 | テストコードを生成するプログラムをfuzzerという。
 35 | CompCertでの証明の正しさを確かめるために、CSmithというfuzzerを使ったfuzzingを行った。
 36 | 
 37 | Software Fundation の後書きに、以下の記述がある；
 38 | 
 39 | In 2011, CompCert was included in a landmark study on fuzz-testing a
 40 | large number of real-world C compilers using the CSmith tool.
 41 | 
 42 | 
 43 | ##  example_generalize.v
 44 | 
 45 | - generalize コマンド
 46 | 
 47 | Coq項{{1}} をλ変数にするコマンド。ただし結果はPrint。
 48 | 項として与えるために、引数は``()``で囲むこと。
 49 | 
 50 | ``(2) ====> (fun x => S x)``
 51 | 
 52 | 
 53 | ##  example_import_projections.v
 54 | 
 55 | - import.projections コマンド
 56 | 
 57 | 不明
 58 | 
 59 | 
 60 | ##  example_record_expansion.v
 61 | 
 62 | - record.expand コマンド
 63 | 
 64 | 引数をレコードのセレクタで分割する場合、それを展開する。
 65 | 
 66 | ```
 67 | Example:
 68 |         Record r := mk { proj1 : T1; proj2 : T2 }.
 69 |         Definition f (x : r) := Body(proj1 x,proj2 x).
 70 | 
 71 | Is expanded to:
 72 |    Definition f1 v1 v2 := Body(v1,v2).
 73 | ```
 74 | 
 75 | ##  example_record_to_sigma.v
 76 | 
 77 | - UM.expand コマンド
 78 | 
 79 | レコードの定義の前につけると、レコードをネストしたsigma-typeで定義することができる。
 80 | 
 81 | sigma-type は、Strong dependent sum である sigT を使う。
 82 | 
 83 | ```
 84 | Inductive sigT (A:Type) (P : A -> Type) : Type :=
 85 |     existT : forall x:A, P x -> sigT P.
 86 | ```
 87 | 
 88 | 実際は、Notationをつかって、``{x : A & (P x)} := sigT A P `` を使用する。
 89 | 
 90 | 
 91 | （参考：通常の exists は、sig であり、``P : A -> Prop`` であるところが違う。``{x : A | P x} := sig A P `` ）
 92 | 
 93 | 
 94 | ##  example_reduction_surgery.v
 95 | 
 96 | - reduce タクティク
 97 | 
 98 | 引数にモジュール名をとり、そこでの定義を展開する。
 99 | 
100 | モジュールToRedの中の定義：
101 | 
102 | ```
103 | Module ToRed.
104 | Definition x := 1.
105 | Definition y := 1.
106 | Definition alias := plus.
107 | End ToRed.
108 | ```
109 | 
110 | ```
111 | ToRed.x + ToRed.y = (let z := 1 in S z)
112 | ----------------------------------------- elpi reduce "ToRed".
113 | 2 = (let z := 1 in S z)
114 | ```
115 | 
116 | ## example_reflexive_tactic.v
117 | 
118 | - monoid タクティク (reflexive normalizer)
119 | 
120 | モノイド則によってゴールを変形する。
121 | ringタクティクと異なり証明が終わらなくてもよい。
122 | 
123 | 
124 | 以上
125 | 


--------------------------------------------------------------------------------
/ssr/ssr_ais_6_1_4_rst_depth_first_search.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | An introduction to small scale reflection in Coq
 3 | 
 4 | 6.1.4 Example: a depth rst search algorithm
 5 | 
 6 | http://hal.inria.fr/docs/00/55/53/79/PDF/main-rr.pdf
 7 | *)
 8 | 
 9 | Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
10 | Require Import path choice fintype tuple finfun finset.
11 | 
12 | Set Implicit Arguments.
13 | Unset Strict Implicit.
14 | Import Prenex Implicits.
15 | 
16 | Variables (T : finType) (e : T -> seq T).
17 | 
18 | Definition grel := [rel x y | y \in e x].
19 | Check grel : rel T.                         (* simpl_rel T := rel T *)
20 | Check [rel x y : T | y \in e x] : rel T.
21 | Check [rel x y : nat | y \in [:: x]] : rel nat.
22 | Check (fun x y : nat => y \in [:: x]) : rel nat.
23 | 
24 | (* 参考 *)
25 | Check [pred n : nat | n == 0] : pred nat.
26 | Check (fun n : nat => n == 0) : pred nat.
27 | Check mem [pred n : nat | n == 0] : mem_pred nat.
28 | Check mem [:: 1 ; 2] : mem_pred nat.
29 | 
30 | Fixpoint dfs (n : nat) (a : seq T) (x : T) {struct n} :=
31 |   if n is n'.+1 then
32 |     if x \in a then a else foldl (dfs n') (x :: a) (e x)
33 |   else a.
34 | 
35 | Inductive dfs_path x y (a : seq T) : Prop :=
36 |   DfsPath p of (path grel x p) & (y = last x p) & [disjoint (x :: p) & a].
37 | 
38 | (* 古い書き方 *)
39 | Inductive dfs_path' x y (a : seq T) : Prop :=
40 |   DfsPath' p : (path grel x p) -> (y = last x p) ->
41 |                [disjoint (x :: p) & a] -> dfs_path' x y (a : seq T).
42 | 
43 | (**
44 | dfs_path の意味：
45 | - ふたつの連続した要素からなるseq 「x :: p」 は、
46 |   grel関係である。それらはグラフ上で隣接adjacentしている。
47 | - y は p の最後の要素である。
48 | - seq 「x :: p」は、seq a の要素ではない。
49 | *)
50 | 
51 | Lemma max_card : forall (T : finType) (A : pred T), #|A| <= #|T|.
52 | Proof.
53 |   admit.
54 | Qed.
55 | 
56 | Lemma dfsP : forall n x y (a : seq T),
57 |                #|T| <= #|a| + n ->
58 |                             y \notin a ->
59 |                             reflect (dfs_path x y a) (y \in dfs n a x).
60 | Proof.
61 |   elim=> [|n IHn] x y a Hn Hy /=.           (* elim by n *)
62 |   - case/idPn: (max_card (predU1 y (mem a))).
63 |     by rewrite -ltnNge cardU1 (negPf Hy) addSn addnC.
64 |   - case Hx: (x \in a).
65 |     + move Da': (x :: a) => a'.
66 |       case Hya': (y \in a').
67 |   (* Hya' : (y \in a') = true *)
68 |       * admit.                                  (* Exercise 6.1.15 *)
69 |   (* Hya' : (y \in a') = false *)
70 |       * admit.
71 |     + admit.
72 | Qed.
73 | 
74 | (* last は、pの最後の要素、[::]ならx。 *)
75 | Lemma dfs_pathP : forall x y,
76 |                     reflect
77 |                       (exists2 p, (path grel x p) & (y = last x p))
78 |                       (y \in dfs #|T| [::] x).
79 | Proof.
80 |   admit.
81 | Qed.
82 | 
83 | (* END *)
84 | 


--------------------------------------------------------------------------------
/prog/coq_sublist.v:
--------------------------------------------------------------------------------
 1 | Require Import List.
 2 | Require Import Omega.
 3 | Require Import Sorting.Permutation.
 4 | Require Import Sorting.Sorted.
 5 | Require Import Program.Wf.
 6 | Require Import Arith.Bool_nat.
 7 | 
 8 | (*
 9 | Reserved Notation "` x" (at level 99).
10 | Notation "` x" := (proj1_sig x).
11 |  *)
12 | 
13 | Section Swap.
14 |   Program Definition swap {T : Type} (x : T * T) :
15 |     {y | fst x = snd y /\ snd x = fst y} :=
16 |     let '(x1, x2) := x in (x2, x1).
17 |   (* Obligation なし *)
18 |   
19 |   Compute proj1_sig (swap (1, 2)).          (* (2, 1) *)
20 | End Swap.
21 | 
22 | Section Sublist.
23 |   Variable A : Type.
24 |   Variable f : A -> bool.
25 | 
26 |   (* Sublist l' l <==> l' ⊆ l *)
27 |   Inductive Sublist : list A -> list A -> Prop :=
28 |   | SL_nil l : Sublist nil l
29 |   | SL_skip x l' l : Sublist l' l -> Sublist l' (x :: l)
30 |   | SL_cons x l' l : Sublist l' l -> Sublist (x :: l') (x :: l).
31 |   
32 |   Hint Constructors Sublist.
33 |   
34 |   (* Sublist なら長さが減る。 *)
35 |   Lemma sublist__length (l l' : list A) :
36 |     Sublist l' l -> length l' <= length l.
37 |   Proof.
38 |     intro H.
39 |     induction H; subst; simpl in *; try auto; omega.
40 |   Qed.
41 |   
42 |   (* *** *)
43 |   Lemma sublist_ref (l : list A) :
44 |     Sublist l l.
45 |   Proof.
46 |     induction l as [|x l' IHl]; now auto.
47 |   Qed.
48 |   
49 |   Lemma sublist_trans (l l' l'' : list A) :
50 |     Sublist l'' l' -> Sublist l' l -> Sublist l'' l.
51 |   Proof.
52 |   Admitted.                               (* mathcomp seq.v *)
53 |   
54 | 
55 |   Program Fixpoint filter (l : list A) :
56 |     {l' | Sublist l' l /\ Forall (fun x => f x = true) l'} :=
57 |     (* さらに、l' が最大の長さのものであることを示す必要がある。 *)
58 |     match l with
59 |     | nil => nil
60 |     | x :: l => if f x then x :: (filter l) else filter l
61 |     end.
62 |   Obligation 2.
63 |   Proof.
64 |     split.
65 |     - now auto.
66 |     - apply Forall_cons.
67 |       + admit.                              (*  f x = true *)
68 |       + now auto.
69 |   Defined.
70 |   
71 |   (* filter の結果は Sublist である。 *)
72 |   Lemma filter__sublist (l : list A) :
73 |     Sublist (proj1_sig (filter l)) l.
74 |   Proof.
75 |     induction l; subst; simpl in *.
76 |     - now auto.
77 |     - destruct (f a); simpl; now auto.
78 |   Qed.
79 |   
80 | End Sublist.
81 | 
82 | (* Arith.Bool_nat で定義されている。 *)
83 | Check nat_eq_bool : forall x y : nat, {b : bool | if b then x = y else x <> y}.
84 | Check nat_noteq_bool : forall x y : nat, {b : bool | if b then x <> y else x = y}.
85 | 
86 | Compute proj1_sig (filter nat
87 |                           (fun x => (proj1_sig (nat_noteq_bool x 2)))
88 |                           (1 :: 2 :: 3 :: nil)).
89 |   
90 | Extraction filter.
91 | 
92 | (* END *)
93 | 


--------------------------------------------------------------------------------
/regexp/ssr_regexp_ex152.v:
--------------------------------------------------------------------------------
 1 | Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype.
 2 | Require Import div prime.
 3 | Require Import regexp pumping.
 4 | 
 5 | (**
 6 | https://www.ps.uni-saarland.de/~doczkal/regular/
 7 | の Coq development からリンクされる、
 8 | ConstructiveRegularLanguages.tgz
 9 | を展開して、make する。
10 | *)
11 | (**
12 | 以下は、その同じ場所で実行する。
13 | *)
14 | 
15 | Set Implicit Arguments.
16 | Unset Strict Implicit.
17 | Import Prenex Implicits.
18 | 
19 | (**
20 | Tukuba Coq Users' Grup 「Coqによる定理証明」
21 | 坂口さん著「反復定理で遊ぼう」 1.5.2 から。
22 | *)
23 | 
24 | Variable char : finType.
25 | 
26 | Lemma nseq_eq_cat (x : char) n xs ys :
27 |   nseq n x = xs ++ ys -> nseq (size xs) x = xs /\ nseq (size ys) x = ys.
28 | Proof.
29 |   elim: n xs ys => //=.
30 |   - by do 2 case=> //=.
31 |   - move=> n IH [] //=.
32 |     + by case=> //= y ys [] H H0; subst y ys; rewrite size_nseq.
33 |     + by move=> a xs ys [] H; subst a; case/IH => {2}<- {2}<-. (* 2番め出現でrewriteする。 *)
34 | Qed.
35 | 
36 | (** 1.5.2 例: {x | |x|a = |x|b }、語xにおける、文字aとbの出現回数が同じ。 *)
37 | Definition lang (a b : char) : word char -> Prop :=
38 |   fun (s : word char) => count (fun c => c == a) s = count (fun c => c == b) s.
39 | 
40 | (** lang が正規言語でないことを証明する *) (* 1.5.1 節とほとんど変わらない証明 *)
41 | Lemma anbn_non_regular (a b : char) :
42 |   a != b -> ~ regular (lang a b).
43 | Proof.
44 |   move/negbTE => H.
45 |   apply pumping => k.
46 |   exists [::].
47 |   exists (nseq k a).
48 |   exists (nseq k b).
49 |   rewrite size_nseq leqnn /=.
50 |   split; last split.
51 |   - by [].
52 |   - rewrite /lang.                          (* Goal : lang a b (nseq k a ++ nseq k b) *)
53 |     rewrite !count_cat !non_regular.count_nseq.
54 |     rewrite !eqxx.                          (* a == a と b == b の書き換え。 *)
55 |     rewrite (eq_sym b a) H.                 (* a == b と b == a の書き換え。 *)
56 |     by [].
57 |   - move=> u v w H0.
58 |     move: H0 (H0).                          (* 前提をふたつにコピーする。 *)
59 |     case/nseq_eq_cat => <-.
60 |     case/nseq_eq_cat => <-.
61 |     move=> <-.
62 |     move: {u v w} (size u) (size v) (size w) => u v w.
63 |     rewrite !cat_nseq_eq addnA.
64 |     move/(f_equal size); rewrite !size_nseq => -> {k}; case: v => // v _.
65 |     exists 0; move=> /=.
66 |     (* Goal : lang a b (nseq u a ++ nseq w a ++ nseq (u + v.+1 + w) b) -> False *)
67 |     rewrite /lang.
68 |     rewrite !count_cat !non_regular.count_nseq.
69 |     rewrite !eqxx.
70 |     rewrite (eq_sym b a) H => /=.
71 |     nat_norm => /eqP.                       (* 以降、数式の計算をする。 *)
72 |     (* u + 1 * w == 1 * (u + (v + w)).+1 -> False *)
73 |     rewrite !mul1n -addnS -addSn.
74 |     rewrite eqn_add2l -{1}[w]add0n.         (* 両辺のuを消す。 *)
75 |     rewrite eqn_add2r.                      (* 両辺のwを消す。 *)
76 |     (* 0 == v.+1 -> False *)
77 |     by [].
78 | Qed.
79 | 
80 | (* END *)
81 | 


--------------------------------------------------------------------------------
/alg/rat_sample.v:
--------------------------------------------------------------------------------
 1 | From mathcomp Require Import all_ssreflect.
 2 | From mathcomp Require Import all_algebra.
 3 | 
 4 | (* ssralg で定義される型 *)
 5 |      Check rat : nmodType.                  (* additive abelian monoid *)
 6 |      Check rat : zmodType.                  (* additive abelian group (Nmodule with an opposite) *)
 7 |      Check rat : semiRingType.              (* non-commutative semi rings *)
 8 |      Check rat : comSemiRingType.           (* commutative semi rings *)
 9 |      Check rat : ringType.                  (* non-commutative rings (semi rings with an opposite) *)
10 |      Check rat : comRingType.               (* commutative rings *)
11 |      Check rat : unitRingType.              (* Rings whose units have computable inverses *)
12 |      Check rat : comUnitRingType.           (* commutative UnitRing *)
13 |      Check rat : idomainType.               (* integral, commutative, ring with partial inverses *)
14 | 
15 |      Check rat : fieldType.                 (* commutative fields *)
16 | Fail Check rat : decFieldType.              (* fields with a decidable first order theory *)
17 | Fail Check rat : closedFieldType.           (* 閉体 *)
18 | 
19 | (* ssrnum で定義される型 *)
20 |      Check rat : porderZmodType.            (* join of Order.POrder and GRing.Zmodule *)
21 | Fail Check rat : normedZmodType.            (* Zmodule with a norm *) (* MAY BE BUG *)
22 |      Check rat : numDomainType.             (* Integral domain with an order and a norm *)
23 |      Check rat : realDomainType.            (* Num domain where all elements are positive or negative *)
24 | 
25 |      Check rat : numFieldType.              (* Field with an order and a norm *)
26 | Fail Check rat : numClosedFieldType.        (* Partially ordered Closed Field with conjugation *)
27 |      Check rat : realFieldType.             (* Num Field where all elements are positive or negative *)
28 |      Check rat : archiFieldType.            (* A Real Field with the archimedean axiom *)
29 | Fail Check rat : rcfType.                   (* A Real Field with the real closed axiom *)
30 | 
31 | (* rat の作り方 *)
32 | Check GRing.isZmodule.Build rat addqA addqC add0q addNq.
33 | Check zmodType.
34 | 
35 | Check GRing.Zmodule_isComRing.Build rat mulqA mulqC mul1q mulq_addl nonzero1q.
36 | Check comRingType.
37 | 
38 | Check GRing.ComRing_isField.Build rat mulVq invq0.
39 | Check fieldType.
40 | 
41 | Check Num.IntegralDomain_isLeReal.Build rat le_rat0D le_rat0M le_rat0_anti
42 |   subq_ge0 (@le_rat_total 0%R) norm_ratN ge_rat0_norm lt_rat_def.
43 | Check realFieldType.
44 | 
45 | Check Num.RealField_isArchimedean.Build rat rat_archimedean.
46 | Check archiFieldType.
47 | 
48 | 
49 | 
50 | 
51 | 
52 | 
53 | 
54 | Check GRing.isSubringClosed.Build rat Qint_pred Qint_subring_closed.
55 | Check GRing.isSemiringClosed.Build rat Qnat_pred Qnat_semiring_closed.
56 | 


--------------------------------------------------------------------------------
/math-comp-book/suhara.ch6.finset.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | finset_eqType, finset_choiceType, finset_countType, finset_finType を求める。
 3 |  *)
 4 | 
 5 | From mathcomp Require Import all_ssreflect.
 6 | From mathcomp Require Import perm.
 7 | 
 8 | (**
 9 | ## subType
10 |  *)
11 | 
12 | Section SetType.
13 | 
14 | Variable T : finType.
15 | 
16 | Inductive set_type : predArgType := FinSet of {ffun pred T}.
17 | Definition finfun_of_set A := let: FinSet f := A in f.
18 | Definition set_of of phant T := set_type.
19 | Identity Coercion type_of_set_of : set_of >-> set_type.
20 | 
21 | Canonical set_subType := Eval hnf in [newType for finfun_of_set].
22 | 
23 | (**
24 | ## eqType
25 |  *)
26 | 
27 | Definition set_eqMixin := Eval hnf in [eqMixin of set_type by <:].
28 | Canonical set_eqType := Eval hnf in EqType set_type set_eqMixin.
29 | 
30 | (**
31 | ## choiceType
32 |  *)
33 | 
34 | Definition set_choiceMixin := [choiceMixin of set_type by <:].
35 | Canonical set_choiceType := Eval hnf in ChoiceType set_type set_choiceMixin.
36 | 
37 | (**
38 | ## countType
39 | *)
40 | 
41 | Definition set_countMixin := [countMixin of set_type by <:].
42 | Canonical set_countType := Eval hnf in CountType set_type set_countMixin.
43 | Canonical set_subCountType := Eval hnf in [subCountType of set_type].
44 | 
45 | 
46 | (**
47 | ## finType
48 |  *)
49 | 
50 | Definition set_finMixin := [finMixin of set_type by <:].
51 | Canonical set_finType := Eval hnf in FinType set_type set_finMixin.
52 | Canonical set_subFinType := Eval hnf in [subFinType of set_type].
53 | 
54 | End SetType.
55 | 
56 | 
57 | (**
58 | ## おまけ
59 |  *)
60 | 
61 | Section BasicSetTheory.
62 | 
63 | Variable T : finType.
64 | Implicit Types (x : T) (A B : {set T}) (pA : pred T).
65 | 
66 | (*
67 | Canonical set_of_subType := Eval hnf in [subType of {set T}].
68 | Canonical set_of_eqType := Eval hnf in [eqType of {set T}].
69 | Canonical set_of_choiceType := Eval hnf in [choiceType of {set T}].
70 | Canonical set_of_countType := Eval hnf in [countType of {set T}].
71 | Canonical set_of_subCountType := Eval hnf in [subCountType of {set T}].
72 | Canonical set_of_finType := Eval hnf in [finType of {set T}].
73 | Canonical set_of_subFinType := Eval hnf in [subFinType of {set T}].
74 |  *)
75 | 
76 | Lemma in_set pA x : x \in finset pA = pA x.
77 | Proof. by rewrite [@finset]unlock unlock [x \in _]ffunE. Qed.
78 | 
79 | Lemma setP A B : A =i B <-> A = B.
80 | Proof.
81 | by split=> [eqAB|-> //]; apply/val_inj/ffunP=> x; have:= eqAB x; rewrite unlock.
82 | Qed.
83 | 
84 | Definition set0 := [set x : T | false].
85 | Definition setTfor (phT : phant T) := [set x : T | true].
86 | 
87 | Lemma in_setT x : x \in setTfor (Phant T).
88 | Proof. by rewrite in_set. Qed.
89 | 
90 | Lemma eqsVneq A B : {A = B} + {A != B}.
91 | Proof. exact: eqVneq. Qed.
92 | 
93 | End BasicSetTheory.
94 | 
95 | 
96 | (* END *)
97 | 


--------------------------------------------------------------------------------
/math-comp-book/suhara.ch56.unit.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | unit_eqType, unit_choiceType, unit_countType, unit_finType を求める。
 3 |  *)
 4 | 
 5 | From mathcomp Require Import all_ssreflect.
 6 | From mathcomp Require Import perm.
 7 | 
 8 | (**
 9 | ## eqType
10 |  *)
11 | Check @EqMixin : forall (T : Type) (op : rel T),
12 |     Equality.axiom (T:=T) op -> Equality.mixin_of T.
13 | 
14 | Definition eqUnit (_ _ : unit) := true.     (* op *)
15 | 
16 | (* boolean とのリフレクションが成り立つ *)
17 | Lemma unit_eqP : @Equality.axiom unit eqUnit. (* axiom *)
18 | Proof.
19 |     by do 2!case; left.
20 | Qed.
21 | 
22 | Definition unit_eqMixin := @EqMixin unit eqUnit unit_eqP.
23 | (* Definition unit_eqMixin := EqMixin unit_eqP. *)
24 | Canonical unit_eqType := Eval hnf in EqType unit unit_eqMixin.
25 | 
26 | 
27 | (**
28 | ## choiceType
29 |  *)
30 | Check @CanChoiceMixin : forall (T : choiceType) (sT : Type) (f : sT -> T) (f' : T -> sT),
31 |     cancel f f' -> choiceMixin sT.
32 | 
33 | (* boolによるピックアップができること。 *)
34 | Definition pickUnit : unit -> bool := xpredT.
35 | Definition unpickUnit : bool -> unit := fun _ => tt.
36 | 
37 | (* pickとunpickで消せること。 *)
38 | Lemma bool_of_unitK : cancel pickUnit unpickUnit.
39 | Proof.
40 |     by case.
41 | Qed.
42 | 
43 | Definition unit_choiceMixin := @CanChoiceMixin bool_choiceType unit
44 |                                                pickUnit unpickUnit 
45 |                                                bool_of_unitK.
46 | (* Definition unit_choiceMixin := CanChoiceMixin bool_of_unitK. *)
47 | Canonical unit_choiceType := Eval hnf in ChoiceType unit unit_choiceMixin.
48 | 
49 | 
50 | (**
51 | ## countType
52 |  *)
53 | Check @CanCountMixin : forall (T : countType) (sT : Type) (f : sT -> T) (f' : T -> sT),
54 |     cancel f f' -> Countable.mixin_of sT.
55 | 
56 | Definition unit_countMixin := @CanCountMixin bool_countType unit
57 |                                              pickUnit unpickUnit
58 |                                              bool_of_unitK.
59 | (* Definition unit_countMixin := CanCountMixin bool_of_unitK. *)
60 | Canonical unit_countType := Eval hnf in CountType unit unit_countMixin.
61 | 
62 | 
63 | (**
64 | ## finType
65 |  *)
66 | Check @FinMixin : forall (T : countType) (e : seq T),
67 |     Finite.axiom (T:=T) e -> Finite.mixin_of T.
68 | 
69 | Definition enumUnit := [:: tt].             (* enum *)
70 | 
71 | (* enum のなかに 型の要素がひとつづつ存在する。 *)
72 | Lemma unit_enumP : @Finite.axiom unit_eqType enumUnit.   (* axiom *)
73 | Proof.
74 |     by case.
75 | Qed.
76 | 
77 | Definition unit_finMixin := @FinMixin unit_countType enumUnit unit_enumP.
78 | (* Definition unit_finMixin := Eval hnf in FinMixin unit_enumP. *)
79 | Canonical unit_finType := Eval hnf in FinType unit unit_finMixin.
80 | 
81 | Lemma card_unit : #|{: unit}| = 1.
82 | Proof.
83 |     by rewrite cardT enumT unlock.
84 | Qed.
85 | 
86 | (* END *)
87 | 


--------------------------------------------------------------------------------
/math4/ssr_root2_contrarian.v:
--------------------------------------------------------------------------------
 1 | (**
 2 | √2 が無理数
 3 | 
 4 | 背理法による「有名な証明」に沿っている。
 5 | 
 6 | - https://www.math.nagoya-u.ac.jp/~garrigue/lecture/2020_AW/ssrcoq6.pdf
 7 | - https://gitlab.com/proofcafe/nu/-/blob/master/nu_ssrcoq6_3_root2.v
 8 | 
 9 | 以上の証明と似ているが、主補題の証明に帰納法（整礎帰納法）を使わないことで、簡単であるといえる。
10 | *)
11 | 
12 | From mathcomp Require Import all_ssreflect.
13 | From mathcomp Require Import all_algebra.
14 | From mathcomp Require Import ssrZ zify ring lra.
15 | 
16 | Set Implicit Arguments.
17 | Unset Strict Implicit.
18 | Unset Printing Implicit Defensive.
19 | 
20 | Section Root2.
21 | 
22 |   (**
23 | ## 補題
24 |    *)
25 |   Lemma evenP n : reflect (exists m, n = 2 * m) (~~ odd n).
26 |   Proof.
27 |     have -> : ~~ odd n = (2 %| n) by lia.
28 |     apply: (iffP eqP) => [md0 | [k ->]]; last by rewrite modnMr.
29 |     exists (n %/ 2).
30 |     lia.
31 |   Qed.
32 | 
33 |   (* これだと done がうまくいかないのは、なぜだろう。 *)
34 |   Lemma evenP' n : reflect (exists m, n = m * 2) (~~ odd n).
35 |   Proof.
36 |     have -> : ~~ odd n = (2 %| n) by lia.
37 |     by apply: dvdnP.
38 |   Qed.
39 |   
40 |   Lemma even_not_coprime p q : ~~ odd p -> ~~ odd q -> ~~ coprime p q.
41 |   Proof.
42 |     move/evenP => [p' ->].
43 |     move/evenP => [q' ->].
44 |     rewrite coprimeMl 2!coprimeMr.
45 |     Check ~~ [&& coprime 2 2 && coprime 2 q', coprime p' 2 & coprime p' q'].
46 |     done.
47 |   Qed.
48 |   
49 |   Lemma two_p2_implies_not_coprime (p q : nat) :
50 |     2 * q ^ 2 = p ^ 2 -> ~~ coprime p q.
51 |   Proof.
52 |     move=> H.
53 |     have Hq_even : ~~ odd p by lia.           (* q が偶数である。 *)
54 |     case: q H => [| q] H.
55 |     (* p = 0 の場合 *)
56 |     - rewrite /coprime gcdn0.
57 |       lia.
58 |     (* p != 0 の場合 *)
59 |     - have Hp_even : ~~ odd q.+1 by lia.      (* p が偶数である。 *)
60 |       by rewrite even_not_coprime.
61 |   Qed.
62 | 
63 |   Section Real.
64 |     Require Import Reals Field.     (* 実数とそのためのfield タクティク *)
65 |     (* 前に出すと、lia がうまくいかない。 *)
66 |     (*
67 |       Module Import GRing.
68 |      *)
69 | 
70 |   (**
71 | ## 無理数である。
72 |    *)
73 |     Definition irrational (x : R) : Prop := forall (p q : nat),
74 |         q <> 0 -> coprime p q -> x <> (INR p / INR q)%R.
75 |     
76 |   (**
77 | ## 証明したいもの ``sqrt 2`` は無理数である。
78 |    *)
79 |     Theorem irrational_sqrt_2 : irrational (sqrt (INR 2)).
80 |     Proof.
81 |       move=> p q Hq Hco Hrt.
82 |       move/negPn/negP in Hco.
83 |       apply/Hco/two_p2_implies_not_coprime/INR_eq.
84 |       move/not_INR in Hq.
85 |       
86 |       Check INR (p * p) = INR (q * q).*2.
87 |       
88 |       rewrite !mult_INR -(sqrt_def (INR 2)).
89 |       - rewrite ?Hrt.
90 |         Check (INR p * INR p)%R = (INR p / INR q * (INR p / INR q) * (INR q * INR q))%R.
91 |         by field.
92 |       - by auto with real.
93 |     Qed.
94 | 
95 |   End Real.
96 | End Root2.
97 | 
98 | (* END *)
99 | 


--------------------------------------------------------------------------------
/coq_leibnitz_equality.v:
--------------------------------------------------------------------------------
 1 | (*
 2 |    Coqの等号とLeibnitz equalityが等価であることについて。
 3 |    
 4 |    http://d.hatena.ne.jp/m-a-o/touch/20110325/p1
 5 |    (2)equalityの話 を参考にした。
 6 | *)
 7 | 
 8 | (* Coq の equality *)
 9 | Inductive eq (A : Type) (x : A) : A -> Prop :=
10 |   eq_refl : eq A x x.
11 | 
12 | (* Leibnitz equality *)
13 | Definition leibnitz_eq (A : Type) (a b : A) : Prop :=
14 |   forall P : A -> Prop, P a -> P b.
15 | 
16 | (* Agdaだと、Leibnitz equalityは、以下の型を持つ。
17 |    {A : Set} -> A -> A -> Set1
18 | *)
19 | 
20 | (* Leibnitz equality と coqのequality が等価であることを証明する。 *)
21 | Theorem eq_leibnitz_eq : forall (A : Type) (a b : A),
22 |   leibnitz_eq A a b <-> a = b.
23 | Proof.
24 |   intros A a b.
25 |   split.
26 |   
27 |   (* leibnitz_eq A a b -> a = b *)
28 |   intros H1.
29 |   apply H1.
30 |   reflexivity.
31 |   
32 |   (* a = a -> leibnitz_eq A a b *)
33 |   unfold leibnitz_eq.
34 |   intros H2.
35 |   rewrite H2.
36 |   intros P Hpb.
37 |   apply Hpb.
38 | Qed.
39 | 
40 | (* eq_ind の leibnitz_eq 版を定義する。 *)
41 | Definition leibnitz_eq_ind : forall (A : Type) (x : A) (P : A -> Prop),
42 |   P x ->forall y : A, leibnitz_eq A x y -> P y.
43 | Proof.
44 |   unfold leibnitz_eq.
45 |   intros A x P H y H0.
46 |   Check (H0 P H).
47 |   apply (H0 P H).
48 | Defined.
49 | Print leibnitz_eq_ind.
50 | 
51 | Definition leibnitz_eq_ind' : forall (A : Type) (x : A) (P : A -> Prop),
52 |   P x -> forall y : A, leibnitz_eq A x y -> P y :=
53 |     fun (A : Type) (x : A) (P : A -> Prop) (H : P x) (y : A)
54 |       (H0 : forall P0 : A -> Prop, P0 x -> P0 y) => H0 P H.
55 | 
56 | (* 参考：eq_indも同様な形で、自分で定義できる。 *)
57 | Definition eq_ind_me : forall (A : Type) (x : A) (P : A -> Prop),
58 |   P x -> forall y : A, eq A x y -> P y.
59 | Proof.
60 |   intros A x P H y H0.
61 |   destruct H0.
62 |   apply H.
63 | Defined.
64 | Print eq_ind_me.
65 | 
66 | Definition eq_ind_me' : forall (A : Type) (x : A) (P : A -> Prop),
67 |   P x -> forall y : A, eq A x y -> P y :=
68 |     fun (A : Type) (x : A) (P : A -> Prop) => eq_rect A x P.
69 | 
70 | Definition eq_ind_me'' : forall (A : Type) (x : A) (P : A -> Prop),
71 |   P x -> forall y : A, eq A x y -> P y :=
72 |     fun (A : Type) (x : A) (P : A -> Prop) (H : P x) (y : A) (H0 : eq A x y) =>
73 |       match H0 in (eq _ _ y0) return (P y0) with
74 |         | eq_refl => H
75 |       end.
76 | 
77 | (*
78 | 以下は、
79 | http://d.hatena.ne.jp/m-a-o/touch/20110325/p1
80 | からの引用である。
81 | 
82 | ちなみに、Leibnitz equalityが関数の外延的等価性
83 | forall (A B : Type) (f g  :  A -> B) , (forall x,  f x = g x) -> f = g.
84 | を持つことをCoqでは証明できないよう。
85 | 
86 | http : //coq.inria.fr/stdlib/Coq.Logic.FunctionalExtensionality.html
87 | とかいうライブラリがあるので。具体例として、
88 | 
89 | forall (A1 A2 : Type), (fun x : prod A1 A2=>(fst x, snd x))=(fun x=>x)
90 | は外延的等価性の仮定なしには、Coqでは証明できない気がする。これが言えな
91 | いと、CoqのTupleは圏論的な意味での直積にはなっていることが証明できない。
92 | *)
93 | 
94 | (* END *)
95 | 


--------------------------------------------------------------------------------
/pnp/ssr_pnp_4_3_leqP.v:
--------------------------------------------------------------------------------
  1 | (** Programs and Proofs Ilya Sergey *)
  2 | (* http://ilyasergey.net/pnp/ *)
  3 | 
  4 | (**
  5 | 4.3 Indexed datatype families and rewriting rules
  6 | 
  7 | leqP の使い方について。
  8 |  *)
  9 | From mathcomp Require Import all_ssreflect.
 10 |   
 11 | Set Implicit Arguments.
 12 | Unset Strict Implicit.
 13 | Unset Printing Implicit Defensive.
 14 | 
 15 | Goal forall m n, m <= n.
 16 | Proof.
 17 |   move=> m n.
 18 |   case: leqP.
 19 |   Undo 1.
 20 |   Check (leqP m n) : leq_xor_gtn m n (m <= n) (n < m).
 21 |   case: (leqP m n).
 22 |   (* m <= n のとき、Goal は true *)
 23 |   (* n < m のとき、Goal は false *)
 24 | Admitted.
 25 | 
 26 | Goal forall n m o p, (m <= n) /\ (o > p) -> False.
 27 | Proof.
 28 |   move=> n m o p.
 29 |   case: leqP.
 30 |   Undo 1.
 31 |   Check (leqP o p) : leq_xor_gtn o p (o <= p) (p < o).
 32 |   case: (leqP o p).
 33 |   (* o <= p のとき、Goal は m <= n /\ false -> False *)
 34 |   (* p < o のとき、Goal は m <= n /\ true -> False *)
 35 |   Admitted.
 36 | 
 37 | (* ゴールに不等式がないと使えない。 *)
 38 | Goal forall (m n : nat), m = n.
 39 | Proof.
 40 |   move=> m n.
 41 |   Fail case: leqP.
 42 |   Check (leqP m n).
 43 |   case: (leqP m n).
 44 | Admitted.  
 45 | 
 46 | 
 47 | (* ***** PnP から ***** *)
 48 | 
 49 | 
 50 | Lemma huh' n m : (m <= n) /\ (m > n) -> False.
 51 | Proof.
 52 |   move/andP.
 53 |   case: leqP.
 54 |   Undo 1.
 55 |   Check (leqP m n) : leq_xor_gtn m n (m <= n) (n < m).
 56 |   case: (leqP m n).
 57 |   
 58 |   (* m <= n のとき、Goal は true && false -> False *)
 59 |   - done.
 60 |   (* n < m のとき、Goal は false && true -> False *)
 61 |   - done.
 62 | Qed.
 63 | 
 64 | 
 65 | Lemma max_is_max m n: n <= maxn m n /\ m <= maxn m n.
 66 | Proof.
 67 |   rewrite /maxn.
 68 |   case: leqP => //.
 69 |   move=> H; split.
 70 |   - by apply: leqnn.
 71 |   - by rewrite ltn_neqAle in H; case/andP: H.
 72 | 
 73 |   Restart.
 74 |   (* n <= maxn m n /\ m <= maxn m n *)
 75 |   rewrite /maxn.
 76 |   (* n <= (if m < n then n else m) /\ m <= (if m < n then n else m) *)
 77 |   
 78 | (*
 79 |   move: leqP => H'.
 80 |   Check H' n m : leq_xor_gtn n m (n <= m) (m < n).
 81 |   case: (H' n m).         (* この n と m の選ばれかたは不明である。 *)
 82 |  *)
 83 |   Check (leqP n m) : leq_xor_gtn n m (n <= m) (m < n).
 84 |   case: (leqP n m).
 85 |   
 86 |   (* n <= m のとき。 (maxn m n) = m なので、 *)
 87 |   (* n <= m -> n <= m /\ m <= m *)
 88 |   - done.
 89 |     
 90 |   (* m < n のとき。 (maxn m n) = n なので、 *)
 91 |   (* m < n -> n <= n /\ m <= n *)
 92 |   - move=> H; split.
 93 |     (* n <= n *)
 94 |     + by apply: leqnn.
 95 |     (* m < n -> m <= n *)
 96 |     + by rewrite ltn_neqAle in H; case/andP: H.
 97 | Qed.
 98 | 
 99 | Check ltnP : forall m n : nat, ltn_xor_geq m n (n <= m) (m < n).
100 | Check posnP : forall n : nat, eqn0_xor_gt0 n (n == 0) (0 < n).
101 | 
102 | (* ssrnum.v にも類似の補題がある。 *)
103 | 
104 | (* END *)
105 | 


--------------------------------------------------------------------------------
/coq_fib.v:
--------------------------------------------------------------------------------
  1 | 
  2 | (*
  3 |    フィボナッチ数
  4 |    *)
  5 | 
  6 | 
  7 | (** 普通のフィボナッチ関数の定義 *)
  8 | Fixpoint fib (n: nat) : nat :=
  9 |   match n with
 10 |     | 0 => 1
 11 |     | 1 => 1
 12 |     | S (S m as sm) => fib sm + fib m
 13 |   end.
 14 | 
 15 | 
 16 | (** CPS変換されたフィボナッチ関数の定義 *)
 17 | Variable A : Type.
 18 | Fixpoint fib_cps (n : nat) (cont : nat -> A) : A :=
 19 |   match n with
 20 |     | 0 =>  cont 1
 21 |     | 1 =>  cont 1
 22 |     | S (S m as sm) =>
 23 |       fib_cps sm (fun r1 =>
 24 |         fib_cps m (fun r2 => cont (r1 + r2)))
 25 |   end.
 26 | 
 27 | 
 28 | 
 29 | (** 補助的な性質をいくつか。ほとんど自明だが。 *)
 30 | Lemma fib0: fib 0 = 1.
 31 |   reflexivity.
 32 | Qed.
 33 | 
 34 | 
 35 | Lemma fib1: fib 1 = 1.
 36 |   reflexivity.
 37 | Qed.
 38 | 
 39 | 
 40 | Lemma fib_SSn : forall n, fib (S (S n)) = fib (S n) + fib n.
 41 |   reflexivity.
 42 | Qed.
 43 | 
 44 | 
 45 | Lemma fib_cps0 : forall f, fib_cps 0 f = f 1.
 46 |   reflexivity.
 47 | Qed.
 48 | 
 49 | 
 50 | Lemma fib_cps1 : forall f, fib_cps 1 f = f 1.
 51 |   reflexivity.
 52 | Qed.
 53 | 
 54 | 
 55 | Lemma fib_cps_SSn : forall n f,
 56 |   fib_cps (S (S n)) f = fib_cps (S n) (fun r1 => fib_cps n (fun r2 => f (r1+r2))).
 57 |   reflexivity.
 58 | Qed.
 59 | 
 60 | 
 61 | (** 等価性の証明 *)
 62 | 
 63 | 
 64 | (* まず、あえて より強い性質を証明する *)
 65 | Theorem eq_fib_fib_cps_aux : forall n,
 66 |   (forall f, f (fib n) = fib_cps n f) /\ (forall g, g (fib (S n)) = fib_cps (S n) g).
 67 | Proof.
 68 |   induction n.
 69 |   (* 0 のとき *)
 70 |   split.
 71 |   intro.
 72 |   reflexivity.
 73 |   reflexivity.
 74 | 
 75 |   intro.
 76 |   rewrite fib1.
 77 |   rewrite fib_cps1.
 78 |   reflexivity.
 79 |   
 80 |   (* nでOKと仮定して(S n)を示す *)
 81 |   destruct IHn.                             (* 仮定に /\ があるときはdestruct *)
 82 |   split.
 83 |   intro f.
 84 |   apply H0.
 85 |   
 86 |   intro g.
 87 |   rewrite fib_cps_SSn.
 88 |   rewrite <- H0.
 89 |   rewrite <- H.
 90 |   rewrite fib_SSn.
 91 |   reflexivity.
 92 | Qed.
 93 | 
 94 | 
 95 | (* そしてこれがメインの定理 *)
 96 | 
 97 | 
 98 | 
 99 | (* END *)
100 | 
101 | Lemma fib_cps_SSn' : forall n f,
102 |   fib_cps (S (S n)) f = fib_cps (S n) (fun r1 => fib_cps n (fun r2 => f (r1+r2))).
103 |   reflexivity.
104 | Qed.
105 | 
106 | Theorem eq_fib_fib_cps_aux' : forall n, forall f,
107 |   f (fib n) = fib_cps n f.
108 | Proof.
109 |   (* 0 のとき *)
110 |   intro.
111 |   (* nでOKと仮定して(S n)を示す *)
112 |   intro f.
113 | 
114 |   rewrite <- H0.
115 |   rewrite <- H.
116 |   rewrite fib_SSn.
117 |   reflexivity.
118 | Qed.
119 | 
120 | Theorem eq_fib_fib_cps' : forall n f, f (fib n) = fib_cps n f.
121 | Proof.
122 |   intros.
123 |   induction n.
124 |   simpl.
125 |   reflexivity.
126 |   
127 |   rewrite <- fib_SSn.
128 | 
129 | 
130 |   
131 |   destruct (eq_fib_fib_cps_aux n);
132 |       apply H.
133 | Qed.
134 | 
135 | 
136 | 
137 | 
138 | 
139 | 
140 | 
141 | 
142 | 


--------------------------------------------------------------------------------
/ex2014/ex44_2.v:
--------------------------------------------------------------------------------
  1 | (**
  2 | # 第9回 タクティックの定義と利用/停止性証明 (2014/06/08)
  3 | 
  4 | http://qnighy.github.io/coqex2014/
  5 | 
  6 | ## 課題44 (種別:C / 締め切り : 2014/06/29)
  7 | 
  8 | 課題42で証明したlog関数に関する性質を証明せよ。
  9 | *)
 10 | 
 11 | Require Import ssreflect ssrbool ssrnat div eqtype.
 12 | Require Import Recdef.
 13 | 
 14 | (*
 15 | Require Import Arith.
 16 | Require Import Omega.
 17 | Require Import Recdef.
 18 | *)
 19 | 
 20 | Require Import Lt.
 21 | 
 22 | (*
 23 |  well_founded lt を示す定理が見つからない。
 24 |  これは、Coq'n art の一部
 25 |  *)
 26 | Theorem lt_Acc : forall n:nat, Acc lt n.
 27 | Proof.
 28 |  induction n.
 29 |  split; intros p H; inversion H.
 30 |  split. 
 31 |  intros y H0.
 32 |  case (le_lt_or_eq _ _ H0).
 33 |  intro; apply Acc_inv with n; auto with arith.
 34 |  intro e; injection e; intro e1; rewrite e1; assumption. 
 35 | Qed.
 36 | 
 37 | Function log (n:nat) {wf lt n} :=
 38 |   match n with
 39 |     | 0 => 0
 40 |     | 1 => 0
 41 |     | n => (log (n %/ 2)).+1
 42 |   end.
 43 | Proof.
 44 |   + move=> n2 n1 n Hn1 Hn2.
 45 |     rewrite -!Hn2.
 46 |     apply/leP.
 47 |     apply ltn_Pdiv.
 48 |       - by [].
 49 |       - by rewrite Hn2.
 50 |   + rewrite /well_founded.
 51 |     by apply lt_Acc.
 52 | Qed.
 53 | 
 54 | (* ここまでは課題42 *)
 55 | 
 56 | Fixpoint pow (n:nat) :=
 57 |   match n with
 58 |     | O => 1
 59 |     | n'.+1 => 2 * pow n'
 60 |   end.
 61 | 
 62 | Lemma pown1_2pown : forall n, pow n.+1 = 2 * pow n.
 63 | Proof.
 64 |   by [].
 65 | Qed.
 66 | 
 67 | Lemma mn2__2mn : forall n m, (m <= n %/ 2) = (2 * m <= n).
 68 | Proof.
 69 |   move=> n m.
 70 |   rewrite leq_divRL.
 71 |   + by rewrite -mulnC.
 72 |   + by [].
 73 | Qed.
 74 | 
 75 | Lemma mn2_2mn : forall n m, m <= n %/ 2 -> 2 * m <= n.
 76 | Proof.
 77 |   move=> n m H.
 78 |   have Hmn : forall n m, (m <= n %/ 2) = (2 * m <= n)
 79 |                          by apply mn2__2mn.
 80 |   case Hmn.
 81 |   by [].
 82 | Qed.
 83 | 
 84 | Lemma np2d2_nd2p1 : forall n, (n + 2) %/ 2 = (n %/ 2) + 1.
 85 | Proof.
 86 |   move=> n.
 87 |   rewrite divnDr.
 88 |   have H : 2 %/ 2 = 1 by rewrite //.
 89 |   + by rewrite H.                                 
 90 |   + by [].
 91 | Qed.
 92 | 
 93 | Lemma log_pow_lb: forall n, 1 <= n -> pow (log n) <= n.
 94 | Proof.
 95 |   move=> n H.
 96 |   functional induction (log n).
 97 |   + by [].                                  (* pow 0 <= 0 *)
 98 |   + by [].                                  (* pow 0 <= 1 *)
 99 |   + rewrite pown1_2pown.
100 |     apply mn2_2mn.
101 |     apply IHn0.
102 |     destruct n.
103 |     - inversion H.
104 |     - destruct n.
105 |       * inversion y.
106 |       * rewrite -addn2.
107 |         rewrite np2d2_nd2p1.
108 |         apply ltn_addl.
109 |         by [].
110 | Qed.
111 |   
112 | (**
113 | ヒント
114 | 
115 | functional inductionタクティックを使うと、Functionで定義した計算の構造に従う帰納法を行うことができます。
116 | *)
117 | 
118 | (* END *)
119 | 


--------------------------------------------------------------------------------
/ssr/ssr_mockbird_3.v:
--------------------------------------------------------------------------------
 1 | (* To Mock a Mocking Bird p.74 *)
 2 | 
 3 | From mathcomp Require Import all_ssreflect.
 4 | 
 5 | Inductive bird : Set :=
 6 | | app : bird -> bird -> bird.
 7 | 
 8 | (* ******* *)
 9 | 
10 | Theorem thm1_ssr :
11 |   (forall (A B : bird),
12 |     exists (C : bird), forall (x : bird), app A (app B x) = app C x) ->
13 |   (exists (M : bird), forall (x : bird), app M x = app x x) ->
14 |   (forall (P : bird),
15 |     exists (x : bird), app P x = x).
16 | Proof.
17 |   move=> Hc Hm P.
18 |   case: Hm => [M Hm'].       (* Hm' は ものまね鳥M についての命題。 *)
19 |   case: (Hc P M) => [PM Hc']. (* Hc' は P と M を合成した、鳥PMについての命題。 *)
20 |   exists (app M PM).          (* 鳥P は、鳥MPMが好き、とする。 *)
21 |   rewrite Hc'.                (* 左辺のP と Mから合成鳥PMを得る。 *)
22 |   rewrite Hm'.            (* 右辺のM PM からものまね鳥 M M を得る。 *)
23 |     by [].
24 | Qed.
25 | 
26 | (* ******* *)
27 | 
28 | Section Birds.
29 |   
30 |   Variable M : bird.              (* ものまね鳥 *)
31 |   Variable P : bird.              (* 誰かを好きな鳥、誰かを求めたい *)
32 |   
33 |   (* 鳥の合成の定義（合成の作り方） *)
34 |   Hypothesis compose : forall (A B x : bird), app A (app B x) = app (app A B) x. (* C1 *)
35 |   
36 |   (* ものまね鳥の定義 *)
37 |   Hypothesis mock : forall (x : bird), app M x = app x x. (* C2 *)
38 |   
39 |   Goal exists (x : bird), app P x = x.
40 |   Proof.
41 |     move: compose => Hc.
42 |     move: mock => Hm.
43 |     move: (Hc P M) => {Hc} Hc.
44 |     exists (app M (app P M)).
45 |     rewrite Hc.
46 |     rewrite Hm.
47 |       by [].
48 |   Qed.
49 | 
50 |   (* さらにまとめる。 *)
51 | 
52 |   Lemma thm1_ssr' : exists (x : bird), app P x = x.
53 |   Proof.
54 |     move: (compose P M) => Hc.
55 |     exists (app M (app P M)).               (* M (P M) *)
56 |       by rewrite Hc mock.
57 |   Qed.
58 |   
59 | (* M (P M) は、P の不動点 fixed point である、という。 *)
60 | 
61 | End Birds.
62 | 
63 | (* Section の外で同じ証明をする。 *)
64 | Lemma thm1_ssr''
65 |   : forall M P : bird,
66 |     (forall x : bird, app M x = app x x) ->
67 |     (forall A B x : bird, app A (app B x) = app (app A B) x) ->
68 |     exists x : bird, app P x = x.
69 | Proof.
70 |   move=> M P mock Hc.
71 |     exists (app M (app P M)).               (* M (P M) *)
72 |       by rewrite Hc mock.
73 | Qed.
74 | 
75 | (* ****** *)
76 | 
77 | Check thm1_ssr
78 |   : (forall A B : bird, exists C : bird, forall x : bird, app A (app B x) = app C x) ->
79 |     (exists M : bird, forall x : bird, app M x = app x x) ->
80 |     forall P : bird, exists x : bird, app P x = x.
81 | 
82 | Check thm1_ssr'
83 |   : forall M P : bird,
84 |     (forall x : bird, app M x = app x x) ->
85 |     (forall A B x : bird, app A (app B x) = app (app A B) x) ->
86 |     exists x : bird, app P x = x.
87 | 
88 | Check thm1_ssr''
89 |   : forall M P : bird,
90 |     (forall x : bird, app M x = app x x) ->
91 |     (forall A B x : bird, app A (app B x) = app (app A B) x) ->
92 |     exists x : bird, app P x = x.
93 | 
94 | (* END *)
95 | 


--------------------------------------------------------------------------------
/rt/coq_masc_maximum.v:
--------------------------------------------------------------------------------
  1 | (* 
  2 |    発表用のコード
  3 |    2013_01_16
  4 |    *)
  5 | Require Export SfLib_J.
  6 | 
  7 | Check list nat.
  8 | Print ble_nat.
  9 | 
 10 | (* 
 11 |    ループ不変式：
 12 |    m と 「lの最大」の大きいほうは、「listの最大」に等しい。
 13 |    
 14 |    この処理：
 15 |    m と mi(lの先頭)の大きい方と、li(lの残り)を引数に再帰的に自分を呼び出す。
 16 |    再帰呼び出しが終了するなら、処理はループ不変式に等しい。
 17 |    *)
 18 | Fixpoint maximum (m : nat) (l : list nat) : nat :=
 19 |   match l with
 20 |     | nil => m
 21 |     | cons mi li =>
 22 |       match ble_nat m mi with
 23 |         | true => maximum mi li
 24 |         | false => maximum m li
 25 |       end
 26 |   end.
 27 | Definition list := cons 1 (cons 3 (cons 2 (cons 1 nil))).
 28 | Eval compute in maximum 0 list.             (* 3 *)
 29 | Eval compute in maximum 0 (cons 1 (cons 3 (cons 2 (cons 1 nil)))). (* 3 *)
 30 | Eval compute in maximum 1         (cons 3 (cons 2 (cons 1 nil))).  (* 3 *)
 31 | Eval compute in maximum 3                 (cons 2 (cons 1 nil)).   (* 3 *)
 32 | Eval compute in maximum 3                         (cons 1 nil).    (* 3 *)
 33 | Eval compute in maximum 3                                 nil.     (* 3 *)
 34 | 
 35 | (* 実際は、型宣言は要らない。 *)
 36 | Fixpoint maximum''' m l :=
 37 |   match l with
 38 |     | nil => m
 39 |     | cons mi li =>
 40 |       match ble_nat m mi with
 41 |         | true => maximum mi li
 42 |         | false => maximum m li
 43 |       end
 44 |   end.
 45 | 
 46 | (* 
 47 |    ループ不変式：
 48 |    foldl f = F とする。
 49 |    f m (F l) は、F list に等しい。
 50 |  *)
 51 | Fixpoint foldl {X Y : Type} (f : Y -> X -> Y) m l :=
 52 |   match l with
 53 |     | nil => m
 54 |     | cons mi li => foldl f (f m mi) li
 55 |   end.
 56 | Print foldl.
 57 | 
 58 | Definition max x y :=
 59 |   match ble_nat x y with
 60 |     | true => y
 61 |     | false => x
 62 |   end.
 63 | (*
 64 |    ループ不変式： max m (maximum l) は、maximun list に等しい。
 65 |    *)
 66 | Definition maximum' := foldl max.
 67 | Eval compute in maximum' 0 list.
 68 | 
 69 | (* 
 70 |    ループ不変式： plus m (sum l) は、sum list に等しい。
 71 |    m と 「lの総和」の和は、「listの総和」に等しい。
 72 |    *)
 73 | Check plus.
 74 | Definition sum := foldl plus.
 75 | Eval compute in sum 0 list.
 76 | Eval compute in foldl minus 100 list.
 77 | 
 78 | Fixpoint foldr {X Y : Type} (f : X -> Y -> Y) m l : Y :=
 79 |   match l with
 80 |     | nil => m
 81 |     | cons mi li => f mi (foldr f m li)
 82 |   end.
 83 | Print foldr.
 84 | 
 85 | Eval compute in foldr plus 0 list.
 86 | 
 87 | (*
 88 |    pairコンストラクタで、見えるようにしてみる。
 89 |    *)
 90 | Inductive pair_left {X : Type} : Type :=
 91 | | nl : pair_left
 92 | | pl : pair_left -> X -> pair_left.
 93 | Eval compute in foldl pl nl list.
 94 | (* pr 1 (pr 3 (pr 2 (pr 1 nr))) *)
 95 | 
 96 | Inductive pair_right {X : Type} : Type :=
 97 | | nr : pair_right
 98 | | pr : X -> pair_right -> pair_right.
 99 | Eval compute in foldr pr nr list.
100 | (* pr 1 (pr 3 (pr 2 (pr 1 nr))) *)
101 | 
102 | (* END *)
103 | 


--------------------------------------------------------------------------------
/ssr/ssr_phant_lang.v:
--------------------------------------------------------------------------------
 1 | From elpi Require Import elpi.
 2 | From HB Require Import structures.
 3 | From mathcomp Require Import all_ssreflect.
 4 | 
 5 | Set Implicit Arguments.
 6 | Unset Strict Implicit.
 7 | Unset Printing Implicit Defensive.
 8 | 
 9 | (**
10 | keen さん 幽霊型を知った
11 | 
12 | https://keens.github.io/blog/2015/05/24/yuureikatawoshitta/
13 | *)
14 | 
15 | Inductive exp :=
16 | | Nat   of nat
17 | | Bool  of bool
18 | | If    of exp * exp * exp
19 | | Plus  of exp * exp
20 | | Equal of exp * exp.
21 | 
22 | 
23 | (*
24 | Inductive phantom {T : Type} := Phantom of exp.
25 | Inductive phantom {T : Type} :=
26 | | Phantom (a : exp) : phantom.
27 | *)
28 | (*
29 | Inductive texp {T : Type} := E of exp. *)
30 | Inductive texp {T : Type} :=
31 | | E (a : exp) : texp.
32 | 
33 | Definition mkNat (x : nat) : @texp nat := E (Nat x).     (* Nat x *)
34 | Definition mkBool (x : bool) : @texp bool := E (Bool x). (* Bool x *)
35 | Definition mkIf (A : Type) (Ecmd : @texp bool) (Ethn Eels : @texp A) : @texp A :=
36 |   match Ecmd, Ethn, Eels with
37 |   | E cmd, E thn, E els => E (If (cmd, thn, els))
38 |   end.
39 | Definition mkPlus (Ea Eb : @texp nat) : @texp nat :=
40 |   match Ea, Eb with
41 |   | E a, E b => E (Plus (a, b))
42 |   end.
43 | Definition mkEqual (T : Type) (Ea Eb : @texp T) : @texp bool :=
44 |   match Ea, Eb with
45 |   | E a, E b => E (Equal (a, b))
46 |   end.
47 | 
48 | Check mkNat 1 : texp.
49 | Check mkBool true : texp.
50 | Check mkIf (mkBool true) (mkNat 1) (mkNat 2) : texp.
51 | Check mkIf (mkBool true) (mkBool false) (mkBool true) : texp.
52 | Check mkPlus (mkNat 1) (mkNat 2) : texp.
53 | Check mkEqual (mkNat 1) (mkNat 2) : texp.
54 | Check mkEqual (mkBool true) (mkBool true) : texp.
55 | 
56 | Fail Check mkPlus (mkBool true) (mkNat 1).
57 | Fail Check mkPlus (mkBool true) (mkBool true).
58 | Fail Check mkIf (mkNat 1) (mkNat 1) (mkNat 2). (* 第1引数はboolであること。 *)
59 | Fail Check mkIf (mkBool true) (mkNat 1) (mkBool true). (* 第2と第3引数が同じ型であること。 *)
60 | 
61 | (* mkNat と mkBool でなく、コアーションを使う例 *)
62 | 
63 | Coercion E : exp >-> texp.
64 | Coercion Nat : nat >-> exp.
65 | Coercion Bool : bool >-> exp.
66 | 
67 | Definition a : @texp nat := 1.
68 | Definition b : @texp bool := true.
69 | Check mkPlus a a.
70 | Fail Check mkPlus a b.
71 | 
72 | 
73 | (* 単位を含める例 *)
74 | 
75 | Inductive Time := Hour | Min | Sec.
76 | Inductive tnat {T : Time} := F of nat.
77 | Definition tadd (T : Time) (x y : @tnat T) : @tnat T := (* x と y と返り値の T は同じ。 *)
78 |   match x, y with
79 |   | F x', F y' => F (x' + y')
80 |   end.
81 | Definition tadd2 (T : Time) (x y : @tnat T) : @tnat T := (* x と y と返り値の T は同じ。 *)
82 |   match x, y with
83 |   | @F _ x', @F _ y' => F (x' + y')         (* 型をマッチ節で受けられないらしい。 *)
84 |   end.
85 | 
86 | (* これ以降、F は意識しないでよい。 *)
87 | Coercion F : nat >-> tnat.
88 | 
89 | Definition a : @tnat Hour := 2.
90 | Definition b : @tnat Sec  := 3.
91 | 
92 | Check tadd a a.
93 | Fail Check tadd a b.
94 | 
95 | (* END *)
96 | 


--------------------------------------------------------------------------------
/coq_generalize_dependent.v:
--------------------------------------------------------------------------------
  1 | (*
  2 |    generalize dependent m.
  3 |    または、intro で「forall m」を残した状態で、
  4 |    induction n をする例
  5 | *)
  6 | 
  7 | 
  8 | Require Import Omega.
  9 | Require Import NArith.
 10 | Require Import Arith.
 11 | 
 12 | 
 13 | Fixpoint sum n :=
 14 |   match n with
 15 |     | O => O
 16 |     | S n' => S n' + sum n'
 17 |   end.
 18 | 
 19 | 
 20 | Theorem Sum_of_nat : forall (n m: nat),
 21 |   m = 2 * sum n -> m = n * (n + 1).
 22 | Proof.
 23 |   intros n m.
 24 |   induction n.
 25 |   simpl.
 26 |   auto.
 27 |   (*
 28 |      IHn : m = 2 * sum n -> m = n * (n + 1)
 29 |      ============================
 30 |      m = 2 * sum (S n) -> m = S n * (S n + 1)
 31 |    *)
 32 | Abort.
 33 | 
 34 | 
 35 | Theorem Sum_of_nat : forall (n m: nat),
 36 |   m = 2 * sum n -> m = n * (n + 1).
 37 | Proof.
 38 |   intro n.
 39 |   induction n.
 40 |   simpl.
 41 |   auto.
 42 |   
 43 | (*
 44 |    n : nat
 45 |    IHn : forall m : nat, m = 2 * sum n -> m = n * (n + 1)
 46 |    ============================
 47 |    forall m : nat, m = 2 * sum (S n) -> m = S n * (S n + 1)
 48 | *)
 49 |   intros.
 50 |   
 51 |   (* 代数的な式の変形をする *)
 52 |   subst.
 53 |   unfold sum.
 54 |   fold sum.
 55 |   ring_simplify.
 56 |   cut (forall m n, m = n -> m + 2 = n + 2).
 57 |   intros.
 58 |   apply (H (2 * n + 2 * sum n) (n * n + 3 * n)).
 59 |   cut (forall x y n, x = y + n -> 2 * n + x = y + 3 * n).
 60 |   intros.
 61 |   apply (H0 (2 * sum n) (n * n)).
 62 |   cut (forall m n, m = n * (n + 1) -> m = n * n + n).
 63 |   intros.
 64 |   apply H1.
 65 |   
 66 |   apply IHn.                                (* ここで、上記の前提をつかう！ *)
 67 |   reflexivity.                              (* 証明終了！ *)
 68 |   
 69 |   (* cutで導入した前提を片付ける *)
 70 |   intros.
 71 |   rewrite H1.
 72 |   ring.
 73 |   intros.
 74 |   rewrite H0.
 75 |   ring.
 76 |   intros.
 77 |   rewrite H.
 78 |   reflexivity.
 79 | Qed.
 80 | 
 81 | 
 82 | Theorem Sum_of_nat' : forall (m n : nat),
 83 |   m = 2 * sum n -> m = n * (n + 1).
 84 | Proof.
 85 |   intros m n.
 86 |   generalize dependent m.
 87 |   induction n.
 88 |   simpl.
 89 |   auto.
 90 | 
 91 | 
 92 | (*
 93 |    n : nat
 94 |    IHn : forall m : nat, m = 2 * sum n -> m = n * (n + 1)
 95 |    ============================
 96 |    forall m : nat, m = 2 * sum (S n) -> m = S n * (S n + 1)
 97 |    
 98 |    Sum_of_nat と同じようにする。
 99 | *)
100 | Abort.
101 | 
102 | 
103 | 
104 | 
105 | (* 1変数の場合 *)
106 | 
107 | 
108 | Lemma Sample_of_unfold : forall n, 2 * sum n = n * (n + 1).
109 | Proof.
110 |   induction n.
111 |   reflexivity.
112 |   (*
113 |      ここで、sum を unfold して、fold すると式が少し変形されます。
114 |      *)
115 |   unfold sum.
116 |   fold sum.
117 |   (*
118 |      ここでreplaceを使ってちょっと左辺を書き換えます。書き換えて良い証明はsubgoal 2と後回しです。
119 |      *)
120 |   replace (2 * (S n + sum n)) with (2 * S n + 2 * sum n).
121 |   (*
122 |      ここでIHnを用いて書き換えて式変形を ring で自動証明します。後回しにしたものもringで一発です。
123 |      *)
124 |   rewrite IHn.
125 |   ring.
126 |   ring.
127 | Qed.
128 | 
129 | 
130 | (* END *)
131 | 


--------------------------------------------------------------------------------
/coq_set_func.v:
--------------------------------------------------------------------------------
  1 | (* 集合型関数 と タクティクによる関数定義 *)
  2 | (* 2011_01_22 *)
  3 | 
  4 | 
  5 | (*
  6 |    述語判定関数は、集合型関数の特別な形。
  7 |    Nat の <や<= は、sumbool型の述語判定関数である。
  8 |    coq_sumbool.v
  9 |    *)
 10 | (*
 11 |    DefinitionやLemmaなど、定義の開始は何を使っても同じである。
 12 |    違いが出るのは閉じるところだけである。
 13 | 
 14 | 
 15 |    DefinedとQedは、どちらも証明を閉じ、
 16 |    作成されたGallina項を変数に束縛するものである（変数定義）。
 17 |    但し以下のような違いがある。
 18 | 
 19 | 
 20 |    ・Defined：変数定義は透過的(Transparent)である。
 21 |    即ち、変数に関連付けた項を参照するおとはできる。したがって、計算することができる。
 22 | 
 23 | 
 24 |    ・Qed：変数定義は非透過的(Opaque)である。変数に関連付けた項は参照できない。
 25 |    （従って計算することはできない。）変数の型のみを参照できる。
 26 |    *)
 27 | 
 28 | 
 29 | Require Import List.
 30 | Inductive app : forall T, list T -> list T -> list T -> Prop :=
 31 | | app_nil : forall T xs, app T nil xs xs
 32 | | app_one : forall T a xs ys zs, app T xs ys zs -> app T (a :: xs) ys (a :: zs).
 33 | 
 34 | 
 35 | (**************)
 36 | (* 集合型関数 *)
 37 | (**************)
 38 | Definition                                  (* Lamma でもよい *)
 39 |   safe_append (T : Type) (xs ys : list T) :
 40 |   {zs : list T | app T xs ys zs}.
 41 | Proof.
 42 |   intros.
 43 |   induction xs.
 44 |   exists ys.
 45 |   apply app_nil.
 46 | 
 47 | 
 48 |   case IHxs.
 49 |   intros zs H.
 50 |   exists (a :: zs).
 51 |   apply app_one.
 52 |   apply H.
 53 | Defined.                                    (* Qed で閉じると計算されない *)
 54 | 
 55 | 
 56 | Definition append (T : Type) (a b : list T) := proj1_sig (safe_append T a b).
 57 | Eval cbv in append nat (1::2::3::nil) (4::5::6::nil).
 58 | (*
 59 |    safe_append自体をEvalても、引数が展開されるだけで、計算（簡約）されない。
 60 |    Qedで閉じると、safe_append が見えてしまい、やはり計算されない。
 61 | *)
 62 | (* coq_safety_prog.v も参照のこと。*)
 63 | 
 64 | 
 65 | (****************************)
 66 | (* タクティクによる関数定義 *)
 67 | (****************************)
 68 | Definition                                  (* Lamma でもよい *)
 69 |   append2 (T : Type) (xs ys : list T) : list T.
 70 | Proof.
 71 |   intros.
 72 |   induction xs.
 73 |   apply ys.
 74 |   apply cons.
 75 |   apply a.
 76 |   apply IHxs.
 77 | Defined.                                    (* Definedで閉じること *)
 78 | Eval cbv in append2 nat (1::2::3::nil) (4::5::6::nil).
 79 | Print append2.
 80 | 
 81 | 
 82 | (* 上と同じ定義を refine で書いた *)
 83 | 
 84 | 
 85 | Definition                                  (* Lamma でもよい *)
 86 |   append3 (T : Type) (xs ys : list T) : list T.
 87 | Proof.
 88 |   refine
 89 |     (fun (T : Type) (xs ys : list T) =>
 90 |       list_rect (fun _ : list T => list T) ys
 91 |       (fun (a : T) (_ IHxs : list T) => a :: IHxs) xs).
 92 | Defined.                                    (* Definedで閉じること *)
 93 | Eval cbv in append3 nat (1::2::3::nil) (4::5::6::nil).
 94 | 
 95 | 
 96 | (******************)
 97 | (* 通常の関数定義 *)
 98 | (******************)
 99 | Fixpoint append4 (T : Type) (xs ys: list T) : list T :=
100 |   match xs with
101 |     | nil => ys
102 |     | x :: xs => x :: (append4 T xs ys)
103 |   end.
104 | Eval cbv in append4 nat (1::2::3::nil) (4::5::6::nil).
105 | 
106 | 
107 | (* END *)


--------------------------------------------------------------------------------
/coq_classical.v:
--------------------------------------------------------------------------------
  1 | (*
  2 |    Anarchy Proof
  3 |    
  4 |    Peirce
  5 |    http://as305.dyndns.org/aps/problem/view/3
  6 | 
  7 | 
  8 |    Converse Peirce
  9 |    http://as305.dyndns.org/aps/problem/view/4
 10 | 
 11 | 
 12 |    call/cc
 13 |    http://as305.dyndns.org/aps/problem/view/5
 14 | *)
 15 | 
 16 | 
 17 | Require Import Classical.                   (* 古典論理パッケージ *)
 18 | 
 19 | 
 20 | (****************)
 21 | (* Prove 'Peirce's law'. *)
 22 | (* 「パースの論理式」を証明する。*)
 23 | (* 古典論理では証明できるが、直観論理では証明できない。*)
 24 | (* 「パースの論理式」を排中律で証明する。*)
 25 | (****************)
 26 | 
 27 | 
 28 | Theorem Peirce : forall (P Q: Prop), ((P -> Q) -> P) -> P.
 29 | Proof.
 30 |   intros p q H.
 31 |   Check classic.                            (* 排中律の公理 *)
 32 |   (* Logic/Classical_Prop.v で定義されている。*)
 33 |   elim (classic p).
 34 |   intros P.
 35 |   assumption.
 36 | 
 37 | 
 38 |   intros H0.
 39 |   apply H0 in H.
 40 |   elim H.
 41 |   intros H1.
 42 |   (* H0 : ~P と H1 : P から Falseを求める *)
 43 |   apply H0 in H1.
 44 |   case H1.                                  (* 前提がFalseで証明は終了。 *)
 45 | Qed.
 46 | 
 47 | 
 48 | (* 「パースの論理式」を二重否定除去で証明する。*)
 49 | 
 50 | 
 51 | Theorem Peirce' : forall (P Q: Prop), ((P -> Q) -> P) -> P.
 52 | Proof.
 53 |   intros p q H.
 54 |   Check NNPP.                               (* 二重否定の除去 *)
 55 |   apply NNPP.
 56 |   intros nHp.
 57 |   apply nHp in H.
 58 |   apply H.
 59 |   intros Hp.
 60 |   case (nHp Hp).
 61 | Qed.
 62 | 
 63 | 
 64 | (* Verifier *)
 65 | Definition check_Peirce: forall (P Q: Prop), ((P -> Q) -> P) -> P := Peirce.
 66 |   
 67 | (* Classical パッケージを使用しない。*)
 68 | 
 69 | 
 70 | (****************)
 71 | (* パースの論理式を使って、排中律を証明する。*)
 72 | (****************)
 73 | 
 74 | 
 75 | (* 古典論理で(Classicalパッケージを使う)、パースの論理式の証明は、
 76 |    coq_classical.v を参照せよ。*)
 77 | (* Axiom Peirce : forall (P Q: Prop), ((P -> Q) -> P) -> P. *)
 78 | 
 79 | 
 80 | Theorem Excluded_Middle : forall (P: Prop), P \/ ~P.
 81 | Proof.
 82 |   intros p.
 83 |   Check (Peirce p False).
 84 |   apply (Peirce _ False).                   (* apply Peirce with False. *)
 85 |   intros H.
 86 |   right.
 87 |   intros Hp.                                (* ~ p に対して、さらにintrosする！ *)
 88 |   apply H.
 89 |   left.
 90 |   apply Hp.
 91 | Qed.
 92 | 
 93 | 
 94 | (* Verifier *)
 95 | Definition check_Excluded_Middle : forall (P: Prop), P \/ ~P := Excluded_Middle.
 96 | 
 97 | 
 98 | (****************)
 99 | (* Prove 'call/cc implies excluded middle'. *)
100 | (* call/cc を使って、排中律 (law of the excluded middle) を証明する。*)
101 | (****************)
102 | 
103 | 
104 | Axiom callcc: forall (P: Prop), ((P -> False) -> P) -> P.
105 | 
106 | 
107 | Theorem Excluded_Middle' : forall (P: Prop), P \/ ~P.
108 | Proof.
109 |   intros p.
110 |   apply callcc.                             (* パースの論理式の特別な形。 *)
111 |   (* パースの論理式による証明と同じだが、
112 |      auto で済ますこともできる。*)
113 |   auto.
114 | Qed.
115 | 
116 | 
117 | (* Verifier *)
118 | Definition check_Excluded_Middle' : forall (P: Prop), P \/ ~P := Excluded_Middle'.
119 | 
120 | 
121 | (* END *)


--------------------------------------------------------------------------------
/jsst2014/ssr_jsst2014_eqtype_example.v:
--------------------------------------------------------------------------------
  1 | (**
  2 | 日本ソフトウェア科学会
  3 | チュートリアル(1) 定理証明支援系Coq入門
  4 | 
  5 | 講師：アフェルト レナルド 先生
  6 | https://staff.aist.go.jp/reynald.affeldt/ssrcoq/coq-jssst2014.pdf
  7 |  *)
  8 | 
  9 | (**
 10 | 首記の講演から興味のもとに抜粋し、例題を追加したものです。
 11 | 内容の責任は  @suharahiromichi にあります。
 12 |  *)
 13 | 
 14 | (**
 15 | eqtype.v: 決定可能な同値関係
 16 |  *)
 17 | Require Import ssreflect ssrfun ssrbool.
 18 | 
 19 | (** nat を定義する。 *)
 20 | Inductive nat : Set :=
 21 | | O
 22 | | S of nat.
 23 | 
 24 | (** 同値関係が決定可能なら, ブール値等式として定義ができる *)
 25 | Fixpoint eqn (m  n : nat) {struct m} : bool :=
 26 |   match m, n with
 27 |     | O, O => true
 28 |     | S m', S n' => eqn m' n'
 29 |     | _, _ => false
 30 |   end.
 31 | 
 32 | (*************************
 33 | eqType を使わない場合（普通はこれをしない）
 34 | eqtype_sample.v
 35 |  *)
 36 | Record myeq := Eqtype {
 37 |   car : Set ; 
 38 |   myequality : car -> car -> bool ;
 39 |   Heq : forall x y : car, myequality x y = true -> x = y }.
 40 | Notation "a '===' b" := (myequality _ a b) (at level 70).
 41 | 
 42 | Lemma myeqnP n m : eqn n m = true -> n = m.
 43 | Proof.
 44 |     by elim: n m => [|n IHn] [|m] //= /IHn ->.
 45 | Qed.
 46 | 
 47 | Check S O = S O.
 48 | Fail Compute S O === S O.                   (* まだ===は使えない。 *)
 49 | Canonical Structure eqtypenat := Eqtype _ _ myeqnP.
 50 | Compute S O === S O.                        (* true *)
 51 | 
 52 | Check (O : car _).
 53 | Check Heq.
 54 | 
 55 | (** 証明 *)
 56 | Goal forall n m : nat, n === m -> n = m.
 57 | Proof.
 58 |   move=> n m.
 59 |   move/myeqnP.
 60 |   Undo 1.
 61 |   move/Heq.
 62 |   by [].
 63 | Qed.
 64 | 
 65 | (*************************
 66 | eqType を使う場合
 67 |  *)
 68 | Require Import eqtype. (* eqtypeまで *)
 69 | 
 70 | (** そのブール値等式と Leibniz 同値関係の等価性が証明をする。 *)
 71 | (* ここでは、<-> ではなく reflect を使う。 *)
 72 | Lemma eqnP : Equality.axiom eqn.            (*  reflect (x = y) (eqn x y) *)
 73 | Proof.
 74 |   move=> n m; apply: (iffP idP) => [|<-]; last by elim n.
 75 |     by elim: n m => [|n IHn] [|m] //= /IHn ->.
 76 | Qed.
 77 | 
 78 | (** その型はeqType として登録できる。 *)
 79 | Check S O = S O.
 80 | Fail Check S O == S O.
 81 | Fail Check S O != S O.
 82 | Canonical nat_eqMixin := EqMixin eqnP.
 83 | Canonical nat_eqType := Eval hnf in EqType nat nat_eqMixin.
 84 | Compute S O == S O.
 85 | Compute S O != S O.
 86 | 
 87 | (** 証明 *)
 88 | Goal forall n m : nat, n == m <-> n = m.
 89 | Proof.
 90 |   move=> n m.
 91 |   by split; move/eqnP.
 92 | Qed.
 93 | 
 94 | (** リフレクションと書き換えができる。  *)
 95 | Goal forall n m l : nat, n == m -> m == l -> n == l.
 96 | Proof.
 97 |   move=> n m l Hnm Hml.
 98 |   apply/eqP.                                (* n = l *)
 99 |   Undo 1.
100 |   rewrite (eqP Hnm).                        (* m == l *)
101 |   by [].
102 | Qed.
103 | 
104 | (** ssrnat のおまけ *)
105 | Lemma eqnE : eqn = eq_op. Proof. by []. Qed.
106 | Lemma eqSS m n : (S m == S n) = (m == n). Proof. by []. Qed.
107 | Lemma nat_irrelevance (x y : nat) (E E' : x = y) : E = E'.
108 | Proof. exact: eq_irrelevance. Qed.
109 | 
110 | (* END *)
111 | 


--------------------------------------------------------------------------------
/prog/coq_merger.v:
--------------------------------------------------------------------------------
  1 | Require Import List.
  2 | Require Import Omega.
  3 | Require Import Sorting.Permutation.
  4 | Require Import Sorting.Sorted.
  5 | Require Import Program.Wf.
  6 | Require Import Arith.Bool_nat.
  7 | 
  8 | (* http://ccvanishing.hateblo.jp/entry/2012/12/30/205251 *)
  9 | Section Marger.
 10 |   Variable A : Type.
 11 |   Variable f : A -> bool.
 12 | 
 13 |   Inductive merger : list A -> list A -> list A -> Prop :=
 14 |   | Merger_nil_l  : forall l : list A,
 15 |       merger l nil l
 16 |   | Merger_nil_r  : forall l : list A,
 17 |       merger l l nil
 18 |   | Merger_cons_l : forall (x : A) (l l1 l2 : list A),
 19 |       merger l l1 l2 -> merger (x :: l) (x :: l1) l2
 20 |   | Merger_cons_r : forall (x : A) (l l1 l2 : list A),
 21 |       merger l l1 l2 -> merger (x :: l) l1 (x :: l2).
 22 | 
 23 |   Hint Constructors merger.
 24 |   
 25 |   Lemma merger_cons_l_inv x l l1 l2 :
 26 |     merger (x :: l) (x :: l1) l2 -> merger l l1 l2.
 27 |   Proof.
 28 |     intro H.
 29 |     inversion H; subst.
 30 |     - now auto.
 31 |     - now auto.
 32 |     - inversion H.
 33 |     inversion H; subst; simpl in *; try auto.
 34 |     - auto.
 35 |   Admitted.
 36 |   
 37 |   Lemma merger_cons_r_inv x l l1 l2 :
 38 |     merger (x :: l) l1 (x :: l2) -> merger l l1 l2.
 39 |   Proof.
 40 |   Admitted.
 41 | 
 42 |   Lemma Forall_inv' (P : A -> Prop) (x : A) (l : list A) :
 43 |     Forall P (x :: l) -> Forall P l.
 44 |   Proof.
 45 |     intro H.
 46 |     now inversion H.
 47 |   Qed.
 48 |   
 49 |   Hint Resolve merger_cons_l_inv merger_cons_r_inv.
 50 |   
 51 |   Program Fixpoint filter (l : list A) :
 52 |     {l' | forall lf,
 53 |         merger l l' lf ->
 54 |         Forall (fun x => f x = true) l' ->
 55 |         Forall (fun x => f x = false) lf} :=
 56 |     match l with
 57 |     | nil => nil
 58 |     | x :: l => if f x then x :: (filter l) else filter l
 59 |     end.
 60 |   Obligations.
 61 |   Obligation 1.
 62 |   Proof.
 63 |     inversion H; subst; simpl in *.
 64 |     - now auto.
 65 |     - now auto.
 66 |   Defined.
 67 |   Obligation 2.
 68 |   Proof.
 69 |     apply f0.
 70 |     - eapply merger_cons_l_inv.
 71 |       now eauto.
 72 |     - now apply Forall_inv' with (x := x).
 73 |   Defined.
 74 |   Obligation 3.
 75 |   Proof.
 76 |     apply f0 with (lf := lf).
 77 |     - admit.
 78 |     - now auto.
 79 | 
 80 |     Restart.
 81 |     Check (f0 (x :: lf)).
 82 |     apply Forall_inv' with (x := x).
 83 |     apply f0 with (lf := x :: lf).
 84 |     - admit.
 85 |     - now auto.
 86 |   Defined.
 87 | 
 88 | End Marger.
 89 | 
 90 | (* Arith.Bool_nat で定義されている。 *)
 91 | Check nat_eq_bool : forall x y : nat, {b : bool | if b then x = y else x <> y}.
 92 | Check nat_noteq_bool : forall x y : nat, {b : bool | if b then x <> y else x = y}.
 93 | 
 94 | Compute proj1_sig (filter nat
 95 |                           (fun x => (proj1_sig (nat_noteq_bool x 2)))
 96 |                           (1 :: 2 :: 3 :: nil)).
 97 |   
 98 | Extraction filter.
 99 | 
100 | (* END *)
101 | 


--------------------------------------------------------------------------------
/coq__rec.v:
--------------------------------------------------------------------------------
  1 | (* _rec を使った関数定義 *)
  2 | (* お茶大 浅井研、Coqゼミ 第5回 を参考にした。 *)
  3 | 
  4 | 
  5 | (* one *)
  6 | 
  7 | 
  8 | Inductive one : Set :=
  9 |   | One : one.                              (* : one は省略できる。 *)
 10 | 
 11 | 
 12 | Print one.
 13 | Check one.
 14 | Check One.
 15 | Print one_ind.
 16 | Check one_ind.
 17 | Print one_rec.
 18 | Check one_rec.
 19 | 
 20 | 
 21 | Definition f_one :=
 22 |   one_rec (fun n : one => nat) 1.
 23 | Check f_one.
 24 | Eval compute in f_one One.                  (* 1 *)
 25 | 
 26 | 
 27 | Definition f_one' (m : nat) :=
 28 |   one_rec (fun n : one => nat) m.
 29 | Check f_one'.
 30 | Eval compute in f_one'.
 31 | Eval compute in f_one' 11 One.              (* 11 *)
 32 | 
 33 | 
 34 | Definition f_one'' (m : nat) :=
 35 |   one_rec (fun f : one => nat -> nat)
 36 |     (fun n : nat => m + 1).
 37 | Check f_one''.
 38 | Eval compute in f_one''.
 39 | Eval compute in f_one'' 111 One.            (* 112 *)
 40 | 
 41 | 
 42 | (* season *)
 43 | 
 44 | 
 45 | Inductive season : Set :=
 46 |   | Spring : season
 47 |   | Summer : season
 48 |   | Fall : season
 49 |   | Winter : season.
 50 | 
 51 | 
 52 | Print season_ind.
 53 | Check season_ind.
 54 | Print season_rec.
 55 | Check season_rec.
 56 | 
 57 | 
 58 | Definition f :=
 59 |   season_rec (fun s : season => nat)
 60 |     0 1 2 3.
 61 | 
 62 | 
 63 | Eval compute in f Spring.                   (* 0 *)
 64 | Eval compute in f Summer.                   (* 1 *)
 65 | Eval compute in f Fall.                     (* 2 *)
 66 | Eval compute in f Winter.                   (* 3 *)
 67 | 
 68 | 
 69 | 
 70 | 
 71 | (* nat *)
 72 | 
 73 | 
 74 | Print nat_ind.
 75 | Check nat_ind.
 76 | Print nat_rec.
 77 | Check nat_rec.
 78 | 
 79 | 
 80 | Definition plus (m : nat) :=
 81 |   nat_rec (fun n : nat => nat)
 82 |    m
 83 |    (fun (n : nat) (x : nat) => S x).
 84 | 
 85 | 
 86 | Eval compute in plus 1 2.                   (* 3 *)
 87 |   
 88 |   
 89 | Lemma plus_n_0 : forall n : nat, n = n + 0.
 90 |   intros.
 91 |   induction n.
 92 |   simpl.
 93 |   reflexivity.
 94 |   simpl.
 95 |   rewrite <- IHn.
 96 |   reflexivity.
 97 |   Restart.
 98 | 
 99 | 
100 |   intros.
101 |   apply nat_ind with (n := n).
102 |   simpl.
103 |   reflexivity.
104 |   intros.                                   (* *** *)
105 |   simpl.
106 |   rewrite <- H.
107 |   reflexivity.
108 | Qed.
109 | 
110 | 
111 | 
112 | 
113 | (** おまけ **)
114 | 
115 | 
116 | Definition pred_spec (n : nat) :=
117 |   {m : nat | n = 0 /\ m = 0 \/ n = S m}.
118 | 
119 | 
120 | Definition predecessor : forall n : nat, pred_spec n.
121 |   intros n.
122 |   apply nat_rec with (n := n).              (* case n *)
123 |   (* ！！しかし、nat_ind ではだめであることに、注意！！ *)
124 |   
125 |   (* Goal : pred_spec 0 *)
126 |   unfold pred_spec.
127 |   exists 0.
128 |   auto.
129 | 
130 | 
131 |   (* Goal : forall n0 : nat, pred_spec n0 -> pred_spec (S n0) *)
132 |   intros.
133 |   unfold pred_spec.
134 |   exists n0.
135 |   auto.
136 | Qed.
137 | 
138 | 
139 | Print predecessor.
140 | 
141 | 
142 | (* END *)


--------------------------------------------------------------------------------
/prog/coq_m91function.v:
--------------------------------------------------------------------------------
 1 | (* マッカーシーの91関数 *)
 2 | (* McCarthy 91 function *)
 3 | 
 4 | Require Import ZArith.
 5 | Require Import Omega.
 6 | Open Scope Z_scope.
 7 | 
 8 | (* Program Command を使って、停止性を含めて証明しようとすると、とても大変である。 *)
 9 | 
10 | Require Import Program.
11 | Program Fixpoint M91 (x : Z) {measure (Z.to_nat (Zmax 0 (101 - x)))} :
12 |   {n | n = if Z_le_dec x 100 then 91 else x - 10} :=     (* n = g x *)
13 |   if Z_le_dec x 100 then M91 (M91 (x + 11)) else x - 10. (* Fix F *)
14 | Admit Obligations.
15 | 
16 | (*
17 |  しかし、不動点帰納法の1ステップ分の
18 | F g x = g x.
19 | を証明するのは易しい。
20 |  *)
21 | 
22 | (* 91関数の意味 *)
23 | Definition g (x : Z) :=
24 |   if Z_le_dec x 100 then 91 else x - 10.
25 | 
26 | Compute g (-1%Z).                           (* 91 *)
27 | Compute g 10.                               (* 91 *)
28 | Compute g 100.                              (* 91 *)
29 | Compute g 101.                              (* 91 *)
30 | Compute g 102.                              (* 92 *)
31 | Compute g 103.                              (* 93 *)
32 | 
33 | (* F : (Z -> Z) -> Z -> (Z -> Z) の最小不動点が、91関数になる。 *)
34 | Definition F (f : Z -> Z) (x : Z) :=
35 |   if Z_le_dec x 100 then f (f (x + 11)) else x - 10.
36 | 
37 | Compute F g (-1%Z).                         (* 91 *)
38 | Compute F g 10.                             (* 91 *)
39 | Compute F g 100.                            (* 91 *)
40 | Compute F g 101.                            (* 91 *)
41 | Compute F g 102.                            (* 92 *)
42 | Compute F g 103.                            (* 93 *)
43 | 
44 | Goal forall (x : Z), F g x = g x.
45 | Proof.
46 |   intro x.
47 |   unfold F.
48 |   unfold g.
49 |   destruct (Z_le_dec x 100).
50 |   - destruct (Z_le_dec (x + 11) 100); simpl.
51 |     + reflexivity.                          (* 91 = 91 *)
52 |     + destruct (Z_le_dec (x + 11 - 10) 100).
53 |       * reflexivity.                        (* 91 = 91 *)
54 |       * omega.                              (* 前提の矛盾 *)
55 |   - reflexivity.                            (* x - 10 = x - 10 *)
56 | Qed.
57 | 
58 | (* END *)
59 | 
60 | (*
61 | Goal forall (x : Z), F g x = g x.
62 | Proof.
63 |   intro x.
64 |   unfold F.
65 |   destruct (Z_le_dec x 100).
66 |   - unfold g at 2.
67 |     destruct (Z_le_dec (x + 11) 100).
68 |     + unfold g; simpl.
69 |       destruct (Z_le_dec x 100).
70 |       * reflexivity.
71 |       * exfalso.
72 |         now apply n.
73 |     + unfold g; simpl.
74 |       destruct (Z_le_dec (x + 11) 100).
75 |       * now exfalso.
76 |       * destruct (Z_le_dec (x + 11 - 10) 100).
77 |         ** destruct (Z_le_dec x 100).
78 |            *** reflexivity.
79 |            *** now exfalso.
80 |         ** destruct (Z_le_dec x 100).
81 |            *** cut (x = 100).
82 |                intro H.
83 |                rewrite H. simpl.
84 |                reflexivity.
85 |            **** omega.
86 |            *** now exfalso.
87 |   - unfold g; simpl.
88 |     destruct (Z_le_dec x 100).
89 |     + exfalso.
90 |       now apply n.
91 |     + reflexivity.
92 | Qed.
93 | 
94 |  *)
95 | 


--------------------------------------------------------------------------------