(** * Hoare_J: ホーア論理 *)
(* * Hoare: Hoare Logic *)

Require Export ImpList_J.

(** ** 表明 *)
Definition Assertion := state -> Prop.

(** ** ホーアの三つ組 *)
Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c" :=          (hoare_triple P c (fun st => True)) (at level 90)
                                  : hoare_spec_scope.
Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q) (at level 90, c at next level)
                                  : hoare_spec_scope.
Open Scope hoare_spec_scope.

Definition assn_sub V a Q : Assertion :=
  fun (st : state) =>
    Q (update st V (aeval st a)).

(* ####################################################### *)
(** *** 代入 *)
Theorem hoare_asgn : forall Q V a,
  {{assn_sub V a Q}} (V ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q V a st st' HE HQ.
(*
   補足説明：
   [V::=a] を実行すると、
   V=aを加えるとQの成立する(もとの)状態(st)から、
   (V=aを加えなくても)Qの成立する状態(st')に、移行する。

  HQ : assn_sub V a Q st
  HE : (V ::= a) / st || st'
  ============================
   Q st'
*)
  inversion HE. subst.
(*
   補足説明：
   [V::=a] を実行すると、
   stから、
   stにV=aを加えた状態[update st V (aeval st a)]に、移行する。
   (この書き方のほうが解りやすいが、その分、表している意味が少ない、のか）

  HQ : assn_sub V a Q st
  HE : (V ::= a) / st || update st V (aeval st a)
  ============================
   Q (update st V (aeval st a))
*)
  unfold assn_sub in HQ. assumption.
Qed.

(* Here's a first formal proof using this rule. *)
(** この規則を使った最初の形式的証明が次のものです。*)

Theorem hoare_asgn_eq : forall Q Q' V a,
     Q' = assn_sub V a Q ->
     {{Q'}} (V ::= a) {{Q}}.
Proof.
  intros Q Q' V a H.
  rewrite H.
(*
   補足説明
   V=aを加えるとQの成立する(もとの)状態(st)では、Q'が成立する。
   (V=aを加えなくても)Qの成立する状態(st')では、Qが成立する。あたりまえ。
   [V::=a] を実行すると、st' から st に移行する。

   感覚的にいうと、
   Q' st で、Q st' のとき、stはst'からV=aを取り去ったもの。
   このQ'とQの関係を以下で示す。
   Q' = assn_sub V a Q
   取り去るというより、不問にする、というべきだろうか。
   より重要なのは、取り去られているのはV=aという、Vとaeval(a)の関係であって、
   aeval(a)を実行するための状態は、取り去られていないことである、だろうか。

   H : Q' = assn_sub V a Q
   ============================
   {{assn_sub V a Q}} V ::= a {{Q}}
*)
  apply hoare_asgn.
Qed.

(* 事前条件を強め、事後条件を弱める。 *)
Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  (forall st, P st -> P' st) ->
  (forall st, Q' st -> Q st) ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  intros st st' Hc HP.
  apply HQ'Q.  apply (Hht st st'). assumption.
  apply HPP'. assumption.  Qed.

(* 事前条件を強める。 *)
Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  (forall st, P st -> P' st) ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  apply hoare_consequence with (P' := P') (Q' := Q);
    try assumption.
  intros st H. apply H.  Qed.

(* 事後条件を弱める。 *)
Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  (forall st, Q' st -> Q st) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  apply hoare_consequence with (P' := P) (Q' := Q');
    try assumption.
  intros st H. apply H.  Qed.

(* ####################################################### *)
(** *** Skip *)
(** [SKIP]は状態を変えないことから、任意の性質 P を保存します:
[[
      --------------------  (hoare_skip)
      {{ P }} SKIP {{ P }}
]]
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* ####################################################### *)
(** *** コマンド合成 *)
(** より興味深いことに、コマンド[c1]が、[P]が成立する任意の状態を[Q]が成立する状態にし、
    [c2]が、[Q]が成立する任意の状態を[R]が成立する状態にするとき、
    [c1]に続いて[c2]を行うことは、[P]が成立する任意の状態を[R]が成立する状態にします:
[[
        {{ P }} c1 {{ Q }}
        {{ Q }} c2 {{ R }}
       ---------------------  (hoare_seq)
       {{ P }} c1;c2 {{ R }}
]]
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); try assumption. Qed.

(** 形式的規則[hoare_seq]においては、
    前提部分が「逆順」である([c1]の前に[c2]が来る)ことに注意してください。
    この順は、規則を使用する多くの場面で情報の自然な流れにマッチするのです。*)

(** 非形式的には、この規則を利用した証明を記録する良い方法は、
    [c1]と[c2]の間に中間表明[Q]を記述する"修飾付きプログラム"の様にすることです:
[[
      {{ a = n }}
    X ::= a;
      {{ X = n }}      <---- 修飾 Q
    SKIP
      {{ X = n }}
]]
*)

(* ####################################################### *)
(** *** 条件分岐 *)

(** しかし、実際には、より詳しいことを言うことができます。
   "then"の枝では、ブール式[b]の評価結果が[true]になることがわかっています。
   また"else"の枝では、それが[false]になることがわかっています。
   この情報を補題の前提部分で利用できるようにすることで、
   [c1]と[c2]の振舞いについて(つまり事後条件[Q]が成立する理由について)推論するときに、
   より多くの情報を使うことができるようになります。
[[
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
]]
*)

(** この規則を形式的に解釈するために、もう少しやることがあります。

    厳密には、上述の表明において、表明とブール式の連言[P /\ b]は、型チェックを通りません。
    これを修正するために、ブール式[b]を形式的に「持ち上げ」て、表明にしなければなりません。
    このために[bassn b]と書きます。
    これは"ブール式[b]の評価結果が(任意の状態で)[true]になる"という表明です。*)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

(** [bassn]についての2つの便利な事実です: *)

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(** いよいよ条件分岐についてのホーア証明規則を形式化し、正しいことを証明できます。*)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  Case "b is true".
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  Case "b is false".
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* ####################################################### *)
(** *** ループ *)

(** 最後に、ループについての推論規則が必要です。
    次のループを考えます:
[[
      WHILE b DO c END
]]
    そして、次の三つ組が正しくなる事前条件[P]と事後条件[Q]を探します:
[[
      {{P}} WHILE b DO c END {{Q}}
]]
    まず、[b]が最初から偽であるときを考えましょう。
    このときループの本体はまったく実行されません。
    この場合は、ループは[SKIP]と同様の振舞いをしますので、
    次のように書いても良いかもしれません。
[[
      {{P}} WHILE b DO c END {{P}}.
]]
    しかし、条件分岐について議論したのと同様に、最後でわかっていることはもう少し多いのです。
    最終状態では[P]であるだけではなく[b]が偽になっているのです。
    そこで、事後条件にちょっと付け足すことができます:
[[
      {{P}} WHILE b DO c END {{P /\ ~b}}
]]
    それでは、ループの本体が実行されるときはどうなるでしょう？
    ループを最後に抜けるときには[P]が成立することを確実にするために、
    コマンド[c]の終了時点で常に[P]が成立することを確認する必要があるのは確かでしょう。
    さらに、[P]が[c]の最初の実行の前に成立しており、[c]を実行するたびに、
    終了時点で[P]の成立が再度確立されることから、
    [P]が[c]の実行前に常に成立していると仮定することができます。
    このことから次の規則が得られます:
[[
                   {{P}} c {{P}}
        -----------------------------------
        {{P}} WHILE b DO c END {{P /\ ~b}}
]]
    命題[P]は不変条件(_invariant_)と呼ばれます。ループ不変式

    これで求める規則にかなり近付いたのですが、もうちょっとだけ改良できます。
    ループ本体の開始時点で、[P]が成立しているだけでなく、
    ガード[b]が現在の状態で真であるということも言えます。
    このことは、[c]についての推論の際にいくらかの情報を与えてくれます。
    結局、規則の最終バージョンはこうなります:
[[
               {{P /\ b}} c {{P}}
        -----------------------------------  [hoare_while]
        {{P}} WHILE b DO c END {{P /\ ~b}}
]]
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  remember (WHILE b DO c END) as wcom.
  induction He;                             (* wcom / st || st' に対する帰納法。 *)
    inversion Heqwcom; subst.

  (* "E_WhileEnd". *)
  (*
     HP : P st
     H : beval st b = false
     ============================
     P st /\ ~ bassn b st
 *)
  split.
  apply HP.
  apply bexp_eval_false. apply H.

  (* "E_WhileLoop". *)
  (*
     HP : P st
     He1 : c / st || st'
     IHHe1 : c = (WHILE b DO c END) -> P st -> P st' /\ ~ bassn b st'
     H : beval st b = true
     He2 : (WHILE b DO c END) / st' || st''
     IHHe2 : (WHILE b DO c END) = (WHILE b DO c END) ->
     P st' -> P st'' /\ ~ bassn b st''
     ============================
     P st'' /\ ~ bassn b st''
     *)
  apply IHHe2.  reflexivity.
  apply (Hhoare st st').
  apply He1.
  (* P st /\ bassn b st *)
  split.
  apply HP.
  apply bexp_eval_true. apply H.
Qed.

Theorem always_loop_hoare : forall P Q,
  {{P}} WHILE BTrue DO SKIP END {{Q}}.
Proof.
  unfold hoare_triple. intros P Q st st' contra.
  apply loop_never_stops in contra.  inversion contra.
Qed.

(* ####################################################### *)
(* ####################################################### *)
(* ####################################################### *)
(* ** Exercise: Reduce to Zero *)
(** ** 練習問題: ゼロへの簡約 *)

(** 次の while ループは、非常にシンプルなため、不変条件が必要ありません:
[[
          {{ True }}
        WHILE X <> 0 DO
            {{ True /\ X <> 0 }} =>
            {{ True }}
          X ::= X - 1
            {{ True }}
        END
          {{ True /\ X = 0 }} =>
          {{ X = 0 }}
]]
   この証明を Coq に変換しなさい。[slow_subtraction]の証明がアイデアの参考になるでしょう。
*)

(* **** Exercise: 2 stars (reduce_to_zero_correct) *)
(** **** 練習問題: ★★ (reduce_to_zero_correct) *)
Definition reduce_to_zero : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    X ::= AMinus (AId X) (ANum 1)
  END.

Theorem reduce_to_zero_correct :
  {{fun st => True}}
  reduce_to_zero
  {{fun st => asnat (st X) = 0}}.
Proof.
  unfold reduce_to_zero.
  (*
     {{ True }}
     WHILE X <> 0 DO
     X ::= X - 1
     END
     {{ X = 0 }}
 *)
  eapply hoare_consequence_post.            (* (1) *)
  (*
     {{ True }}
     WHILE X <> 0 DO
     X ::= X - 1
     END
     {{ True /\ X = 0 }}
 *)
  apply hoare_while.
  (*
     {{ True /\ X <> 0 }}
     X ::= X - 1
     {{ True }}
 *)
  eapply hoare_consequence_pre.             (* (2) *)
  (*
     {{ True }}
     X ::= X - 1
     {{ True }}
     *)
  apply hoare_asgn.
  (* (2)の後始末。
     {{True /\ X <> 0}} => {{True}}
     *)
  intros st H. apply H.
  (* (1)の後始末。
     {{True /\ X = 0}} => {{X=0}}
     *)
  intros st H. simpl in H.
  destruct H.
  unfold bassn, beval in H0. simpl in H0.
  apply eq_true_not_negb in H0.
  rewrite negb_involutive in H0.
  apply beq_nat_true in H0.
  apply H0.
Qed.
(** [] *)

(* ####################################################### *)
(* ####################################################### *)
(* ####################################################### *)
(* ** Exercise: Slow Addition *)
(** ** 練習問題: 遅い足し算 *)

(** 次のプログラムは変数Xを変数Zに足します。
    そのために、Xを減らしてZを増やすということを繰り返します。*)

Definition add_slowly : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    Z ::= APlus (AId Z) (ANum 1);
    X ::= AMinus (AId X) (ANum 1)
  END.

(* **** Exercise: 3 stars (add_slowly_decoration) *)
(** **** 練習問題: ★★★ (add_slowly_decoration) *)
(*
   [[
   {{ X = x /\ Z = z }} => (1)
   {{ Z + X = z + x }}        ：ループ不変式
   WHILE X <> 0 DO
   {{ Z + X = z + x /\ X <> 0 }} => (2)
   {{ (Z + 1) + (X - 1) = z + x }}
   Z ::= Z + 1;
   {{ Z + (X - 1) = z + x }}
   X ::= X - 1
   {{ Z + X = z + x }}
   END
   {{ Z + X = z + x /\ ~ (X <> 0) }} => (3)
   {{ Z = z + x }}
   ]]
*)
(** [] *)

(* **** Exercise: 3 stars (add_slowly_formal) *)
(** **** 練習問題: ★★★ (add_slowly_formal) *)
(* Now write down your specification of [add_slowly] formally, as a
    Coq [Hoare_triple], and prove it valid. *)
(** Coq の [Hoare_triple]のように、[add_slowly]の仕様を形式的に記述しなさい。
    そして正しさを証明しなさい。*)

Definition add_slowly_invariant x z :=
  fun st => (asnat (st Z)) + (asnat (st X)) = z + x.

Theorem add_slowly_correct : forall x z,
  {{fun st => asnat (st X) = x /\ asnat (st Z) = z}}
  add_slowly
  {{fun st => asnat (st Z) = z + x}}.
Proof.
  (* subtract_slowly を add_slowly に書き換えただけ。 *)
  intros x z. unfold add_slowly.
(*
   {{ X = x /\ Z = z }}
   WHILE X <> 0 DO
   Z ::= Z + 1;
   X ::= X - 1
   END
   {{ Z = z + x }}
]]
*)
  eapply hoare_consequence with (P' := add_slowly_invariant x z). (* pre:(1)、 post:(2) *)
(*
   {{ X + Z = x + z }} (1)
   WHILE X <> 0 DO
   Z ::= Z + 1;
   X ::= X - 1
   END
   {{ Z + X = z + x /\ ~ (X <> 0) }} (2)
]]
*)
  apply hoare_while.
(*
   {{ Z + X = z + x /\ X <> 0 }}
   Z ::= Z + 1;
   X ::= X - 1
   {{ Z + X = z + x }}
*)
  eapply hoare_seq.
(*
   SEQの後の文。
   {{ Z + (X - 1) = z + x }}
   X ::= X - 1
   {{ Z + X = z + x }}
*)
  apply hoare_asgn.
(*
   SEQの前の文。
   {{ Z + X = z + x /\ X <> 0 }}
   Z ::= Z + 1;
   {{ Z + (X - 1) = z + x }}
*)
  eapply hoare_consequence_pre.             (* (3) *)
(*
   {{ (Z + 1) + (X - 1) = z + x }}
   Z ::= Z + 1;
   {{ Z + (X - 1) = z + x }}
*)
  apply hoare_asgn.

(* (3)の後始末。
   {{ Z + X = z + x /\ X <> 0 }} => {{ (Z + 1) + (X - 1) = z + x }}
*)
  unfold add_slowly_invariant, assn_sub, update, bassn. simpl.
  intros st [Inv GuardTrue].
  remember (beq_nat (asnat (st X)) 0) as Q; destruct Q.
  inversion GuardTrue.
  symmetry in HeqQ.  apply beq_nat_false in HeqQ.
  omega.

(* (1)の後始末。
   {{ X = x /\ Z = z }} => {{ Z + X = z + x }}
   *)
  unfold add_slowly_invariant.
  intros st [HX HZ]. omega.

(* (2)の後始末。
   {{ Z + X = z + x /\ ~ (X <> 0) }} => {{ Z = z + x }}
 *)
  intros st [Inv GuardFalse].
  unfold add_slowly_invariant in Inv.
  unfold add_slowly_invariant.
  unfold bassn in GuardFalse. simpl in GuardFalse.
  destruct (asnat (st X)).
  omega.
  apply ex_falso_quodlibet.   apply GuardFalse. reflexivity.
Qed.

(* hoare_consequence_pre とhoare_consequence_postに分けてみた。
   後始末のゴールの順番が変わることに注意するだけ。
*)
Theorem add_slowly_correct' : forall x z,
  {{fun st => asnat (st X) = x /\ asnat (st Z) = z}}
  add_slowly
  {{fun st => asnat (st Z) = z + x}}.
Proof.
  intros x z. unfold add_slowly.
(*
   {{ X = x /\ Z = z }}
   WHILE X <> 0 DO
   Z ::= Z + 1;
   X ::= X - 1
   END
   {{ Z = z + x }}
]]
*)
   eapply hoare_consequence_pre.            (* (1) *)
(*  with (P' := add_slowly_invariant x z). *)
(*
   {{ X + Z = x + z }}
   WHILE X <> 0 DO
   Z ::= Z + 1;
   X ::= X - 1
   END
   {{ Z = z + x }}
]]
*)
   eapply hoare_consequence_post.           (* (2) *)
(*    with (Q' :=
      fun st : state =>                     (* (2) *)
        add_slowly_invariant x z st /\ ~ bassn (BNot (BEq (AId X) (ANum 0))) st).*)
(*
   {{ X + Z = x + z }} (1)
   WHILE X <> 0 DO
   Z ::= Z + 1;
   X ::= X - 1
   END
   {{ Z + X = z + x /\ ~ (X <> 0) }} (2)
]]
*)
  apply hoare_while
    with (P := add_slowly_invariant x z).
  (* whileの分解にループ不変式を使うのが、筋だと思う。 *)
(*
   {{ Z + X = z + x /\ X <> 0 }}
   Z ::= Z + 1;
   X ::= X - 1
   {{ Z + X = z + x }}
*)
  eapply hoare_seq.
(*
   SEQの後の文。
   {{ Z + (X - 1) = z + x }}
   X ::= X - 1
   {{ Z + X = z + x }}
*)
  apply hoare_asgn.
(*
   SEQの前の文。
   {{ Z + X = z + x /\ X <> 0 }}
   Z ::= Z + 1;
   {{ Z + (X - 1) = z + x }}
*)
  eapply hoare_consequence_pre.             (* (3) *)
(*
   {{ (Z + 1) + (X - 1) = z + x }}
   Z ::= Z + 1;
   {{ Z + (X - 1) = z + x }}
*)
  apply hoare_asgn.

(* (3)の後始末。
   {{ Z + X = z + x /\ X <> 0 }} => {{ (Z + 1) + (X - 1) = z + x }}
*)
  unfold add_slowly_invariant, assn_sub, update, bassn. simpl.
  intros st [Inv GuardTrue].
  remember (beq_nat (asnat (st X)) 0) as Q; destruct Q.
  inversion GuardTrue.
  symmetry in HeqQ. apply beq_nat_false in HeqQ.
  omega.

(* (2)の後始末。
   {{ Z + X = z + x /\ ~ (X <> 0) }} => {{ Z = z + x }}
 *)
  intros st [Inv GuardFalse].
  unfold add_slowly_invariant in Inv.
  unfold add_slowly_invariant.
  unfold bassn in GuardFalse. simpl in GuardFalse.
  destruct (asnat (st X)).
  omega.
  apply ex_falso_quodlibet. apply GuardFalse. reflexivity.

(* (1)の後始末。
   {{ X = x /\ Z = z }} => {{ Z + X = z + x }}
   *)
  unfold add_slowly_invariant.
  intros st [HX HZ]. omega.
Qed.
(** [] *)

(* ####################################################### *)
(* ####################################################### *)
(* ####################################################### *)
(* ** Example: Parity *)
(** ** 例: パリティ *)
(**
[[
    {{ X = x }} =>
    {{ X = x /\ 0 = 0 }}
  Y ::= 0;
    {{ X = x /\ Y = 0 }} =>
    {{ (Y=0 <-> ev (x-X)) /\ X<=x }}
  WHILE X <> 0 DO
      {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ X<>0 }} =>
      {{ (1-Y)=0 <-> ev (x-(X-1)) /\ X-1<=x }}
    Y ::= 1 - Y;
      {{ Y=0 <-> ev (x-(X-1)) /\ X-1<=x }}
    X ::= X - 1
      {{ Y=0 <-> ev (x-X) /\ X<=x }}
  END
    {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ ~(X<>0) }} =>
    {{ Y=0 <-> ev x }}
]]
*)

Definition find_parity : com :=
  Y ::= (ANum 0);
  WHILE (BNot (BEq (AId X) (ANum 0))) DO
    Y ::= AMinus (ANum 1) (AId Y);
    X ::= AMinus (AId X) (ANum 1)
  END.

Definition find_parity_invariant x :=
  fun st =>
       asnat (st X) <= x
    /\ (asnat (st Y) = 0 /\ ev (x - asnat (st X)) \/ asnat (st Y) = 1 /\ ~ev (x - asnat (st X))).

Lemma not_ev_ev_S_gen: forall n,
  (~ ev n -> ev (S n)) /\
  (~ ev (S n) -> ev (S (S n))).
Proof.
  induction n as [| n'].
  Case "n = 0".
    split; intros H.
    SCase "->".
      apply ex_falso_quodlibet. apply H. apply ev_0.
    SCase "<-".
      apply ev_SS. apply ev_0.
  Case "n = S n'".
    inversion IHn' as [Hn HSn]. split; intros H.
    SCase "->".
      apply HSn. apply H.
    SCase "<-".
      apply ev_SS. apply Hn. intros contra.
      apply H. apply ev_SS. apply contra.  Qed.

Lemma not_ev_ev_S : forall n,
  ~ ev n -> ev (S n).
Proof.
  intros n.
  destruct (not_ev_ev_S_gen n) as [H _].
  apply H.
Qed.

(* より修飾に忠実な判 *)
(*
[[
    {{ X = x }} =>                                (1)
    {{ X = x /\ 0 = 0 }}
  Y ::= 0;
    {{ X = x /\ Y = 0 }} =>                       (2)
    {{ (Y=0 <-> ev (x-X)) /\ X<=x }}
  WHILE X <> 0 DO
      {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ X<>0 }} => (3)
      {{ (1-Y)=0 <-> ev (x-(X-1)) /\ X-1<=x }}
    Y ::= 1 - Y;
      {{ Y=0 <-> ev (x-(X-1)) /\ X-1<=x }}
    X ::= X - 1
      {{ Y=0 <-> ev (x-X) /\ X<=x }}
  END
    {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ ~(X<>0) }} => (4)
    {{ Y=0 <-> ev x }}
]]
*)
Theorem find_parity_correct'' : forall x,
  {{fun st => asnat (st X) = x}}
  find_parity
  {{fun st => asnat (st Y) = 0 <-> ev x}}.
Proof.
  intros x. unfold find_parity.
(*
[[
{{ X = x }}
  Y ::= 0;
  WHILE X <> 0 DO
    Y ::= 1 - Y;
    X ::= X - 1
  END
  {{ Y=0 <-> ev x }}
]]
*)
 eapply hoare_consequence_post.             (* (4) *)
(*
[[
{{ X = x }}
  Y ::= 0;
  WHILE X <> 0 DO
    Y ::= 1 - Y;
    X ::= X - 1
  END
    {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ ~(X<>0) }}
]]
*)
  apply hoare_seq with (Q := find_parity_invariant x). (* (2) *)
  (* 修飾の証明は増えない。つまり(2)の修飾の証明はいらない。 *)
(*
[[
{{ (Y=0 <-> ev (x-X)) /\ X<=x }} ： ループ不変式
  WHILE X <> 0 DO
    Y ::= 1 - Y;
    X ::= X - 1
  END
  {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ ~(X<>0) }}
]]
*)
  apply hoare_while with (P := find_parity_invariant x). (* ゴールは増えない。 *)
(*
[[
{{ (Y=0 <-> ev (x-X)) /\ X<=x /\ X<>0 }}
Y ::= 1 - Y;
X ::= X - 1
{{ Y=0 <-> ev (x-X) /\ X<=x }}
]]
*)
    eapply hoare_seq.
(*
[[
{{ Y=0 <-> ev (x-(X-1)) /\ X-1<=x }}
X ::= X - 1
{{ Y=0 <-> ev (x-X) /\ X<=x }}
]]
*)
    apply hoare_asgn.                       (* X ::= X - 1 *)
(*
[[
{{ (Y=0 <-> ev (x-X)) /\ X<=x /\ X<>0 }}
Y ::= 1 - Y;
{{ Y=0 <-> ev (x-(X-1)) /\ X-1<=x }}
]]
*)
    eapply hoare_consequence_pre.           (* (3) *)
(*
[[
{{ (1-Y)=0 <-> ev (x-(X-1)) /\ X-1<=x }}
Y ::= 1 - Y;
{{ Y=0 <-> ev (x-(X-1)) /\ X-1<=x }}
]]
*)
    apply hoare_asgn.                       (* Y ::= 1 - Y *)
(* (3)の修飾の証明。
   {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ X<>0 }} =>
   {{ (1-Y)=0 <-> ev (x-(X-1)) /\ X-1<=x }}
   *)
    intros st [[Inv1 Inv2] GuardTrue].
    unfold find_parity_invariant, bassn, assn_sub, aeval in *. (* GoalとGuardTrue *)
    rewrite update_eq.
    rewrite (update_neq Y X); auto.
    rewrite (update_neq X Y); auto.
    rewrite update_eq.
    simpl in GuardTrue. destruct (asnat (st X)).
      inversion GuardTrue. simpl.
    split. omega.
    inversion Inv2 as [[H1 H2] | [H1 H2]]; rewrite H1;
                     [right|left]; (split; simpl; [omega |]).
    apply ev_not_ev_S in H2.
    replace (S (x - S n)) with (x-n) in H2 by omega.
    rewrite <- minus_n_O. assumption.
    apply not_ev_ev_S in H2.
    replace (S (x - S n)) with (x - n) in H2 by omega.
    rewrite <- minus_n_O. assumption.
(*
[[
{{ X = x }}
Y ::= 0;
{{ (Y=0 <-> ev (x-X)) /\ X<=x }}
]]
*)
    eapply hoare_consequence_pre.           (* (1) *)
(*
[[
{{ X = x /\ 0 = 0 }}
Y ::= 0;
{{ (Y=0 <-> ev (x-X)) /\ X<=x }}
]]
*)
    apply hoare_asgn.                       (* Y ::= 0 *)
(* (1) の修飾の証明
   {{ X = x }} => {{ X = x /\ 0 = 0 }}
*)
    intros st H.
    unfold assn_sub, find_parity_invariant, update. simpl.
    subst.
    split.
    omega.
    replace (asnat (st X) - asnat (st X)) with 0 by omega.
    left. split. reflexivity.
    apply ev_0.

(* (4) の修飾の証明。
   {{ (Y=0 <-> ev (x-X)) /\ X<=x /\ ~(X<>0) }} => {{ Y=0 <-> ev x }}
*)
    unfold bassn, find_parity_invariant. simpl.
    intros st [[Inv1 Inv2] GuardFalse].
    destruct (asnat (st X)).
      split; intro.
        inversion Inv2.
           inversion H0 as [_ H1]. replace (x-0) with x in H1 by omega.
           assumption.
           inversion H0 as [H0' _]. rewrite H in H0'. inversion H0'.
        inversion Inv2.
           inversion H0. assumption.
           inversion H0 as [_ H1]. replace (x-0) with x in H1 by omega.
           apply ex_falso_quodlibet. apply H1. assumption.
      apply ex_falso_quodlibet. apply GuardFalse. reflexivity.
Qed.

(* ####################################################### *)
(* ####################################################### *)
(* ** Example: Finding Square Roots *)
(** ** 例: 平方根の探索 *)
(*
{{Treu}} => {{x = x}}              修飾(0)
  X ::= ANum x;
{{X = x}} => {{X = x /\ 0 = 0}}    修飾(1)
  Z ::= ANum 0;
{{X = x /\ Z = 0}}                 修飾(2)
=> {{X = x /\ Z * Z <= x}}         ループ不変式
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) <= x}}  ループ不変式かつループ実行条件
=> {{X = x /\ (Z+1)*(Z+1) <= x}}   修飾(3)
    Z ::= APlus (ANum 1) (AId Z)
{{X = x /\ Z * Z <= x}}            ループ不変式
END
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) > x}}   ループ不変式かつ終了条件
=> {{Z * Z <= x /\ (Z+1)*(Z+1) > x}}  要求仕様、 修飾(4)
*)

Definition sqrt_loop : com :=
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
    Z ::= APlus (ANum 1) (AId Z)
  END.

Definition sqrt_com : com :=
  Z ::= ANum 0;
  sqrt_loop.

Definition sqrt_spec (x : nat) : Assertion :=
  fun st =>
       ((asnat (st Z)) * (asnat (st Z))) <= x
    /\ ~ (((S (asnat (st Z))) * (S (asnat (st Z)))) <= x).

Definition sqrt_inv (x : nat) : Assertion :=
  fun st =>
       asnat (st X) = x
    /\ ((asnat (st Z)) * (asnat (st Z))) <= x.

Theorem random_fact_1 : forall st,
     (S (asnat (st Z))) * (S (asnat (st Z))) <= asnat (st X) ->
     bassn (BLe (AMult (APlus (ANum 1) (AId Z))
                       (APlus (ANum 1) (AId Z)))
                (AId X)) st.
Proof.
  intros st Hle.  unfold bassn. simpl.
  destruct (asnat (st X)) as [|x'].
  Case "asnat (st X) = 0".
    inversion Hle.
  Case "asnat (st X) = S x'".
    simpl in Hle. apply le_S_n in Hle.
    remember (ble_nat (plus (asnat (st Z))
                      ((asnat (st Z)) * (S (asnat (st Z))))) x')
      as ble.
    destruct ble. reflexivity.
    symmetry in Heqble. apply ble_nat_false in Heqble.
    unfold not in Heqble. apply Heqble in Hle. inversion Hle.
Qed.

Theorem random_fact_2 : forall st,
     bassn (BLe (AMult (APlus (ANum 1) (AId Z))
                       (APlus (ANum 1) (AId Z)))
                (AId X)) st ->
       asnat (aeval st (APlus (ANum 1) (AId Z)))
     * asnat (aeval st (APlus (ANum 1) (AId Z)))
     <= asnat (st X).
Proof.
  intros st Hble. unfold bassn in Hble. simpl in *.
  destruct (asnat (st X)) as [| x'].
  Case "asnat (st X) = 0".
    inversion Hble.
  Case "asnat (st X) = S x'".
    apply ble_nat_true in Hble. omega. Qed.

(* 修飾を注釈版 *)
Theorem sqrt_com_correct' : forall x,
  {{fun st => True}} (X ::= ANum x; sqrt_com) {{sqrt_spec x}}.
Proof.
  intros x.
(*
{{Treu}}
  X ::= ANum x;
  Z ::= ANum 0;
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
    Z ::= APlus (ANum 1) (AId Z)
END
{{Z * Z <= x /\ (Z+1)*(Z+1) > x}} 要求仕様
*)
  apply hoare_seq with (Q := fun st => asnat (st X) = x).
(*
{{X = x}}
  Z ::= ANum 0;
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
    Z ::= APlus (ANum 1) (AId Z)
END
{{Z * Z <= x /\ (Z+1)*(Z+1) > x}} 要求仕様
*)
  Case "sqrt_com".
    unfold sqrt_com.
    apply hoare_seq with (Q := fun st => asnat (st X) = x
                                      /\ asnat (st Z) = 0).

(*
{{X = x /\ Z = 0}}
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
    Z ::= APlus (ANum 1) (AId Z)
END
{{Z * Z <= x /\ (Z+1)*(Z+1) > x}} 要求仕様
*)
    SCase "sqrt_loop".
      unfold sqrt_loop.
      eapply hoare_consequence.
(*
{{X = x /\ Z * Z <= x}}         ループ不変式
  WHILE BLe (AMult (APlus (ANum 1) (AId Z))
                   (APlus (ANum 1) (AId Z)))
            (AId X) DO
    Z ::= APlus (ANum 1) (AId Z)
END
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) > x}}   ループ不変式かつ終了条件
*)
      apply hoare_while with (P := sqrt_inv x).
(*
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) <= x}}  ループ不変式かつループ実行条件
    Z ::= APlus (ANum 1) (AId Z)
{{X = x /\ Z * Z <= x}}            ループ不変式
*)
      SSCase "loop preserves invariant".
        eapply hoare_consequence_pre.
(*
{{X = x /\ (Z+1)*(Z+1) <= x}}   修飾(3)
    Z ::= APlus (ANum 1) (AId Z)
{{X = x /\ Z * Z <= x}}            ループ不変式
*)
        apply hoare_asgn.                   (* Z := 1 + Z *)
(*
   修飾(3)の証明
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) <= x}}  ループ不変式かつループ実行条件
=> {{X = x /\ (Z+1)*(Z+1) <= x}}
*)
        intros st H.
        unfold assn_sub. unfold sqrt_inv in *.
        inversion H as [[HX HZ] HP]. split.
        SSSCase "X is preserved".
          rewrite update_neq; auto.
        SSSCase "Z is updated correctly".
          rewrite (update_eq (aeval st (APlus (ANum 1) (AId Z))) Z st).
          subst. apply random_fact_2. assumption.
(*  修飾(3)終わり *)
(*
   修飾(2)の証明
{{X = x /\ Z = 0}} => {{X = x /\ Z * Z <= x}}   ループ不変式
*)
      SSCase "invariant is true initially".
        intros st H. inversion H as [HX HZ].
        unfold sqrt_inv. split. assumption.
        rewrite HZ. simpl. omega.
(*  修飾(2)終わり *)
(*
   修飾(4)の証明
{{X = x /\ Z * Z <= x /\ (Z+1)*(Z+1) > x}}   ループ不変式かつ終了条件
=> {{Z * Z <= x /\ (Z+1)*(Z+1) > x}}         要求仕様
*)
      SSCase "after loop, spec is satisfied".
        intros st H. unfold sqrt_spec.
        inversion H as [HX HP].
        unfold sqrt_inv in HX.  inversion HX as [HX' Harith].
        split. assumption.
        intros contra. apply HP. clear HP.
        simpl. simpl in contra.
        apply random_fact_1. subst x. assumption.
(*  修飾(4)終わり *)
(*
{{X = x}}
  Z ::= ANum 0;
{{X = x /\ Z = 0}}
*)
    SCase "Z set to 0".
      eapply hoare_consequence_pre.
(*
{{X = x /\ 0 = 0}}
  Z ::= ANum 0;
{{X = x /\ Z = 0}}
*)
(*
   修飾(1)の証明
{{X = x}} => {{X = x /\ 0 = 0}}
 *)
      apply hoare_asgn.                     (* Z := 0 *)
      intros st HX.
      unfold assn_sub. split.
      rewrite update_neq; auto.
      rewrite update_eq; auto.
(*  修飾(1)終わり *)
(*
{{Treu}}
  X ::= ANum x;
{{X = x}}
*)
  Case "assignment of X".
    eapply hoare_consequence_pre.
(*
{{x = x}}
  X ::= ANum x;
{{X = x}}
*)
    apply hoare_asgn.                       (* X := x *)
(*
   修飾(0)の証明
{{Treu}} => {{x = x}}
*)
    intros st H.
    unfold assn_sub. rewrite update_eq; auto.
(*  修飾(0)終わり *)
  Qed.
(** [] *)

(* ####################################################### *)
(* ####################################################### *)
(* ####################################################### *)
(* ** Exercise: Factorial *)
(** ** 練習問題: 階乗 *)

Module Factorial.

Fixpoint real_fact (n:nat) : nat :=
  match n with
  | O => 1
  | S n' => n * (real_fact n')
  end.

(* Recall the factorial Imp program: *)
(** 階乗を計算する Imp プログラムを思い出してください: *)

Definition fact_body : com :=
  Y ::= AMult (AId Y) (AId Z);
  Z ::= AMinus (AId Z) (ANum 1).

Definition fact_loop : com :=
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    fact_body
  END.

Definition fact_com : com :=
  Z ::= (AId X);
  Y ::= ANum 1;
  fact_loop.

(* **** Exercise: 3 stars, optional (fact_informal) *)
(** **** 練習問題: ★★★, optional (fact_informal) *)
(* Decorate the [fact_com] program to show that it satisfies the
    specification given by the pre and postconditions below.  Just as
    we have done above, you may elide the algebraic reasoning about
    arithmetic, the less-than relation, etc., that is (formally)
    required by the rule of consequence:

(* FILL IN HERE *)
[[
    {{ X = x }}
  Z ::= X;
  Y ::= 1;
  WHILE Z <> 0 DO
    Y ::= Y * Z;
    Z ::= Z - 1
  END
    {{ Y = real_fact x }}
]]
*)
(** [fact_com]を修飾して、以下の事前条件、事後条件として与えられる仕様を満たすことを示しなさい。
    帰結規則のために(形式的には)算術式や不等号などについての推論が必要になりますが、
    ここまでと同様、それらは省略して構いません。

回答：
[[
{{True}} => {{ X = x }}  修飾(1)
  Z ::= X;
{{Z = x}} => {{Z = x /\ 1 = 1}} 修飾(2)
  Y ::= 1;
{{Z = x /\ Y = 1}} =>  修飾(3)
{{Y*real_fact(Z) = real_fact(x)}} ループ不変式
  WHILE Z <> 0 DO
{{Y * real_fact(Z) = real_fact(x) /\ Z <> 0}} ループ不変式、かつ、ループ実行条件
=> {{Y * Z * real_fact(Z - 1) = real_fact(x)}} 修飾(4)
    Y ::= Y * Z;
{{Y * real_fact(Z - 1) = real_fact(x)}}
    Z ::= Z - 1
{{Y * real_fact(Z) = real_fact(x)}} ループ不変式
  END
{{Y * real_fact(Z) = real_fact(x) /\ Z = 0}} ループ不変式、かつ、終了条件
=> {{ Y = real_fact x }} 要求仕様、修飾(5)
]]
*)
(** [] *)

(* ####################################################### *)
(* ####################################################### *)
(* **** Exercise: 4 stars, optional (fact_formal) *)
(** **** 練習問題: ★★★★, optional (fact_formal) *)
(* Prove formally that fact_com satisfies this specification,
    using your informal proof as a guide.  You may want to state
    the loop invariant separately (as we did in the examples). *)
(** fact_com がこの仕様を満たすことを、形式的に証明しなさい。
    その際、自分の非形式的な証明をガイドとして使いなさい。
    (例で行ったように)ループ不変条件を分離して主張しても構いません。*)

(* 要求仕様 使ってない *)
Definition fact_spec (x : nat) : Assertion :=
  fun st =>
       asnat (st Z) = real_fact x.

Definition fact_inv (x : nat) : Assertion :=
  fun st =>
       asnat (st Y) * real_fact (asnat (st Z)) = real_fact x.

Theorem fact_com_correct : forall x,
  {{fun st => asnat (st X) = x}} fact_com
  {{fun st => asnat (st Y) = real_fact x}}.
Proof.
  unfold fact_com, fact_loop, fact_body.
  intros x.
  eapply hoare_consequence_post.            (* 修飾(5) *)
  eapply hoare_consequence_pre.             (* 修飾(1) *)
  apply hoare_seq with (Q := fun st => asnat (st Z) = x).
  eapply hoare_consequence_pre.             (* 修飾(2) *)
  apply hoare_seq with (Q := fun st => asnat (st Z) = x /\ asnat (st Y) = 1).
  eapply hoare_consequence_pre.             (* 修飾(3) *)
  apply hoare_while with (P := fact_inv x).
  eapply hoare_consequence_pre.             (* 修飾(4) *)
  eapply hoare_seq.
  apply hoare_asgn.                         (* Z := Z - 1 *)
  apply hoare_asgn.                         (* Y := Y * Z *)
(*
   修飾(4)の証明
   {{Y * real_fact(Z) = real_fact(x) /\ Z <> 0}} ループ不変式、かつ、ループ実行条件
   => {{Y * Z * real_fact(Z - 1) = real_fact(x)}}
 *)
  unfold assn_sub, bassn, fact_inv, update.
  intros st H. simpl.
  destruct H as [H1 H2].
  simpl in H2.
  (* ここの証明は、Imp_J.vの fact_body_preserves_invariant とおなじ。 *)
  destruct (asnat (st Z)) as [| z'].
  apply ex_falso_quodlibet. inversion H2.
  rewrite <- H1. rewrite <- mult_assoc.
  replace (S z' - 1) with z' by omega.
  reflexivity.
(* 修飾(4)の証明、終わり *)

(*
   修飾(3)の証明
   {{Z = x /\ Y = 1}} => {{Y*real_fact(Z) = real_fact(x)}} ループ不変式
*)
  intros st H.
  unfold fact_inv.
  destruct H as [H1 H2].
  rewrite H1. rewrite H2. omega.
(* 修飾(3)の証明、終わり *)

  apply hoare_asgn.                         (* Y := 1 *)
(*
   修飾(2)の証明
   {{Z = x}} => {{Z = x /\ 1 = 1}}
*)
  unfold assn_sub, update.
  intros st H.
  split; try(rewrite <- H); simpl; reflexivity.
(* 修飾(2)の証明、終わり *)

  apply hoare_asgn.                         (* Z := X *)
(*
   修飾(1)の証明
   {{True}} => {{ X = x }}
*)
  unfold assn_sub, update. simpl.
  intros st H.
  apply H.
(* 修飾(1)の証明、終わり *)

(*
   修飾(5)の証明
   {{Y * real_fact(Z) = real_fact(x) /\ Z = 0}}
   ループ不変式、かつ、終了条件
   => {{ Y = real_fact x }} 要求仕様
   *)
  unfold assn_sub, bassn, fact_inv, update.
  intros st H. simpl.
  destruct H as [H1 H2].
  simpl in H2.
  destruct (asnat (st Z)) as [| z'].
  rewrite <- H1. simpl. omega.
  apply ex_falso_quodlibet. apply H2.
  reflexivity.
Qed.
(** [] *)

End Factorial.

(* ####################################################### *)
(* ####################################################### *)
(* ** Reasoning About Programs with Lists *)
(** ** リストを扱うプログラムについての推論 *)

(* **** Exercise: 3 stars (list_sum) *)
(** **** 練習問題: ★★★ (list_sum) *)
(* Here is a direct definition of the sum of the elements of a list,
    and an Imp program that computes the sum. *)
(** 以下は、リストの要素の合計の直接的定義と、その合計を計算するImpプログラムです *)

Definition sum l := fold_right plus 0 l.

Definition sum_program :=
  Y ::= ANum 0;
  WHILE (BIsCons (AId X)) DO
    Y ::= APlus (AId Y) (AHead (AId X)) ;
    X ::= ATail (AId X)
  END.

(* ループ不変式 *)
Definition sum_program_inv l : Assertion :=
  fun st =>
    asnat (st Y) + sum (aslist (st X)) = sum l.

(* Provide an _informal_ proof of the following specification of
    [sum_program] in the form of a decorated version of the
    program. *)
(** [sum_program]の以下の仕様の「非形式的な」証明を、
    修飾を付けたバージョンのプログラムの形で与えなさい。*)

Definition sum_program_spec := forall l,
  {{ fun st => aslist (st X) = l }}
  sum_program
  {{ fun st => asnat (st Y) = sum l }}.

(*
[[
{X = 1} => {X = 1 /\ 0 = 0}              修飾(1)
Y := 0;
{X = 1 /\ Y = 0} => {Y + sum X = sum l}  修飾(2)、ループ不変式
WHILE (isCons X) DO
{Y + sum X = sum l /\ isCons X}          ループ不変式かつループ実行条件
=> {Y + head X + sum (tail X) = sum l}   修飾(3)
  Y := Y + head X;
{Y + sum (tail X) = sum l}
  X := tail X;
{Y + sum X = sum l}                      ループ不変式
END
{Y + sum X = sum l /\ ~isCons X}         ループ不変式かつループ終了条件
=> {Y = sum l}                           修飾(4)、要求仕様
]]
*)

Lemma sum_head_tail : forall l,
  head l + sum (tail l) = sum l.
Proof.
  intros l.
  induction l; simpl; reflexivity.
Qed.

Theorem sum_program_correct :
  sum_program_spec.
Proof.
  unfold sum_program_spec.
  intros l.
  eapply hoare_consequence_post.            (* 修飾(4) *)
  eapply hoare_consequence_pre.             (* 修飾(1) *)
  eapply hoare_seq
    with (Q := fun st => aslist (st X) = l /\ asnat (st Y) = 0).
  eapply hoare_consequence_pre.             (* 修飾(2) *)
  apply hoare_while with (P := sum_program_inv l).
  eapply hoare_consequence_pre.             (* 修飾(3) *)
  eapply hoare_seq.
  apply hoare_asgn.                         (* X := tail X *)
  apply hoare_asgn.                         (* Y := Y + head X *)
(*
   修飾(3)
   {Y + sum X = sum l /\ isCons X}
   => {Y + head X + sum (tail X) = sum l}
   *)
  unfold sum_program_inv, assn_sub. simpl.
  intros st [H1 H2].
  unfold bassn in H2.
  unfold update. simpl.
  rewrite plus_assoc_reverse.
  rewrite (sum_head_tail (aslist (st X))).
  apply H1.

(*
   修飾(2)
   {X = 1 /\ Y = 0} => {Y + sum X = sum l}
   *)
  unfold sum_program_inv. simpl.
  intros st [H1 H2].
  rewrite H2. rewrite H1. reflexivity.

  apply hoare_asgn.                         (* Y := 0 *)
(*
   修飾(1)
   {X = l} => {X = l /\ 0 = 0}
   *)
  unfold assn_sub, update. simpl.
  intros st H.
  split. apply H. reflexivity.

(*
   修飾(4)
   {Y + sum X = sum l /\ ~(isCons X)} => {Y = sum l}
   *)
  unfold sum_program_inv, bassn, update.
  intros st [H1 H2].
  remember (aslist (st X)) as x'.
  destruct x'.
  (* X = [] のとき。 *)
  rewrite <- H1. simpl. omega.
  (* X = n :: x' のとき。 *)
  apply ex_falso_quodlibet.
  apply H2. simpl.
  rewrite <- Heqx'.
  reflexivity.
Qed.
(** [] **)

(* **** Exercise: 4 stars, optional (list_reverse) *)
(** **** 練習問題: ★★★★, optional (list_reverse) *)
(* Recall the function [rev] from Poly.v, for reversing lists. *)
(** Poly_J.vの[rev]を思い出してください。リストを逆順にするものです。*)

Fixpoint snoc {X:Type} (l:list X) (v:X) : (list X) :=
  match l with
  | nil      =>  [ v ]
  | cons h t => h :: (snoc t v)
  end.

Lemma snoc_equation : forall (A : Type) (h:A) (x y : list A),
  snoc x h ++ y = x ++ h :: y.
Proof.
  intros A h x y.
  induction x.
    Case "x = []". reflexivity.
    Case "x = cons". simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_nil : forall (A : Type) (l : list A),
  l ++ [] = l.
Proof.
  induction l.
    reflexivity.
    simpl. rewrite IHl. reflexivity.
Qed.

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

Lemma rev_equation : forall (A : Type) (h : A) (x y : list A),
  rev (h :: x) ++ y = rev x ++ h :: y.
Proof.
  intros. simpl. apply snoc_equation.
Qed.

Definition rev_program :=
  Y ::= ANil;
  WHILE BIsCons (AId X) DO
    Y ::= ACons (AHead (AId X)) (AId Y);
    X ::= ATail (AId X)
  END.

Definition rev_program_inv l : Assertion :=
  fun st =>
    rev (aslist (st X)) ++ aslist (st Y) = rev l.

Definition rev_program_spec := forall l,
  {{fun st => aslist (st X) = l}}
  rev_program
  {{fun st => aslist (st Y) = rev l}}.

(*
[[
{X = l} => {X = l /\ nil = nil}             修飾(1)
  Y ::= ANil;
{X = l /\ Y = nil} => {rev X ++ Y = rev l}  修飾(2)、ループ不変式
  WHILE BsCons (AId X) DO
{rev X ++ Y = rev l /\ BsCons (AId X)}      ループ不変式かつループ実行条件
=> {rev (tail X) ++ ((head X) :: Y) = rev l}  修飾(3)
    Y ::= ACons (AHead (AId X)) (AId Y);
{rev (tail X) ++ Y = rev l}
    X ::= ATail (AId X)
{rev X ++ Y = rev l}                        ループ不変式
  END.
{rev X ++ Y = rev l /\ ~(isCons X)}         ループ不変式かつループ終了条件
=> {Y = rev l}                              修飾(4)、要求仕様
]]
*)

Theorem rev_program_correct :
  rev_program_spec.
Proof.
  unfold rev_program_spec, rev_program.
  intros l.
  eapply hoare_consequence_post.            (* 修飾(4) *)
  eapply hoare_consequence_pre.             (* 修飾(1) *)
  apply hoare_seq
    with (Q := fun st => aslist (st X) = l /\ aslist (st Y) = []).
  eapply hoare_consequence_pre.             (* 修飾(2) *)
  apply hoare_while
    with (P := rev_program_inv l).
  eapply hoare_consequence_pre.             (* 修飾(3) *)
  eapply hoare_seq.
  apply hoare_asgn.                         (* Y := tail X *)
  apply hoare_asgn.                         (* Y := (head X) :: Y *)
(*
   修飾(3)
   {rev X ++ Y = rev l /\ BsCons (AId X)}
   => {rev (tail X) ++ ((head X) :: Y) = rev l}
   *)
  unfold rev_program_inv, assn_sub, bassn, update. simpl.
  intros st [H1 H2].
  rewrite <- (rev_equation nat
    (head (aslist (st X)))                  (* h *)
    (tail (aslist (st X)))                  (* x *)
    (aslist (st Y))).                       (* y *)
   (* (head X) :: (tail X) = X にならない。
      （(head []) :: (tail []) = 0 :: [] = [0] だから。）
      だから、Xをnilとconsに分けて証明する。
      *)
   remember (aslist (st X)) as x'.
   destruct x'.
(* X = [] *)
   simpl.
   (* 0 :: aslist (st Y) = rev l 、、、これは変 *)
   apply ex_falso_quodlibet.
   inversion H2.
(* X = n :: x' *)
   rewrite <- H1.
   simpl.
   reflexivity.

(*
   修飾(2)
   {X = l /\ Y = nil} => {rev X ++ Y = rev l}
   *)
   unfold rev_program_inv.
   intros st [H1 H2].
   rewrite H1. rewrite H2.
   apply append_nil.

   apply hoare_asgn.                        (* Y := nil *)
(*
   修飾(1)
   {X = l} => {X = l /\ nil = nil}
   *)
   unfold assn_sub, update. simpl.
   intros st H.
   split. apply H. reflexivity.

(*
   修飾(4)
   {rev X ++ Y = rev l /\ ~(isCons X)} => {Y = rev l}
   *)
   unfold rev_program_inv, bassn, update.
   intros st [H1 H2].
   rewrite <- H1.
   remember (aslist (st X)) as x'.
   destruct x'.
(* X = [] のとき。 *)
   simpl. reflexivity.
(* X = n :: x' のとき *)
   apply ex_falso_quodlibet.
   apply H2. simpl. rewrite <- Heqx'.
   reflexivity.
Qed.
(** [] *)

(* ####################################################### *)
(* ####################################################### *)
(* 次節の問題だが、ここ方法で解いて見る。 *)
(** [X]に現在設定されている値を変数[Y]に代入する遠回りの方法は、
    [Y]を[0]から始め、
    [X]を[0]になるまで減らしていきながら、その各ステップで[Y]を増やしていくことです。
    com の方法で解いてみる *)
(*
[[
      {{ X = x }} => {0 = 0}                                   (1)
    Y ::= 0;
      {{ X = x /\ Y = 0 }} => {{ X + Y = x }}      ループ不変式 (2)
    WHILE X <> 0 DO
        {{ X + Y = x /\ X > 0 }}
        => {{ (X - 1) + (Y + 1) = x }}                         (3)
      X ::= X - 1;
        {{ X + Y + 1 = x }}
      Y ::= Y + 1;
        {{ X + Y = x }}
    END
      {{ X + Y = x /\ X = 0 }} => {{ Y = x }}                   (4)
]]
*)

Definition slow_asgn_prog :=
  Y ::= (ANum 0);
  WHILE (BNot (BEq (AId X) (ANum 0))) DO
    X ::= AMinus (AId X) (ANum 1);
    Y ::= APlus (AId Y) (ANum 1)
  END.

Definition slow_asgn_prog_inv x : Assertion :=
  fun st =>
    asnat (st X) + asnat (st Y) = x.

Definition slow_asgn_prog_spec := forall x,
  {{ fun st => asnat (st X) = x }}
  slow_asgn_prog
  {{ fun st => asnat (st Y) = x }}.

Lemma negb_not_true_iff : forall b, negb b <> true <-> b = true.
Proof.
  intros b.
  split.
  intros H.
  apply eq_true_negb_classical.             (* XXX *)
  apply H.
  intros H.

  rewrite H. simpl.
  unfold not.
  intros. inversion H0.
Qed.

Lemma x_plus_y__x_m1_plus_y_p1 : forall x y,
             x <> 0 -> x + y = (x - 1) + (y + 1).
Proof.
  intros x y H.
  induction x as [| x'].
  Case "x = 0".
    apply ex_falso_quodlibet.               (* 単にomegaでもよい *)
    apply H. reflexivity.
  Case "x = Sx'".
    omega.
Qed.

Theorem slow_asgn_prog_correct :
  slow_asgn_prog_spec.
Proof.
  unfold slow_asgn_prog_spec.
  intros x.
  eapply hoare_consequence_post.            (* 修飾(4) *)
  eapply hoare_consequence_pre.             (* 修飾(1) *)
  eapply hoare_seq
    with (Q := fun st => asnat (st X) = x /\ asnat (st Y) = 0).
  eapply hoare_consequence_pre.             (* 修飾(2) *)
  apply hoare_while with (P := slow_asgn_prog_inv x).
  eapply hoare_consequence_pre.             (* 修飾(3) *)
  eapply hoare_seq.
  apply hoare_asgn.                         (* Y := Y + 1 *)
  apply hoare_asgn.                         (* X := X - 1 *)
(*
   修飾(3)
   {{ X + Y = x /\ X > 0 }}
   => {{ (X - 1) + (Y + 1) = x }}                         (3)
*)
  unfold slow_asgn_prog_inv, assn_sub. simpl.
  intros st [H1 H2].
  unfold bassn in H2.
  unfold update. simpl.
  rewrite <- x_plus_y__x_m1_plus_y_p1.
  rewrite H1.
  reflexivity.
  (* X <> 0 の証明をする。 *)
  apply beq_nat_false.
  unfold bassn in H2.
  apply negb_true_iff in H2.
  apply H2.
(*
   修飾(2)
   {{ X = x /\ Y = 0 }} => {{ X + Y = x }}
   *)
  unfold slow_asgn_prog_inv.
  intros st [H1 H2].
  rewrite H2. rewrite H1. omega.

  apply hoare_asgn.                         (* X := x *)
(*
   修飾(1)
   {{ X = x }} => {0 = 0}                                   (1)
   *)
  unfold assn_sub, update. simpl.
  intros st H.
  split. apply H. reflexivity.

(*
   修飾(4)
   {{ X + Y = x /\ X = 0 }} => {{ Y = x }}                  (4)
   *)
  unfold slow_asgn_prog_inv, bassn. simpl.
  intros st [H1 H2].
  apply negb_not_true_iff in H2.
  apply beq_nat_true in H2.
  rewrite H2 in H1.
  rewrite plus_O_n in H1.
  apply H1.
Qed.

(* END *)


(*|
######################################################
Trouble writing my notation for natural numbers in Coq
######################################################

:Link: https://stackoverflow.com/q/11714415
|*)

(*|
Question
********

Why does Coq not accept this?

.. coq:: none
|*)

Definition addition a b := a + b.
Definition multiply a b := a * b.
Definition ten := 10.

(*||*)

Fail Notation "[ d1 , .. , d2 ]" := (addition (multiply ( .. d1 .. ) ten) d2). (* .fails *)

(*|
Answer
******

`Recursive notations
<http://coq.inria.fr/doc/Reference-Manual015.html#RecursiveNotations>`__
need to obey fairly strict rules. The pattern to repeat must appear
twice (that's how Coq knows what is to be repeated): once using ``d2``
around the hole, and once using ``d1`` around a *terminating
expression*. You've only used your pattern once, using ``d2`` around
the hole. You need another iteration, around some ``zero`` (like
``nil`` in the notation for lists).
|*)

Definition zero := 0. (* .none *)
Notation "[ d1 , .. , d2 ]" :=
  (addition (multiply .. (addition (multiply zero ten) d1) .. ten) d2).

(*|
If you don't wish to introduce a zero, you can require at least two
digits inside the brackets (instead of just one as above), and use
that as the terminating expression. This is like the notation for
pairs (in ``Init/Notations.v``, also presented in the manual). You
could complement this with a notation for ``[d0]`` with lower
priority, but as this is just ``d0`` there isn't much point.
|*)

Notation "[ d0 , d1 , .. , d2 ]" :=
  (addition (multiply .. (addition (multiply d0 ten) d1) .. ten) d2).


Require Import IFOL.Syntax.Signature.
Require Import IFOL.Syntax.Theory.

Require Import IFOL.Semantics.Signature.
Require Import IFOL.Semantics.Formula.

Definition theory_dom {S} (eval_S : sort_dom S) (sg : sig S)
  (eval_sig : sig_dom eval_S sg) (th : Theory sg) : Type :=
  forall i : carrier sg th, eval_Formula eval_S sg eval_sig nil tt
    (formula sg th i).


Require Import String List.
Require Import ExtLib.Data.HList.

Set Implicit Arguments.
Set Strict Implicit.

Inductive data T : (T -> Type) -> Type :=
| Inj   : forall X, Type -> data X
| Get   : forall X, T -> data X
| Prod  : forall X, data X -> data X -> data X
| Sigma : forall X (S : Type), (S -> data X) -> data X
| Pi    : forall X (S : Type), (S -> data X) -> data X.

Fixpoint dataD (T : Type) (X : T -> Type) (d : data X) : Type :=
  match d with
    | Inj _X x => x
    | Get X i => X i
    | Prod l r => prod (dataD l) (dataD r)
    | @Sigma _ _ i s => @sigT i (fun v => dataD (s v))
    | @Pi _ _ i s => forall v : i, dataD (s v)
  end.

(** Example of lists as data **)
Definition dataList (a : Type) : @data unit (fun _ => list a) :=
  @Sigma _ _ bool (fun x => match x with
                              | true => @Inj _ _ unit
                              | false => @Prod _ _ (Inj _ a) (Get _ tt)
                            end).

Theorem dataList_to_list : forall T (x : dataD (dataList T)), list T.
  simpl. intros.
  destruct x. destruct x.
  apply nil.
  simpl in *.
  apply (fst d :: snd d).
Defined.

Theorem list_to_dataList : forall T (ls : list T), dataD (dataList T).
  simpl. destruct 1.
  exists true. apply tt.
  exists false. apply (t, ls).
Defined.

Fixpoint dataP (T : Type) (X : T -> Type) (d : data X) (R : Type) : Type :=
  match d with
    | Inj _X x => x -> R
    | Get X x => X x -> R
    | @Prod _ _ l r => dataP l (dataP r R)
    | @Sigma _ _ i s => forall i, dataP (s i) R
    | @Pi _ _ i s => (forall i, dataD (s i)) -> R
  end.

Fixpoint dataMatch (T : Type) (X : T -> Type) (d : data X) {struct d}
  : forall (R : Type), dataP d R -> dataD d -> R :=
    match d as d return forall (R : Type), dataP d R -> dataD d -> R with
      | Inj _ _ => fun _ p => p
      | Get X x => fun _ p => p
      | @Prod _ _ l r => fun _ p v =>
        dataMatch r _ (dataMatch l _ p (fst v)) (snd v)
      | @Sigma _ _ i d => fun _ p v =>
        match v with
        | existT _ x y => dataMatch (d x) _ (p _) y
        end
      | @Pi _ _ i d => fun _ p v => p v
    end.

(* This used to work
(** You really need a fold! **)
Fixpoint dataLength {x} (l : list x) Z {struct l} : nat :=
  dataMatch (dataList x) _ (fun tag => match tag with
                                       | true => fun _ => 0
                                       | false => fun h t => S (Z t) (* (dataLength t) *)
                                       end) (list_to_dataList l).
*)


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal78.

Set Printing Depth 1000.
Definition lfind_eval  x n:=
Cons n x.

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))) (Cons (Succ Zero) Nil)) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ Zero) Nil))) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))) (Succ Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Nil) (Zero).


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import finfun bigop prime binomial ssralg finset fingroup finalg matrix.
Require Import Reals Fourier.
Require Import Reals_ext ssr_ext ssralg_ext log2 ln_facts Rssr Rbigop arg_rmax.
Require Import num_occ proba entropy types jtypes divergence conditional_divergence.
Require Import error_exponent channel_code channel success_decode_bound.

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

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

Section channel_coding_converse_intermediate_lemma.

Variables A B : finType.
Variable W : `Ch_1*(A, B).
Variable cap : R.
Hypothesis Hc : capacity W cap.

Variable minRate : R.
Hypothesis HminRate : minRate > cap.

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

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

Lemma channel_coding_converse_gen : exists Delta, 0 < Delta /\ forall n',
  let n := n'.+1 in forall (M : finType) (c : code A B M n), (0 < #|M|)%nat ->
    minRate <= CodeRate c ->
      scha(W, c) <= INR (n.+1)^(#|A| + #|A| * #|B|) * exp2 (- INR n * Delta).
Proof.
move: error_exponent_bound => /(_ _ _ Bnot0 W _ Hc _ HminRate); case => Delta [Delta_pos HDelta].
exists Delta; split => // n' n M c Mnot0 H.
apply (Rle_trans _ _ _ (success_bound W Mnot0 c)).
set Pmax := arg_rmax _ _ _.
set tc :=  _.-typed_code _.
rewrite pow_add -mulRA.
apply Rmult_le_compat_l; first by apply pow_le, pos_INR.
apply (Rle_trans _ _ _ (typed_success_bound W Mnot0 (Pmax.-typed_code c))).
apply Rmult_le_compat_l; first by apply pow_le, pos_INR.
set Vmax := arg_rmax _ _ _.
rewrite /success_factor_bound /exp_cdiv.
case : ifP => Hcase; last first.
  rewrite mul0R; by apply Rlt_le, exp2_pos.
rewrite -exp2_plus.
apply exp2_le_increasing.
rewrite -mulRDr 2!Ropp_mult_distr_l_reverse.
apply Ropp_le_contravar, Rmult_le_compat_l; first by apply pos_INR.
have {Hcase}Hcase : Vmax << W | Pmax.
  move=> a Hp b /eqP Hw.
  move/forallP : Hcase.
  by move/(_ a)/implyP/(_ Hp)/forallP/(_ b)/implyP/(_ Hw)/eqP.
apply (Rle_trans _ _ _ (HDelta Pmax Vmax Hcase)) => /=.
by apply Rplus_le_compat_l, Rle_max_compat_l, Rplus_le_compat_r.
Qed.

End channel_coding_converse_intermediate_lemma.

Section channel_coding_converse.

Variables A B : finType.
Variable W : `Ch_1*(A, B).
Variable cap : R.
Hypothesis w_cap : capacity W cap.

Variable epsilon : R.
Hypothesis eps_gt0 : 0 < epsilon.

Variable minRate : R.
Hypothesis minRate_cap : minRate > cap.

(** * Converse of the Channel Coding Theorem #<a name="label_channel_coding_converse"> </a># *)

Theorem channel_coding_converse : exists n0,
  forall n M (c : code A B M n),
    (0 < #|M|)%nat -> n0 < INR n -> minRate <= CodeRate c -> scha(W, c) < epsilon.
Proof.
case: (channel_coding_converse_gen w_cap minRate_cap) => Delta [Delta_pos HDelta].
pose K := (#|A| + #|A| * #|B|)%nat.
pose n0 := 2 ^ K * INR K.+1`! / ((Delta * ln 2) ^ K.+1) / epsilon.
exists n0 => n M c HM n0_n HminRate.
have Rlt0n : 0 < INR n.
  apply: (Rlt_trans _ _ _ _ n0_n).
  rewrite /n0.
  apply Rmult_lt_0_compat; last by apply Rinv_0_lt_compat.
  rewrite /Rdiv -mulRA.
  apply Rmult_lt_0_compat; first by apply pow_gt0; fourier.
  apply Rmult_lt_0_compat; first by apply lt_0_INR; apply /ltP; apply fact_gt0.
  apply Rinv_0_lt_compat, pow_gt0, Rmult_lt_0_compat => //; by apply ln_2_pos.
destruct n as [|n'].
  by apply Rlt_irrefl in Rlt0n.
set n := n'.+1.
apply (Rle_lt_trans _ (INR n.+1 ^ K * exp2 (- INR n * Delta))).
  by apply HDelta.
move: (n0_n) => /(Rmult_lt_compat_l (/ INR n) _) => /(_ (Rinv_0_lt_compat (INR n) Rlt0n)).
rewrite Rinv_l; last by apply not_eq_sym, Rlt_not_eq.
move/(Rmult_lt_compat_l epsilon _) => /(_ eps_gt0); rewrite mulR1 => H1'.
apply: (Rle_lt_trans _ _ _ _ H1') => {H1'}.
rewrite /n0 [in X in _ <= X]mulRC -2![in X in _ <= X]mulRA.
rewrite Rinv_l; last by apply not_eq_sym, Rlt_not_eq.
rewrite mulR1.
apply Rge_le; rewrite mulRC -2!mulRA; apply Rle_ge.
set aux := INR _ * (_ * _).
have aux_gt0 : 0 < aux.
  apply Rmult_lt_0_compat.
    apply lt_0_INR; apply/ltP; by apply fact_gt0.
  apply Rmult_lt_0_compat.
  apply Rinv_0_lt_compat, pow_gt0, Rmult_lt_0_compat => //; by apply ln_2_pos.
  by apply Rinv_0_lt_compat.
apply (Rle_trans _ ((INR n.+1 / INR n) ^ K * aux)); last first.
  apply Rmult_le_compat => //.
  - apply pow_ge0, Rle_mult_inv_pos => //; by apply pos_INR.
  - by apply Rlt_le.
  - apply pow_incr; split.
    + apply Rle_mult_inv_pos => //; by apply pos_INR.
    + apply Rmult_le_reg_r with (INR n) => //.
      rewrite /Rdiv -mulRA -Rinv_l_sym; last by apply not_eq_sym, Rlt_not_eq.
      rewrite mulR1 (_ : 2 = INR 2) // -mult_INR; apply le_INR.
      rewrite (_ : 0 = INR 0) // in Rlt0n.
      apply INR_lt in Rlt0n.
      rewrite multE mul2n -addnn -addn1.
      apply/leP.
      by rewrite leq_add2l.
  - by apply Rle_refl.
rewrite pow_mult -mulRA.
apply Rmult_le_compat.
- apply pow_ge0, Rlt_le, lt_0_INR; by apply/ltP.
- by apply Rlt_le, exp2_pos.
- by apply Rle_refl.
- apply Rle_inv_conv.
  + by apply exp2_pos.
  + apply Rmult_lt_0_compat; last by exact aux_gt0.
    rewrite pow_inv; last by apply not_eq_sym, Rlt_not_eq.
    by apply Rinv_0_lt_compat, pow_gt0.
  + rewrite -exp2_Ropp Ropp_mult_distr_l_reverse Ropp_involutive /exp2.
    have nDeltaln2 : 0 <= INR n * Delta * ln 2.
      apply Rmult_le_pos; last by apply Rlt_le, ln_2_pos.
      apply Rmult_le_pos; last by apply Rlt_le.
      by apply pos_INR.
    apply: (Rle_trans _ _ _ _ (exp_lb (K.+1) nDeltaln2)) => {nDeltaln2}.
    apply Req_le.
    rewrite Rinv_mult_distr; last 2 first.
      by apply not_eq_sym, Rlt_not_eq, pow_gt0, Rinv_0_lt_compat.
      by apply not_eq_sym, Rlt_not_eq.
    rewrite mulRC Rinv_mult_distr; last 2 first.
      apply not_eq_sym, Rlt_not_eq, lt_0_INR; apply/ltP; by apply fact_gt0.
      apply not_eq_sym, Rlt_not_eq, Rmult_lt_0_compat.
        apply Rinv_0_lt_compat, pow_gt0, Rmult_lt_0_compat => //; by apply ln_2_pos.
      by apply Rinv_0_lt_compat.
    rewrite -mulRA mulRC.
    rewrite Rinv_mult_distr; last 2 first.
    - apply not_eq_sym, Rlt_not_eq, Rinv_0_lt_compat, pow_gt0, Rmult_lt_0_compat => //; by apply ln_2_pos.
    - by apply not_eq_sym, Rlt_not_eq, Rinv_0_lt_compat.
    - rewrite Rinv_involutive ; last first.
        apply not_eq_sym, Rlt_not_eq, pow_gt0, Rmult_lt_0_compat => //; by apply ln_2_pos.
      rewrite Rinv_involutive; last by apply not_eq_sym, Rlt_not_eq.
      rewrite (_ : / (/ INR n) ^ K = (INR n) ^ K); last first.
        rewrite -pow_inv; last first.
          by apply Rinv_neq_0_compat, not_eq_sym, Rlt_not_eq.
        rewrite Rinv_involutive //.
        by apply not_eq_sym, Rlt_not_eq.
      rewrite /Rdiv; f_equal.
      rewrite !Rpow_mult_distr -(tech_pow_Rmult (INR n)).
      field.
Qed.

End channel_coding_converse.

Check channel_coding_converse.


(*** Coq coding by choukh, Aug 2022 ***)

Require Import Lib.
From Category.Instance Require Import Poset Ens Sets Zero One.
From Category.Algebra Require Import Monoid.
From Category.Construction Require Import Opposite.

(** 3 Important Kinds Of Categories **)
Section Ch3.

(** 3.1 Preorders **)
Import Relation_Definitions RelationClasses.

(* preorder *)
Check (@Proset : ∀ A (R : relation A), PreOrder R → Category).

(* partial order *)
Check (@Poset : ∀ C (R : relation obj[C]), PreOrder R → Asymmetric R → Category).

(** 3.2 The Category Of Sets **)

(* cat of setoids *)
Check (Sets : Category).

(* cat of coq types *)
Check (Coq : Category).

(** 3.4 The Category Of Graphs **)

(* Directed multigraphs with loops *)
(* kind of like 'categories' without id and comp. *)
Record Graph := {
  vertex :> Type;
  edge : Type;
  endpoint : bool → edge → vertex;
  source := endpoint true;
  target := endpoint false
}.
Arguments source {_}.
Arguments target {_}.

Record Graph_Morph (A B : Graph) := {
  αᵥ :> A → B;
  αₑ : edge A → edge B;
  source_morph e : source (αₑ e) = αᵥ (source e);
  target_morph e : target (αₑ e) = αᵥ (target e)
}.

Global Instance Graph_Morph_Setoid {A B} : Setoid (Graph_Morph A B).
Proof. construct.
  - intros F G. exact ((∀ x, F x = G x) ∧ ∀ e, F.(αₑ) e = G.(αₑ) e).
  - firstorder congruence.
Defined.

Import Setoid Category.

Program Definition Gph : Category := {|
  obj := Graph;
  hom := Graph_Morph;
  homset := @Graph_Morph_Setoid;
  id X := {| αᵥ x := x |};
  compose X Y Z f g := {| αᵥ := Basics.compose f g |};
|}.
Next Obligation. destruct f, g; auto. Defined.
Next Obligation. destruct f, g; simpl; congruence. Defined.
Next Obligation. destruct f, g; simpl; congruence. Defined.
Next Obligation.
  proper. congruence.
  destruct x0, y0, x1, y1. simpl in *. congruence.
Defined.
Next Obligation. destruct f; auto. Defined.
Next Obligation. destruct f; auto. Defined.
Next Obligation. destruct f, g, h; auto. Defined.
Next Obligation. destruct f, g, h; auto. Defined.

(** 3.5 Monoids **)

(* empty cat *)
Check (_0 : Category).

(* one object one arrow cat *)
Check (_1 : Category).

(* one object many arrows cat *)

Variable A : Type.
Hypothesis setoid_A : Setoid A.
Hypothesis monoid_A : @Monoid A setoid_A.

Definition monoid : Category := {|
  obj := unit;
  hom _ _ := A;
  homset _ _ := setoid_A;
  id _ := mempty;
  compose _ _ _ := mappend;
  compose_respects _ _ _ := mappend_respects;
  id_left _ _ := mempty_left;
  id_right _ _ := mempty_right;
  comp_assoc _ _ _ _ f g h := symmetry (mon_assoc f g h);
  comp_assoc_sym _ _ _ _ := mon_assoc;
|}.

(** 3.6 Duality **)

Check (Opposite : Category → Category).

(* opposite involution *)
Check (@op_invol : ∀ C : Category, C^op^op = C).

End Ch3.


From stdpp Require Import base gmultiset fin_sets.
From Coq Require Import ssreflect.

(* 공집합이 아닌 집합은 크기가 0보다 크다는 보조정리  *)
Lemma non_empty_pos (X : gmultiset nat) n :
  n ∈ X → size X > 0.
Proof.
  intros. assert (size X ≠ 0); [|lia].
  apply gmultiset_size_non_empty_iff. multiset_solver.
Qed.

Lemma gm_size_singleton_inv (X : gmultiset nat) n m :
  size X = 1 →
  n ∈ X → m ∈ X  →
  n = m.
Proof.
  intros HX n_in m_in.
  apply (gmultiset_disj_union_difference' m),(f_equal size) in m_in.
  rewrite HX gmultiset_size_disj_union gmultiset_size_singleton in m_in.
  assert (X ∖ {[+ m +]} = ∅) as Hm_empty.
  { apply gmultiset_size_empty_iff. lia. }
  assert (X = {[+ m +]}) as -> by multiset_solver.
  by apply gmultiset_elem_of_singleton.
Qed.

Lemma one_gmultiset_not_empty (X : gmultiset nat) n :
  size X > 1 → n ∈ X → X ∖ {[+ n +]} ≠ ∅.
Proof.
  intros.
  rewrite -gmultiset_size_empty_iff gmultiset_size_difference; [multiset_solver|].
  rewrite gmultiset_size_singleton. lia.
Qed.

Lemma apply_induction (P : gmultiset nat) p s P' :
  (∀ (m n : nat) (P : gmultiset nat),
    P ≠ ∅ → m ∈ P → n ∈ P → s = size P → n = m) →
  s > 0 →
  S s = size P →
  p ∈ P →
  P' = P ∖ {[+ p +]} →
  ∃ m, ∀ (n : nat), n ∈ P' → n = m.
Proof.
  intros IHs' ?? p_in HP'.
  assert (s = size P').
  { apply (f_equal size) in HP'. rewrite gmultiset_size_difference in HP'; [multiset_solver|].
    rewrite gmultiset_size_singleton in HP'. lia.
  }
  destruct (gmultiset_choose P') as [m m_in].
  { apply gmultiset_size_non_empty_iff. lia. }
  exists m. intros n n_in. apply (IHs' m n P'); [multiset_solver|done..].
Qed.

Lemma fake_set_eq (P : gmultiset nat) n :
    P ≠ ∅ → ∃ m, n ∈ P → n = m.
Proof.
  intros NotEmpty.
  destruct (gmultiset_choose P) as [m m_in]; [done|].
  exists m.
  (* n ∈ X라는 사실과 귀납변수가 될 집합의 크기 m을 소개. *)
  intro n_in. remember (size P) as N eqn:HN.
  (* 보조정리로 크기가 0보다 크다는 사실을 암. *)
  assert (N > 0) as N_pos by (subst N; by apply (non_empty_pos P n)).
  (* 올바른 induction hypothesis을 얻기 위한 작업. *)
  generalize dependent P. generalize dependent n. generalize dependent m.
  (* 귀납 시작. *)
  induction N as [|N' IHN'].
  - (* Base Case. Vacuously true. *)
    inversion N_pos.
  - (* Inductive Case. *)
    (* 우선 N = 1일때를 해결하자. *)
    destruct (decide (N' = 0)) as [->|Gt]; intros m n P NotEmpy m_in n_in HN'.
    { apply (gm_size_singleton_inv P n m); [lia|done..]. }
    (* 그럼 N > 1이다. *)
    assert (N' > 0) as Pos by lia;
    specialize (IHN' Pos). clear Pos N_pos.

    (* 우선 p1을 얻기 위해 공집합이 아님을 보임 *)
    assert (P ≠ ∅) as NotEmpty.
    { (* 자명함. *) multiset_solver. }
    (* p1 얻기 성공! *)
    apply gmultiset_choose in NotEmpty;
    destruct NotEmpty as [p1 p1_in].
    (* [P ∖ {[+ p1 +]}]에 대해 IHs' 적용. *)
    remember (P ∖ {[+ p1 +]}) as P1 eqn:HP1.
    assert (∃ m1, ∀ (n1 : nat), n1 ∈ P1 → n1 = m1) as P1_all_same.
    { apply (apply_induction P p1 N'); auto with lia. }

    (* 이제 다른 원소 p2를 얻어야함 *)
    assert (P ∖ {[+ p1 +]} ≠ ∅) as NotEmpty.
    { (* 크기가 1보다 크니 자명함. *) apply (one_gmultiset_not_empty P p1); [lia|done]. }
    (* p2 얻기 성공! *)
    apply gmultiset_choose in NotEmpty;
    destruct NotEmpty as [p2 p2_in].

    (* [P ∖ {[+ p2 +]}]에 대해 IHs' 적용. *)
    remember (P ∖ {[+ p2 +]}) as P2 eqn:HP2.
    assert (∃ m2, ∀ (n2 : nat), n2 ∈ P2 → n2 = m2) as P2_all_same.
    { apply (apply_induction P p2 N'); auto with lia. multiset_solver. }

    (* 교집합에서 원소가 있음을 보이기 위해, 교집합이 공집합이 아님을 증명해보자... *)
    assert (P1 ∩ P2 ≠ ∅) as NonEmpty.
    { subst.
      (* 여태까지와 같이 크기를 사용하자. *)
      apply gmultiset_size_non_empty_iff.
      (* 크기가... 0일수가 있네...? *)
      admit.
    }
Abort.


(* This file defines nat_cast, an alternative to eq_rect which works only for type nat instead
   of any type A.
   The motivation behind nat_cast is that it only matches on proofs in contradictory cases,
   so functions using nat_cast can always be run inside Coq using cbv, whereas function using
   eq_rect cannot. *)

Arguments id {A} x.

(* Transport equality, only matching on eq_refl in contradictory cases, to make sure
   terms using this function reduce *)
Fixpoint nat_cast (P : nat -> Type) {n m} : n = m -> P n -> P m.
  refine match n, m return n = m -> P n -> P m with
         | O, O => fun _ => id
         | S n, S m => fun pf => @nat_cast (fun n => P (S n)) n m (f_equal pred pf)
         | _, _ => fun pf => match _ pf : False with end
         end;
    clear; abstract congruence.
Defined. (* thx Jason *)

Lemma nat_cast_eq_rect: forall (P : nat -> Type),
  forall (n m : nat)  (e: n = m) (pn: P n),
  nat_cast P e pn = eq_rect n P pn m e.
Proof.
  destruct e.
  revert dependent P; induction n; simpl; intros.
  - reflexivity.
  - rewrite IHn. reflexivity.
Qed. (* thx Clement *)

Lemma nat_cast_proof_irrel: forall (P : nat -> Type),
  forall (n m : nat)  (e1 e2: n = m) (pn: P n),
  nat_cast P e1 pn = nat_cast P e2 pn.
Proof.
  destruct e1.
  revert dependent P; induction n; simpl; intros.
  - reflexivity.
  - erewrite IHn. reflexivity.
Qed.

Lemma nat_cast_same: forall (P: nat -> Type) (s: nat) (n: P s),
  nat_cast P eq_refl n = n.
Proof.
  intros. rewrite nat_cast_eq_rect. reflexivity.
Qed.

Lemma nat_cast_fuse: forall (P: nat -> Type) (n1 n2 n3: nat) (e12: n1 = n2) (e23: n2 = n3) (x: P n1),
  nat_cast P e23 (nat_cast P e12 x) = nat_cast P (eq_trans e12 e23) x.
Proof.
  destruct e12.
  destruct e23.
  intros.
  rewrite nat_cast_same.
  reflexivity.
Qed.

Lemma nat_cast_cast ni no (pf: ni = no) (P: nat -> Type) (x : P ni):
  nat_cast P pf x = match pf in _ = Y return P Y with
                    | eq_refl => x
                    end.
Proof.
  destruct pf.
  rewrite nat_cast_same.
  auto.
Qed.


(*
Goal forall (P Q R S : Prop), (S /\ P) /\ (Q /\ R) -> (P /\ S) /\ (R /\ Q).
  intros.
  destruct H.
  split.
  destruct H0.
 *)

Goal forall (P Q R S : Prop), (S /\ P) /\ (Q /\ R) -> (P /\ S) /\ (R /\ Q).
  intros.
  destruct H.
  assert (forall (X Y : Prop), X /\ Y -> Y /\ X).
  intros.
  destruct H1.
  split.
  apply H2.
  apply H1.
  split.
  apply (H1 S P H).
  apply (H1 Q R H0).
Qed.

Goal forall (P Q R S : Prop), (S /\ P) /\ (Q /\ R) -> (P /\ S) /\ (R /\ Q).
  intros.
  destruct H.
  cut (forall (X Y : Prop), X /\ Y -> Y /\ X).
  intro.
  split.
  apply (H1 S P).
  apply H.
  apply (H1 Q R).
  apply H0.
  intros.
  destruct H1.
  split.
  apply H2.
  apply H1.
Qed.

Require Import List.
Theorem app_eq_nil : forall (A : Type)(l l' : list A), l ++ l' = nil -> l = nil /\ l' = nil.
  intros.
  split.
  destruct l.
  reflexivity.
  discriminate.
  destruct l'.
  reflexivity.
  destruct l.
  discriminate.
  discriminate.
Qed.

Require Import List.
Goal forall (A : Type)(a : A), nil <> a :: nil.
  discriminate.
Qed.

Goal forall (n m : nat)(f : nat -> nat), f n = n -> S (f (f n)) = S m -> n = m.
  intros.
  congruence.
Qed.

Goal forall (A : Type)(x y : A), x :: y :: nil <> x :: nil.
  intros.
  congruence.
Qed.

(*
Require Import Arith.
Goal forall (P Q : nat -> Prop)(a : nat), P (a * 2) \/ Q (a * 2).
  intros.
  (*rewrite mult_comm.*)
  replace (Q (a * 2)) with (Q (2 * a)).
  simpl.
 *)

(*
Require Import List.
Lemma removelast_app : forall (A : Type)(l l' : list A), l' <> nil -> removelast (l ++ l') = l ++ removelast l'.
  intros.
  induction l.
  reflexivity.
  simpl.
  destruct (l ++ l').
  remember (l ++ l').
  destruct l0.
  apply False_ind.
  apply H.
  destruct (app_eq_nil l l').
  rewrite Heql0.
  reflexivity.
  apply H1.
  f_equal.
  apply IHl.
 *)

Require Import List.
Inductive InList (A : Type)(a : A) : list A -> Prop :=
  | headIL : forall xs, InList A a (a :: xs)
  | consIL : forall x xs, InList A a xs -> InList A a (x :: xs).

Goal forall (A : Type)(l : list A)(a a' : A), InList A a (a' :: l) -> a = a' \/ InList A a l.
  intros.
  inversion H.
  left.
  reflexivity.
  right.
  apply H1.
Qed.
(*
Goal forall (n : nat), (exists m, n = 2 * m) \/ (exists m, n = 2 * m + 1).
  intros.
  left.
  exists n.
  induction n.
    reflexivity.
    simpl.
    f_equal.
    inversion IHn.
      f_equal.
      intros.
      simpl.
  *)

(*
Require Import Omega.
Goal forall (n : nat), (exists m, n = 2 * m) \/ (exists m, n = 2 * m + 1).
  intros.
  constructor.
  exists n.
  induction n.
  simpl.
  omega.
  simpl.
  induction n.
  simpl.
  apply False_ind.
 *)

(*
Goal forall (A : Type)(l m:list A) (a:A), InList A a (l ++ m) -> InList A a l \/ InList A a m.
  intros.
  left.
  destruct l.
 *)


From Nominal Require Export Group Swap Permutation.

(* Permutation Type *)
Class PermAction X := action: Perm → X → X.
#[export] Hint Mode PermAction ! : typeclass_instances.

(* CAUSA PROBLEMAS COM REESCRITA ENVOLVENDO action (- p)
  Instance: Params (@action) 2 := {}. *)

Infix "•" := action (at level 60, right associativity): nominal_scope.
Notation "(•)" := action (only parsing): nominal_scope.
Notation "(• x )" := (action x) (only parsing): nominal_scope.
Notation "( x •)" := (λ y, action y x) (only parsing): nominal_scope.

(* Permutation type is a type with a permutation group (left) action *)
Class PermT (X : Type) `{Act: PermAction X, Equiv X}: Prop := {
  gact_setoid :> Equivalence(≡@{X});
  gact_proper :> Proper ((≡@{Perm}) ==> (≡@{X}) ==> (≡@{X})) (•);

  gact_id: ∀ (x: X), ɛ • x ≡@{X} x;
  gact_compat: ∀ (p q: Perm) (x: X), p • (q • x) ≡@{X} (q + p) • x
}.

#[export] Hint Mode PermT ! - - : typeclass_instances.
#[export] Existing Instance gact_setoid.
#[export] Existing Instance gact_proper.

(* Arguments gact_id {_ _ _ _ _ Grp _ _ _ GAct} : rename.
Arguments gact_compat {_ _ _ _ _ Grp _ _ _ GAct} : rename.
Arguments gact_proper {_ _ _ _ _ Grp _ _ _ GAct} : rename. *)

Section PermTypeProperties.
  Context `{PermT X}.

  Corollary perm_left_inv (x: X) p: (-p) • p • x ≡ x.
  Proof. rewrite gact_compat, grp_right_inv, gact_id; auto. Qed.

  Corollary perm_rigth_inv (x: X) p: p • (-p) • x ≡ x.
  Proof. rewrite gact_compat, grp_left_inv, gact_id; auto. Qed.

  Lemma perm_iff (x y: X) p: p • x ≡ y ↔ x ≡ (-p) • y.
  Proof. split; intros A;
    [rewrite <-A, perm_left_inv | rewrite A, perm_rigth_inv]; auto.
  Qed.

  Lemma perm_inj (x y: X) p: p • x ≡ p • y ↔ x ≡ y.
  Proof. split; intros A;
    [apply perm_iff in A; rewrite <-(perm_left_inv y p) | rewrite A]; auto.
  Qed.

  Lemma perm_inv_empty_act (x: X): (-ɛ) • x ≡ x.
  Proof. rewrite grp_inv_neutral; apply gact_id. Qed.

  Lemma perm_action_duplicate a b (x: X): ⟨a,b⟩ • ⟨a,b⟩ • x ≡ x.
  Proof. rewrite gact_compat, perm_duplicate; apply gact_id. Qed.

  Lemma perm_action_equal a (x: X): ⟨a,a⟩ • x ≡ x.
  Proof. rewrite perm_equiv_neutral; apply gact_id. Qed.

  Lemma perm_comm a b p (x: X): a ∉ perm_dom p → b ∉ perm_dom p → ⟨a,b⟩ • p • x ≡ p • ⟨a,b⟩ • x.
  Proof. intros; rewrite gact_compat, <-perm_notin_dom_comm, <-gact_compat; auto. Qed.

  Lemma perm_swap_distr a b p (x: X): p • ⟨a,b⟩ • x ≡ ⟨perm_swap p a, perm_swap p b⟩ • p • x.
  Proof. rewrite 2gact_compat, perm_comm_distr; auto. Qed.
End PermTypeProperties.

(* #[global] Instance action_perm_proper `{Perm A}: Proper ((≡@{perm}) ⟹ (≡@{A}) ⟹ (≡@{A})) action.
Proof. apply gact_proper. Qed. *)


Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.

Theorem plus_1_neq_0 : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  - reflexivity.
  - reflexivity. Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b eqn:E.
  - reflexivity.
  - reflexivity. Qed.

Theorem plus_1_neq_0' : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    + reflexivity.
    + reflexivity.
  - destruct c eqn:Ec.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb_commutative'' :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros [] c H.
  apply H. discriminate H.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros [| n] .
  - reflexivity.
  - reflexivity.
Qed.

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

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f x b.
  rewrite -> x.
  rewrite -> x.
  reflexivity.
Qed.

From Coq Require Export String.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition manual_grade_for_negation_fn_applied_twice : option (nat*string) := None.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f x b.
  rewrite -> x.
  rewrite -> x.
  destruct b eqn:Eb.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros b c.
  destruct b eqn:Eb.
     - destruct c eqn:Ec.
     reflexivity.
     discriminate.
     - destruct c eqn:Ec.
     discriminate.
     reflexivity.
Qed.

Theorem andb_eq_orb' :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros a b H.
  destruct a.
  rewrite <- (andb_true_elim2 true b).
  reflexivity.
  apply H.
  apply H.
Qed.

Inductive bin : Type :=
  | Z
  | A (n : bin)
  | B (n : bin).

Fixpoint incr (m:bin) : bin :=
  match m with
  | Z => B Z
  | B m' => A ( incr m')
  | A m' => B m'
  end.

Example test_inc1: (incr Z) = B Z.
Proof. simpl. reflexivity. Qed.
Example test_inc2: (incr (B Z)) = A (B Z).
Proof. simpl. reflexivity. Qed.
Example test_inc3: (incr (A (B (B Z)))) = B (B (B Z)).
Proof. simpl. reflexivity. Qed.
Example test_inc4: (incr (B (B (B Z)))) = A(A (A (B Z))).
Proof. simpl. reflexivity. Qed.


From Undecidability.L Require Export L Encodings Interpreter Choose.

(** * Results obtained with self-interpreters *)

(** ** Step-indexed self-interpreter *)

(** *** Encoding of options *)

Definition none : term := .\"s", "n"; "n".
Definition some : term := .\"t", "s", "n"; "s" "t".

Hint Unfold some none : cbv.

Definition oenc t :=
  match t with
  | Some t => lambda(lambda (1 (tenc t)))
  | None => none
  end.

Lemma oenc_cls s: closed (oenc s).
Proof.
  destruct s; simpl; value.
Qed.

Lemma oenc_lambda s: lam (oenc s).
Proof.
  destruct s; simpl; value.
Qed.

Hint Resolve oenc_cls oenc_lambda: cbv.

Lemma some_correct s : some (tenc s) ≡ oenc (Some s).
Proof.
  solveeq.
Qed.

Lemma some_correct_r s t t' : proc t -> proc t' -> oenc (Some s) t t' ≡ t (tenc s).
Proof.
  intros. solveeq.
Qed.

Lemma none_correct s t : proc s -> proc t  -> none s t ≡ t.
Proof.
  intros. solveeq.
Qed.

Lemma oenc_correct_some s v : lam v -> oenc (Some s) ≡ some v -> v ≡ tenc s.
Proof.
  intros lam_v H.
  symmetry in H. eapply eqTrans with (s := lambda(lambda(1 v))) in H. eapply unique_normal_forms in H; value. inv H. reflexivity.
  symmetry; clear H; solvered.
Qed.

Lemma oenc_inj o1 o2 : oenc o1 ≡ oenc o2 -> o1 = o2.
Proof.
  intros H; eapply unique_normal_forms in H; value.
  destruct o1, o2; try congruence; cbn in H; repeat inv H.
  eapply tenc_injective in H1. now subst.
Qed.

Lemma none_equiv_some v : ~ oenc None ≡ some v.
Proof.
  intros H. assert (eva v) as (w & [Hw Hl] % evaluates_equiv) by (eapply app_eva; eexists (oenc None); eapply evaluates_equiv; split; value; eauto using equiv).
  rewrite Hw in H. symmetry in H. eapply eqTrans with (s := (lambda (lambda (1 w)))) in H.
  eapply unique_normal_forms in H; value. inv H. symmetry. unfold some. clear H. solvered.
Qed.

(** *** Equality of encoded natural numbers *)
Definition EqN := rho (.\"EqN", "n", "m"; "n" ("m" !T !(lambda F)) (.\"n"; "m" !F (.\"m"; "EqN" "n" "m"))).

Hint Unfold EqN: cbv.

Lemma EqN_correct m n : EqN (enc m) (enc n) ≡ benc (Nat.eqb m n).
Proof with eauto.
  revert n; induction m; intros.
  - destruct n. repeat redL. repeat redL.
  - destruct n.
    + repeat redL.
    + transitivity (EqN (enc m) (enc n)). repeat redL. now rewrite IHm.
Qed.

(** *** Substitution *)

Definition Subst := rho (.\ "Subst", "s", "k", "u"; "s" (.\"n"; !EqN "n" "k" "u" (!Var "n"))
                                                     (.\"s1", "s2"; !App ("Subst" "s1" "k" "u") ("Subst" "s2" "k" "u"))
                                                     (.\"s1"; !Lam ("Subst" "s1" (!Succ "k") "u")) ).

Hint Unfold Subst : cbv.

Lemma Subst_correct s k u :
  Subst (tenc s) (enc k) (tenc u) ≡ tenc (subst s k u).
Proof.
  revert k; induction s; intros k.
  - transitivity (EqN (enc n) (enc k) (tenc u) (Var (enc n))). solveeq.
    rewrite EqN_correct.
    destruct (Nat.eqb_spec n k); cbn; decide (n = k); try congruence; solveeq.
  - specialize (IHs1 k). specialize (IHs2 k). solveeq.
  - transitivity (Lam (((Subst (tenc s)) (Succ (enc k))) (tenc u))). solveeq.
    rewrite Succ_correct, IHs;value. solveeq.
Qed.

(** *** Step-indexed self-interpreter *)

Definition E := Eval cbv in
                 rho (.\ "Eval","n","u";"u"
                   (.\"";!none)
                   (.\"s","t"; "n" !none
                                   (.\"n"; "Eval" "n" "s"
                                           (.\"s"; "Eval" "n" "t"
                                                 (.\"t"; "s"
                                                           (.\""; !none)
                                                           (.\"",""; !none)
                                                           (.\"s"; "Eval" "n" (!Subst "s" !Zero "t")))
                                                 !none)
                                           !none))
                   (.\"s"; !some (!Lam "s"))).

Definition cLam s := lambda(lambda(lambda(0 s))).
Hint Unfold cLam : cbv.

Lemma E_rec_app_Sn_1 s t n s1 t1 :
   proc s1 ->
   proc t1 ->
   E (enc n) (tenc s) ≡ some (cLam s1) ->
   E (enc n) (tenc t) ≡ some (cLam t1) ->
   E (enc (S n)) (tenc (app s t)) ≡ E (enc n) (Subst s1 Zero (cLam t1)).
Proof.
  intros. solveeq.
Qed.

Lemma E_rec_app_Sn_2 s t n : E (enc n) (tenc s) ≡ none -> E (enc (S n)) (tenc (s t)) ≡ none.
Proof.
  intros H. solveeq.
Qed.

Lemma E_rec_app_Sn_3 s t n t1 : proc t1
                                   -> E (enc n) (tenc s) ≡ some (cLam t1)
                                   -> E (enc n) (tenc t) ≡ none
                                   -> E (enc (S n)) (tenc (s t)) ≡ none.
Proof.
  intros [clsT1 lamT1] Hs Ht. solveeq.
Qed.

Lemma E_correct k s : E (enc k) (tenc s) ≡ oenc (eval k s).
Proof with value.
  revert s; induction k; intros s.
  - destruct s; solveeq.
  - destruct s.
    + solveeq.
    + destruct (eval k s1) eqn:Hs1.
      * destruct (eval_lambda Hs1); subst t. {
        destruct (eval k s2) eqn:Hs2.
        - destruct (eval_lambda Hs2); subst t.
          eapply eqTrans.
          eapply E_rec_app_Sn_1 with (s1 := tenc x) (t1 := tenc ( x0));
            eauto with cbv...
          rewrite IHk, Hs1. symmetry. solveeq.
          rewrite IHk, Hs2. symmetry. solveeq.
          assert (Subst (tenc x) Zero (tenc (lambda x0)) ≡ tenc (subst x 0 (lambda x0))).
          change Zero with (enc 0). eapply Subst_correct.
          rewrite H, IHk. simpl. now rewrite Hs1, Hs2.
       -  rewrite E_rec_app_Sn_3 with (t1 := tenc x); eauto with cbv...
          simpl. rewrite Hs1, Hs2. reflexivity.
          rewrite IHk. rewrite Hs1. symmetry. solveeq.
          rewrite IHk. rewrite Hs2. symmetry. solveeq.
        }
      * simpl. rewrite Hs1. eapply E_rec_app_Sn_2.
        change none with (oenc (None)). rewrite <- Hs1. eapply IHk.
    + solveeq.
Qed.

Lemma E_S n s t : E (enc n) (tenc s) ▷ oenc (Some t) -> E (enc (S n)) (tenc s) ▷ oenc (Some t).
Proof.
  rewrite !E_correct. intros [? % oenc_inj ?] % evaluates_equiv; value.
  erewrite eval_S; eauto using evaluates.
Qed.

Lemma E_sound n s : E (enc n) (tenc s) ▷ oenc (None) \/ exists t, E (enc n) (tenc s) ▷ oenc (Some t) /\ s ▷ t.
Proof.
  destruct (eval n s) eqn:Eq.
  - right. exists t. rewrite E_correct, Eq. eauto using evaluates, eval_evaluates.
  - left. rewrite E_correct, Eq. econstructor.
Qed.

Lemma E_complete s t : s ▷ t -> exists n, E (enc n) (tenc s) ▷ oenc (Some t).
Proof.
  intros [n H] % evaluates_eval. exists n. rewrite E_correct, H. econstructor.
Qed.

(** ** Class of total procedures is unrecognisable *)

Require Import DecidableRecognisable Rice.

Lemma totality : ~ recognisable (fun s => proc s /\ forall t, eva(s (tenc t))).
Proof.
  pose (f := fun s : term => lambda (0 (lambda (E 0 (tenc (s (tenc s))) D I)) F I)).
  pose (v := lambda (Lam (App (App (App (tenc 0) (Lam (App (App (App (App (tenc E) (tenc 0)) (Q (App 0 (Q 0)))) (tenc D)) (tenc I)))) (tenc F)) (tenc I)))).

  eapply (@Reduction _ f v).
  - value.
  - intros.
    assert (forall t, f s (tenc t) ≡ (tenc t) (lambda (E 0 (tenc (s (tenc s))) D I)) F I) by (intros; solveeq).
    intuition.
    + eapply eva_Omega.
      destruct H2 as [s' [n H2] % evaluates_eval].
      specialize (H4 n).
      rewrite H0 in H4.
      eapply eva_proper; try eassumption. symmetry.
      transitivity (E (enc n) (tenc (s (tenc s))) D I). solveeq.
      rewrite E_correct, H2. solveeq.
    + value.
    + destruct t.
      * destruct (eval n (s (tenc s))) eqn:Hs.
        -- destruct H1. exists t. firstorder using eval_evaluates.
        -- rewrite H0. eapply eva_proper.
           transitivity (E (enc n) (tenc (s (tenc s))) D I). solveeq.
           rewrite E_correct, Hs. transitivity I. solveeq. reflexivity.
           exists I; repeat econstructor.
      * exists (tenc t2). solveeq.
      * exists (tenc t). solveeq.
  - intros s.
    transitivity (Lam (App (App (App (tenc 0) (Lam (App (App (App (App (tenc E) (tenc 0)) (Q (App (tenc s) (Q (tenc s))))) (tenc D)) (tenc I)))) (tenc F)) (tenc I))). solveeq.
    now rewrite Q_correct, !App_correct, Q_correct, !App_correct, Lam_correct, !App_correct, Lam_correct.
Qed.

Theorem totality_hard : ~ recognisable (fun s => forall t, pi s t) /\ ~ recognisable (fun s => ~ forall t, pi s t).
Proof.
  split.
  - intros H. eapply totality.
    eapply recognisable_intersection; eauto. eapply dec_recognisable, decidable_proc.
  - eapply rec_total.
Qed.

(** ** Self-interpreter *)

Definition H s : term := Eval cbv in (.\ "y"; !E "y" !s !(lambda T) !F).
Definition U : term := Eval cbv in .\ "x"; !E !(C (H 1)) "x" !I !I.

Lemma U_rec s : U (tenc s) ≡ E (C (H (tenc s))) (tenc s) I I.
Proof.
  solvered.
Qed.

Lemma H_test s : test (H (tenc s)).
Proof.
  intros n.
  assert ((lambda (E 0 (tenc s) (lambda T) F)) (enc n) ≡ E (enc n) (tenc s) (lambda T) F) by solveeq.
  destruct (eval n s) eqn:Eq; [ left | right]; rewrite H0, E_correct, Eq; solveeq.
Qed.

Lemma H_inv n s : satis ( H (tenc s) ) n -> eval n s <> None.
Proof.
  intros. destruct (eval n s) eqn:Eq.
  - congruence.
  - exfalso.
    assert (H (tenc s) (enc n) ≡ E (enc n) (tenc s) (lambda T) F) by solvered. unfold satis in H0.
    rewrite H1, E_correct, Eq, none_correct in H0; value. inv H0.
Qed.

Lemma H_proc s : proc (H (tenc s)).
Proof.
  value.
Qed.

Lemma U_complete s t : s ▷ t -> U (tenc s) ▷ tenc t.
Proof.
  intros [n H0] % evaluates_eval.
  rewrite U_rec. edestruct (C_complete (n := n) (H_proc s) (H_test s)) as [? []].
  - eapply evaluates_equiv; split; value.
    transitivity ( E (enc n) (tenc s) (lambda T) F). cbn. solveeq.
    rewrite E_correct, H0. solveeq.
  - assert ((lambda (E 0 (tenc s) (lambda T) F)) (enc x) ≡ E (enc x) (tenc s) (lambda T) F) by solveeq.
    unfold satis in H2. eapply H_inv in H2.
    destruct (eval x s) eqn:Eq.
    + enough (t = t0). subst. rewrite H1, E_correct, Eq. solveeq.
      eapply eval_evaluates, evaluates_equiv in H0.  eapply eval_evaluates, evaluates_equiv in Eq.
      eapply unique_normal_forms; firstorder. now rewrite <- H0, <- H4.
    + congruence.
Qed.

Lemma U_sound s : eva (U (tenc s)) -> eva s.
Proof with eauto.
  rewrite U_rec. intros H0.
  assert (eva (C (H (tenc s)))) by
      now eapply app_eva in H0 as [[[H % app_eva ?] %app_eva ?] %app_eva ?].
  eapply C_sound in H1 as [n H1 % H_inv].
  destruct (eval n s) eqn:Eq; try congruence. eapply eval_evaluates in Eq. firstorder. value.
  eapply H_test.
Qed.

Lemma U_eva s : eva s <-> eva (U (tenc s)).
Proof.
  split.
  - intros [v Hv % U_complete]. eauto.
  - eauto using U_sound.
Qed.

Lemma recognisable_eva : recognisable eva.
Proof.
  exists U. split; value. intros. now rewrite U_eva.
Qed.


(** * Example on monoids. *)
(** Gianluca Amato,  Marco Maggesi, Cosimo Perini Brogi 2019-2021 *)
(**
This file contains the definition of the signature of monoids and the way to turn
a monoid (as defined in [UniMath.Algebra.Monoids]) into an algebra.
*)

Require Import UniMath.MoreFoundations.Notations.
Require Import UniMath.Combinatorics.StandardFiniteSets.
Require Import UniMath.Algebra.Monoids.

Require Import UniMath.Algebra.Universal.EqAlgebras.

Local Open Scope stn.

(** Signature. *)

Definition monoid_signature := make_signature_simple_single_sorted [2; 0].

(** Algebra of monoids without equations. *)

Definition monoid_algebra (M: monoid)
  : algebra monoid_signature
  := make_algebra_simple_single_sorted monoid_signature M
  [(
    λ p, op (pr1 p) (pr12 p) ;
    λ _, unel M
  )].

Module Eqspec.

(** Free algebra of open terms. *)

Definition monoid_varspec : varspec monoid_signature
  := make_varspec monoid_signature natset (λ _, tt).

Definition Mon : UU := term monoid_signature monoid_varspec tt.
Definition mul : Mon → Mon → Mon := build_term_curried (●0: names monoid_signature).
Definition id  : Mon := build_term_curried (●1: names monoid_signature).

Definition x : Mon := varterm (0: monoid_varspec).
Definition y : Mon := varterm (1: monoid_varspec).
Definition z : Mon := varterm (2: monoid_varspec).

Definition monoid_equation : UU
  := equation monoid_signature monoid_varspec.

Definition monoid_mul_assoc : monoid_equation :=
  tt,, make_dirprod (mul (mul x y) z) (mul x (mul y z)).

Definition monoid_mul_lid : monoid_equation
  := tt,, make_dirprod (mul id x) x.

Definition monoid_mul_rid : monoid_equation
  := tt,, make_dirprod (mul x id) x.

Definition monoid_axioms : eqsystem monoid_signature monoid_varspec
  := ⟦ 3 ⟧,, three_rec monoid_mul_assoc monoid_mul_lid monoid_mul_rid.

Definition monoid_eqspec : eqspec.
Proof.
  use tpair. { exact monoid_signature. }
  use tpair. { exact monoid_varspec. }
  exact monoid_axioms.
Defined.

Definition monoid_eqalgebra := eqalgebra monoid_eqspec.

(** Every monoid is a monoid eqalgebra. *)

Section Make_Monoid_Eqalgebra.

Variable M : monoid.

Lemma holds_monoid_mul_lid : holds (monoid_algebra M) monoid_mul_lid.
Proof.
  intro. cbn in α.
  change (fromterm (ops (monoid_algebra M)) α tt (mul id x) = α 0).
  change (op (unel M) (α 0) = α 0).
  apply lunax.
Qed.

Lemma holds_monoid_mul_rid : holds (monoid_algebra M) monoid_mul_rid.
Proof.
  intro.
  change (op (α 0) (unel M) = α 0).
  apply runax.
Qed.

Lemma holds_monoid_mul_assoc : holds (monoid_algebra M) monoid_mul_assoc.
Proof.
  intro.
  change (op (op (α 0) (α 1)) (α 2) = op (α 0) (op (α 1) (α 2))).
  apply assocax.
Qed.

Definition is_eqalgebra_monoid :
  is_eqalgebra (σ := monoid_eqspec) (monoid_algebra M).
Proof.
  red. simpl.
  apply three_rec_dep; cbn.
  - exact holds_monoid_mul_assoc.
  - exact holds_monoid_mul_lid.
  - exact holds_monoid_mul_rid.
Defined.

Definition make_monoid_eqalgebra : monoid_eqalgebra.
  use make_eqalgebra.
  - exact (monoid_algebra M).
  - exact is_eqalgebra_monoid.
Defined.

End Make_Monoid_Eqalgebra.

End Eqspec.


Require Import List Lia.
Import ListNotations.

Require Import Undecidability.PCP.PCP.

Set Implicit Arguments.
Unset Strict Implicit.

Set Default Proof Using "Type".

Module PCPListNotation.
Notation "x 'el' A" := (In x A) (at level 70).
Notation "A <<= B" := (incl A B) (at level 70).
Notation "| A |" := (length A) (at level 65).
End PCPListNotation.

Import PCPListNotation.

Ltac inv H := inversion H; subst; try clear H.

(* *Some basic things concerning lists *)

Lemma list_prefix_inv X (a : X) x u y v :
  ~ a el x -> ~ a el u -> x ++ a :: y = u ++ a :: v -> x = u /\ y = v.
Proof.
  intro. revert u.
  induction x; intros; destruct u; inv H1; try now firstorder.
    eapply IHx in H4; try now firstorder. intuition congruence.
Qed.

Lemma split_inv X (u z x y : list X) (s : X) :
  u ++ z = x ++ s :: y -> ~ s el u -> exists x' : list X, x = u ++ x'.
Proof.
  revert u. induction x; cbn; intros.
  - destruct u. cbn. eauto. inv H. firstorder.
  - destruct u. cbn. eauto.
    inv H. edestruct IHx. cbn. rewrite H3. reflexivity. firstorder. subst. cbn. eauto.
Qed.

Lemma in_split X (a : X) (x : list X) :
  a el x -> exists y z, x = y ++ [a] ++ z.
Proof.
  induction x; cbn; intros.
  - firstorder.
  - destruct H as [-> | ].
    + now exists [], x.
    + destruct (IHx H) as (y & z & ->).
      now exists (a0 :: y), z.
Qed.

Definition is_cons X (l : list X) :=
  match l with
  | [] => false
  | _ => true
  end.

Lemma is_cons_true_iff X (l : list X) :
  is_cons l = true <-> l <> [].
Proof.
  destruct l; cbn; firstorder congruence.
Qed.

(* *** Fresh symbols *)

Fixpoint fresh (l : list nat) :=
  match l with
  | [] => 0
  | x :: l => S x + fresh l
  end.

Lemma fresh_spec' l a : a el l -> a < fresh l.
Proof.
  induction l.
  - firstorder.
  - cbn; intros [ | ]; firstorder lia.
Qed.

Lemma fresh_spec (a : nat) (l : list nat) : a el l -> fresh l <> a.
Proof.
  intros H % fresh_spec'. intros <-. lia.
Qed.

Section neList.

  Variable X : Type.
  Variable P : list X -> Prop.

  Hypothesis B : (forall x : X, P [x]).
  Hypothesis S : (forall x A, P A -> P (x :: A)).

  Lemma list_ind_ne A : A <> [] -> P A.
  Proof using S B.
    intros H. destruct A. congruence. clear H.
    revert x. induction A; eauto.
  Qed.

End neList.

Fixpoint omap X Y (f : X -> option Y) l :=
  match l with
  | nil => nil
  | x :: l => match f x with Some y => y :: omap f l | None => omap f l end
  end.

Lemma in_omap_iff X Y (f : X -> option Y) l y : y el omap f l <-> exists x, x el l /\ f x = Some y.
Proof.
  induction l; cbn.
  - firstorder.
  - destruct (f a) eqn:E; firstorder (subst; firstorder congruence).
Qed.

Section Positions.
  Variables (X: Type) (d: forall x y : X, {x = y} + {x <> y}).
  Implicit Types (x y: X) (A B : list X).

  Fixpoint pos x A : option nat :=
    match A with
    | nil => None
    | y :: A' => if d x y then Some 0
                else match pos x A' with
                     | Some n => Some (S n)
                     | None => None
                     end
    end.

  Lemma el_pos x A :
    x el A -> { n | pos x A = Some n }.
  Proof.
    induction A as [|y A IH]; cbn; intros H.
    - destruct H as [].
    - destruct (d x y) as [<-|H1].
      + now exists 0.
      + destruct IH as [n IH].
        * destruct H as [->|H]; tauto.
        * rewrite IH. now exists (S n).
  Qed.

  Notation nthe n A := (nth_error A n).

  Lemma nthe_length A n :
    length A > n -> { x | nthe n A = Some x }.
  Proof.
    revert n.
    induction A as [|y A IH]; cbn; intros n H.
    - exfalso. lia.
    - destruct n as [|n]; cbn.
      + now exists y.
      + destruct (IH n) as [x H1]. lia. now exists x.
  Qed.

 Lemma pos_nthe x A n :
    pos x A = Some n -> nthe n A = Some x.
 Proof.
   revert n.
   induction A as [|y A IH]; cbn; intros n.
    - intros [=].
    - destruct (d x y) as [<-|H1].
      + now intros [= <-].
      + destruct (pos x A) as [k|]; intros [= <-]; cbn.
        now apply IH.
  Qed.

  Lemma nthe_app_l x n A B :
    nthe n A = Some x -> nthe n (A ++ B) = Some x.
  Proof.
    revert n.
    induction A as [|y A IH]; cbn; intros k H.
    - destruct k; discriminate H.
    - destruct k as [|k]; cbn in *. exact H.
      apply IH, H.
  Qed.

End Positions.

Notation nthe n A := (nth_error A n).

Lemma pos_nth X d (x : X) l n def : pos d x l = Some n -> nth n l def = x.
Proof.
  revert n; induction l; cbn; intros; try congruence.
  destruct (d x a); try destruct (pos d x l) eqn:E; inv H; eauto.
Qed.

Lemma pos_length X d (x : X) l n : pos d x l = Some n -> n < | l |.
Proof.
  revert n; induction l; cbn; intros; try congruence.
  destruct (d x a).
  - inv H. lia.
  - destruct (pos d x l) eqn:E; inv H; try lia. specialize (IHl _ eq_refl). lia.
Qed.

Lemma cons_incl X (a : X) (A B : list X) : a :: A <<= B -> A <<= B.
Proof.
  intros ? ? ?. eapply H. firstorder.
Qed.

Lemma app_incl_l X (A B C : list X) :
  A ++ B <<= C -> A <<= C.
Proof.
  intros H x Hx. eapply H. eapply in_app_iff. now left.
Qed.

Lemma app_incl_R X (A B C : list X) :
  A ++ B <<= C -> B <<= C.
Proof.
  intros H x Hx. eapply H. eapply in_app_iff. now right.
Qed.


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Vectors.Fin.
Require Export Category.Lib.Foundation.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Class Setoid A := {
  equiv : crelation A;
  setoid_equiv : Equivalence equiv
}.
#[export] Existing Instance setoid_equiv.

Coercion setoid_equiv : Setoid >-> Equivalence.

Notation "f ≈ g" := (equiv f g) (at level 79) : category_theory_scope.

Definition eq_equivalence@{t u} {A : Type@{t}} : @Equivalence@{t u} A (@eq A) :=
  @Build_Equivalence@{t u} A
    (@eq A) (@eq_Reflexive A)
    (@eq_Symmetric A)
    (@eq_Transitive A).

Inductive poly_unit@{u} : Type@{u} := ttt.

Definition unit_setoid@{t u} : Setoid@{t u} poly_unit@{t} :=
  {| equiv := @eq poly_unit@{t}
   ; setoid_equiv := @eq_equivalence@{t u} poly_unit@{t} |}.

Definition eq_Setoid@{u} (A : Type@{u}) : Setoid@{u u} A :=
  Build_Setoid@{u _} A (λ f g, eq f g) eq_equivalence@{u u}.

#[export]
Program Instance funext_Setoid
        {T : Type} (t : T → Type) (a b : T) `{Setoid (t b)} :
  Setoid (t a → t b) | 9 := {|
  equiv := λ f g, ∀ x, f x ≈ g x
|}.
Next Obligation.
  constructor; repeat intro.
  - reflexivity.
  - symmetry.
    now apply X.
  - now rewrite X, X0.
Qed.

#[export]
Program Instance Fin_Setoid {n} : Setoid (Fin.t n) := {|
  equiv := eq
|}.

Class Unique `{S : Setoid A} (P : A → Type) := {
  unique_obj : A;
  unique_property : P unique_obj;
  uniqueness      : ∀ v : A, P v → unique_obj ≈ v;
}.

Arguments unique_obj {_ _ _} _.
Arguments unique_property {_ _ _} _.
Arguments uniqueness {_ _ _} _.

Notation "∃! x .. y , P" := (Unique (fun x => .. (Unique (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity) : category_theory_scope.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

(** A type class-based library for working with decidable equality. *)

Require Import Coq.Classes.Equivalence.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Logic.Decidable.

(* *********************************************************************** *)
(** * Hints for [equiv] *)

Hint Extern 0 (?x === ?x) => reflexivity.
Hint Extern 1 (_ === _) => (symmetry; trivial; fail).
Hint Extern 1 (_ =/= _) => (symmetry; trivial; fail).

(* *********************************************************************** *)
(** * Facts about [EqDec] *)

(** The [EqDec] class is defined in Coq's standard library. *)
Section CoqEqDecSec.
  Variable A:Type.

  Lemma equiv_reflexive' : forall `{EqDec A} (x : A),
                             x === x.
  Proof. intros. apply equiv_reflexive. Qed.

  Lemma equiv_symmetric' : forall `{EqDec A} (x y : A),
                             x === y ->
                             y === x.
  Proof. intros. apply equiv_symmetric; assumption. Qed.

  Lemma equiv_transitive' : forall `{EqDec A} (x y z : A),
                              x === y ->
                              y === z ->
                              x === z.
  Proof. intros. eapply @equiv_transitive; eassumption. Qed.

  Lemma equiv_decidable : forall `{EqDec A} (x y : A),
                            decidable (x === y).
  Proof. intros. unfold decidable. destruct (x == y); auto. Defined.
End CoqEqDecSec.

(* *********************************************************************** *)
(** * Specializing [EqDec] *)

(** It is convenient to be able to use a single notation for decidable
    equality on types.  This can naturally be done using a type class.
    However, the definition of [EqDec] in the EquivDec library is
    overly general for cases where the equality is [eq]: the extra
    layer of abstraction provided by abstracting over the equivalence
    relation gets in the way of smooth reasoning.  To get around this,
    we define a version of that class where the equivalence relation
    is hard-coded to be [eq].

    Implementation note: One should not declare an instance for
    [EqDec_eq A] directly.  First, declare an instance for [@EqDec A
    eq eq_equivalence].  Second, let class inference build an instance
    for [EqDec_eq A] using the instance declaration below.

    Implementation note (BEA): Specifying [eq_equivalence] explicitly
    is important.  Following Murphy's Law, if type class inference can
    find multiple ways of inferring the [@Equivalence A eq] argument,
    it will do so in the most inconvenient way possible.
    Additionally, I choose to infer [EqDec_eq] instances from [EqDec]
    instances because the standard library already defines instances
    for [EqDec]. *)

Class EqDec_eq (A : Type) :=
  eq_dec : forall (x y : A), {x = y} + {x <> y}.

Instance EqDec_eq_of_EqDec {A} (qa: @EqDec A eq eq_equivalence) : EqDec_eq A.
Proof. trivial. Defined.

(*
Existing Class EqDec_eq.
Existing Instance EqDec_eq_of_EqDec.
*)


Require Export ZArith.
Require Export Uint63.
Require Import List.
Import ListNotations.

Open Scope uint63.

Class Hashable (A : Type) : Type :=
{
  hash : A -> int;
}.

#[export] Instance Hashable_Empty_set : Hashable Empty_set :=
{
  hash e := match e with end;
}.

#[export] Instance Hashable_unit : Hashable unit :=
{
  hash _ := 147852369;
}.

#[export] Instance Hashable_bool : Hashable bool :=
{
  hash b := if b then 789654123 else 123654789;
}.

#[export] Instance Hashable_int : Hashable int :=
{
  hash i := i;
}.

#[export] Instance Hashable_nat : Hashable nat :=
{
  hash n := Uint63.of_Z (Z.of_nat n);
}.

#[export] Instance Hashable_sum
  {A B : Type} `{Hashable A} `{Hashable B} : Hashable (A + B) :=
{
  hash x :=
    match x with
    | inl a => add (mul 123456789 (hash a)) 987654321
    | inr b => add (mul 987654321 (hash b)) 123456789
    end;
}.

#[export] Instance Hashable_prod
  {A B : Type} `{Hashable A} `{Hashable B} : Hashable (A * B) :=
{
  hash '(a, b) :=
    let x := hash a in
    let y := hash b in
      div (add (mul x x) (add (mul 3 x) (add (mul 2 (mul x y)) (add y (mul y y))))) 2
}.

Fixpoint hash_list {A : Type} `{Hashable A} (l : list A) : int :=
match l with
| [] => hash tt
| h :: t => hash (hash h, hash_list t)
end.

#[export] Instance Hashable_list (A : Type) `{Hashable A} : Hashable (list A) :=
{
  hash := hash_list;
}.

Compute hash (inl false).
Compute hash (inl true).
Compute hash (inr false).
Compute hash (inr true).

Compute hash (inl (inl false)).
Compute hash (inl (inr false)).
Compute hash (inr (inl false)).
Compute hash (inr (inr false)).

Compute hash (true, false).
Compute hash (false, true).
Compute hash (true, true).
Compute hash (false, false).

Compute hash [true; false; true].