Require Import Coq.ZArith.ZArith.
Require Import Coq.PArith.PArith.
Require Import Coq.NArith.NArith.
Require Import Coq.Lists.List.
Open Scope Z_scope.

(** * MathClasses-style "Decision" class. *)

Class Decision (P: Prop) := decide: {P} + {~P}.
Arguments decide P {_}.

(** A common special case is that of decidable equality. *)
Class EqDec A := eq_dec (a b : A) :> Decision (a = b).

Definition isTrue P `{Decision P} :=
  if decide P then true else false.

Lemma isTrue_sound P `{Decision P}:
  isTrue P = true -> P.
Proof.
  unfold isTrue.
  destruct (decide P).
  tauto.
  discriminate.
Qed.

Lemma isTrue_complete P `{Decision P}:
  P -> isTrue P = true.
Proof.
  intro HP.
  unfold isTrue.
  destruct (decide P); eauto.
Qed.

Lemma isTrue_correct P `{Decision P}:
  isTrue P = true <-> P.
Proof.
  split.
  * apply isTrue_sound.
  * apply isTrue_complete.
Qed.

Ltac decision :=
  eapply isTrue_sound;
  reflexivity.

Ltac obviously H P :=
  assert (H: P) by decision.

Ltac ensure P :=
  let H := fresh "H" in
  obviously H P; clear H.

(** * Instances *)

Instance decide_Zeq: EqDec Z := Z_eq_dec.
Instance decide_Zle (m n: Z): Decision (m <= n) := {decide := Z_le_dec m n}.
Instance decide_Zlt (m n: Z): Decision (m < n) := {decide := Z_lt_dec m n}.
Instance decide_Zge (m n: Z): Decision (m >= n) := {decide := Z_ge_dec m n}.
Instance decide_Zgt (m n: Z): Decision (m > n) := {decide := Z_gt_dec m n}.
Instance decide_nateq: EqDec nat := eq_nat_dec.
Instance decide_natle m n: Decision (m <= n)%nat := { decide := le_dec m n }.
Instance decide_natlt m n: Decision (m < n)%nat := { decide := lt_dec m n }.
Instance decide_poseq: EqDec positive := Pos.eq_dec.
Instance decide_booleq: EqDec bool := Bool.bool_dec.
Instance decide_Neq: EqDec N := N.eq_dec.

Instance decide_posle (m n: positive): Decision (Pos.le m n).
Proof.
  destruct (Pos.leb m n) eqn:leb.
  - left; apply Pos.leb_le, leb.
  - right; rewrite <- Pos.leb_le, leb; discriminate.
Defined.

Instance and_dec A B: Decision A -> Decision B -> Decision (A /\ B) := {
  decide :=
    match (decide A) with
      | left HA =>
          match (decide B) with
            | left HB => left (conj HA HB)
            | right HnB => right (fun H => HnB (proj2 H))
          end
      | right HnA => right (fun H => HnA (proj1 H))
    end
}.

Instance or_dec A B: Decision A -> Decision B -> Decision (A \/ B) := {
  decide :=
    match (decide A) with
      | left HA => left (or_introl HA)
      | right HnA =>
        match (decide B) with
          | left HB => left (or_intror HB)
          | right HnB => right (fun HAB => match HAB with
                                             | or_introl HA => HnA HA
                                             | or_intror HB => HnB HB
                                           end)
        end
    end
}.

Instance impl_dec P Q `(Pdec: Decision P) `(Qdec: Decision Q): Decision (P->Q) :=
  {
    decide :=
      match Qdec with
        | left HQ => left (fun _ => HQ)
        | right HnQ =>
          match Pdec with
            | left HP => right _
            | right HnP => left _
          end
      end
  }.
Proof.
  * abstract tauto.
  * abstract tauto.
Defined.

Instance not_dec P `(Pdec: Decision P): Decision (~P) :=
  {
    decide :=
      match Pdec with
        | left _ => right _
        | right _ => left _
      end
  }.
Proof.
  * abstract tauto.
  * abstract tauto.
Defined.

Program Instance decide_none {A} (a: option A): Decision (a = None) := {
  decide :=
    match a with
      | Some _ => right _
      | None => left _
    end
}.

Instance decide_option_eq A `{EqDec A}:
  EqDec (option A) :=
  fun x y =>
    match x, y with
      | Some x, Some y =>
        match decide (x = y) with
          | left H => left (f_equal _ H)
          | right H => right _
        end
      | None, None =>
        left eq_refl
      | _, _ =>
        right _
    end.
Proof.
  * abstract (injection; eauto).
  * abstract discriminate.
  * abstract discriminate.
Defined.

Section DECIDE_PROD.
  Context A `{Adec: EqDec A}.
  Context B `{Bdec: EqDec B}.

  Global Instance decide_eq_pair: EqDec (A * B).
  Proof.
    intros [x1 x2] [y1 y2].
    destruct (decide (x1 = y1)).
    destruct (decide (x2 = y2)).
    left; congruence.
    right; intro H; inversion H; now auto.
    right; intro H; inversion H; now auto.
  Defined.
End DECIDE_PROD.

(** * Decision procedures for lists *)

Instance decide_In: forall `{EqDec} a l, Decision (@In A a l) :=
  @In_dec.

Instance decide_Forall {A} (P: A -> Prop):
  (forall a, Decision (P a)) ->
  (forall l, Decision (Forall P l)).
Proof.
  intros HP l.
  induction l.
  * left.
    constructor.
  * destruct (decide (Forall P l)) as [Hl | Hl].
    destruct (decide (P a)) as [Ha | Ha].
    + left.
      constructor;
      assumption.
    + right.
      inversion 1.
      tauto.
    + right.
      inversion 1.
      tauto.
Defined.

Instance decide_list_eq `{EqDec}: EqDec (list A) :=
  list_eq_dec H.

(** * Decision procedures from [compare] *)

(** This takes care of many orders, which are defined as, say,
  [le x y := compare x y <> Gt]. *)

Instance comparison_eq_dec: EqDec comparison.
Proof.
  intros x y.
  red.
  decide equality.
Defined.

(** Decision and equivalence *)

Local Instance decide_rewrite P Q (Heq: P <-> Q) `(Decision P): Decision Q :=
  match decide P with
    | left _ => left _
    | right _ => right _
  end.
Proof.
  abstract tauto.
  abstract tauto.
Defined.

(** Decision and discriminable cases *)

Theorem decide_discr {A}
        (Q1 Q2 P: A -> Prop)
        (discr: forall i, {Q1 i} + {Q2 i})
        (dec_1: Decision (forall i, Q1 i -> P i))
        (dec_2: Decision (forall i, Q2 i -> P i)):
  Decision (forall i, P i).
Proof.
  unfold Decision in *.
  firstorder.
Defined.


Require Export prosa.model.priority.classes.

(** * Numeric Fixed Task Priorities *)

(** We define the notion of arbitrary numeric fixed task priorities, i.e.,
    tasks are prioritized in order of user-provided numeric priority values,
    where numerically smaller values indicate lower priorities (as for instance
    it is the case in Linux). *)

(** First, we define a new task parameter [task_priority] that maps each task
    to a numeric priority value. *)
Class TaskPriority (Task : TaskType) := task_priority : Task -> nat.

(** Based on this parameter, we define the corresponding FP policy. *)
Instance NumericFP (Task : TaskType) `{TaskPriority Task} : FP_policy Task :=
{
  hep_task (tsk1 tsk2 : Task) := task_priority tsk1 >= task_priority tsk2
}.

(** In this section, we prove a few basic properties of numeric fixed priorities. *)
Section Properties.

  (**  Consider any kind of tasks with specified priorities... *)
  Context {Task : TaskType}.
  Context `{TaskPriority Task}.

  (** ...and jobs stemming from these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.

  (** The resulting priority policy is reflexive. *)
  Lemma NFP_is_reflexive : reflexive_priorities.
  Proof. by move=> ?; rewrite /hep_job_at /JLFP_to_JLDP /hep_job /FP_to_JLFP /hep_task /NumericFP. Qed.

  (** The resulting priority policy is transitive. *)
  Lemma NFP_is_transitive : transitive_priorities.
  Proof.
    move=> t y x z.
    rewrite /hep_job_at /JLFP_to_JLDP /hep_job /FP_to_JLFP /hep_task /NumericFP.
    by move=> PRIO_yx PRIO_zy; apply leq_trans with (n := task_priority (job_task y)).
  Qed.

  (** The resulting priority policy is total. *)
  Lemma NFP_is_total : total_priorities.
  Proof. by move=> t j1 j2; apply leq_total. Qed.

End Properties.

(** We add the above lemmas into a "Hint Database" basic_facts, so Coq
    will be able to apply them automatically. *)
Hint Resolve
     NFP_is_reflexive
     NFP_is_transitive
     NFP_is_total
  : basic_facts.


(**
Coq/SSReflect/MathComp による定理証明

第4章 MathComp ライブラリの基本ファイル

4.3 ssrnat.v --- SSReflect 向け nat 型のライブラリ

======

2018_12_02 @suharahiromichi
 *)

From mathcomp Require Import all_ssreflect.

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

(**
# はじめに

本節はテキストを参照しながら、MathComp のソースコードに沿って説明していきます。
ソースコードが手元にあるならば、それも参照してください。
opamでインストールしている場合は、ssrbool.v のソースは、たとえば以下にあります。

~/.opam/4.07.1/lib/coq/user-contrib/mathcomp/ssreflect/ssrnat.v
*)

(**
# successor and predecessor

Standard Coq の S (successor) と pred (predecessor) の構文糖衣(Notation)である。
nosimpl ではない。後述する .*2 (double) は nosimple です。
csm_3_6_3_simpl.v に誤記がありました。
*)

Locate ".+1".           (* S n : nat_scope (default interpretation) *)
Print S.                (* Inductive nat : Set :=  O : nat | S : nat -> nat *)

Locate ".-1".    (* Nat.pred n : nat_scope (default interpretation) *)
Print Nat.pred.  (* Nat.pred = fun n : nat => match n with | 0 => n | u.+1 => u end *)

(**
重大な注意

n.+1.-1 = n は、無条件に成立するが、
n.-1.+1 = n は、n≧1 でなければならない。 0.-1.+1 = 0.+1 = 1 なので。
*)

Check succnK : forall n : nat, n = n.+1.-1.
Check prednK : forall n : nat, 0 < n -> n.-1.+1 = n. (* 1 <= n *)

(**
nat_eqType、eqType のインスタンス
*)

Check 1 : nat_eqType : eqType.
Check 1 : nat        : Type.

(**
# bin_nat, number

(略)
*)

(**
# basic arithmetic

## 定義

Standard Soq の Nat.add, Nat.sub. Nat.mul に nosimpl をつけたもの。
*)

Locate "m + n".    (* addn m n : nat_scope (default interpretation) *)
Print addn.        (* addn = nosimpl addn_rec *)
Print addn_rec.    (* Nat.add *)
Print plus.        (* Notation plus := Nat.add (Standard Coq での定義) *)

Locate "m - n".    (* subn m n : nat_scope (default interpretation) *)
Print subn.        (* subn = nosimpl subn_rec *)
Print subn_rec.    (* subn_rec = Nat.sub *)
Print minus.       (* Notation minus := Nat.sub (Standard Coq での定義) *)

Locate "m * n".    (* muln m n : nat_scope (default interpretation) *)
Print muln.        (* muln = nosimpl muln_rec *)
Print muln_rec.    (* muln_rec = Nat.mul *)
Print mult.        (* Notation mult := Nat.mul (Standard Coq での定義) *)

(**
## nosimpl とは
 *)
Print nosimpl.        (* Notation nosimpl t := (let 'tt := tt in t) *)

(**
match や let: を関数の定義の中で使うと、simplが機能しないことを利用する。
（定義を展開unfoldすると、simplは機能することに注意）

https://coq.inria.fr/refman/proof-engine/ssreflect-proof-language.html#locking-unlocking
の後半 We found that 以降。
*)
Definition add1 := (match tt with tt => Nat.add end).
Definition add2 := (let: tt := tt in Nat.add).
Definition add3 := (let tt := tt in Nat.add). (* これは simpl される。 *)

(* どこの simpl で 左辺が2に簡約されるか。 *)
Goal add1 1 1 = 2. Proof. simpl. rewrite /add1. simpl. reflexivity. Qed.
Goal add2 1 1 = 2. Proof. simpl. rewrite /add2. simpl. reflexivity. Qed.
Goal add3 1 1 = 2. Proof. simpl. reflexivity. Qed.

(*
simpl (rewrite /=) は、簡約をするタクティクで simplification の略。
https://coq.inria.fr/refman/proof-engine/tactics.html#coq:tacn.simpl
In detail, the tactic simpl 以降。

simpl タクティクは、β簡約またはι簡約をおこなうが、ι簡約できる場合のみδ簡約する
（δ簡約によって展開することで、ι簡約できるようになった場合のみ、その関数をδ簡約する）
という性質を使う。以下の例を参照のこと：
*)

(* 単なるι簡約：常にできる。 *)
Goal (match 0 with 0 => 1 | _ => 1 end) = 1. Proof. simpl. reflexivity. Qed.
Goal (match tt with tt => 1 end) = 1. Proof. simpl. reflexivity. Qed.

(* δ簡約して、ι簡約：これはできる。 *)
Definition one1 (n : nat) := (match n with 0 => 1 | _ => 1 end).
Goal one1 0 = 1. Proof. simpl. reflexivity. Qed. (* 1 = 1 *)

(* ι簡約しないなら、δ簡約してくれない。 *)
Definition one2 (n : nat) := (match tt with tt => 1 end).
Goal one2 0 = 1. Proof. simpl. Admitted.    (* one2 0 = 1 *)

(**
## Standard Coq の関数に変換する。

次の補題が用意されている。
Standard Coq の add, sub, mul にも 「+」「-」「*」 が用意されているが、
デフォルトではないので、%coq_nat と表示される。

一旦 %coq_nat に変換すれば、Standard Coq の omega などが使用できる。
ただし、ltacで定義するのが現実的である。ssr_omega.v 参照のこと。
*)

Check plusE  : Nat.add = addn.
Check minusE : Nat.sub = subn.
Check multE  : Nat.mul = muln.

Goal 1 + 1 = 2. Proof. rewrite -plusE. simpl. reflexivity. Qed. (* (1 + 1)%coq_nat *)
Goal 1 - 1 = 0. Proof. rewrite -minusE. simpl. reflexivity. Qed. (* (1 - 1)%coq_nat *)
Goal 1 * 1 = 1. Proof. rewrite -multE. simpl. reflexivity. Qed. (* (1 * 1)%coq_nat *)

(**
# comparison 比較
*)

(**
## MathComp の比較（不等式）

leq m n := (m - n == 0) で定義されている。「<=」は leq の Notation である。

「<」はleqで定義されている。ltn は「<」で定義されている。
*)

Locate "m <= n".    (* leq m n : nat_scope (default interpretation) *)
Check leq : nat -> nat -> bool.
Print leq.          (* leq = fun m n : nat => m - n == 0 *)

Locate "m < n".  (* leq m.+1 n : nat_scope (default interpretation) *)
Check ltn : nat -> nat -> bool.
Print ltn.       (* [rel m n | m < n] *)

(**
MathComp の「<=」などの不等式はboolである。leq は、nosimpl でないので、done で証明できる。
 *)

(**
## Standard Coq の比較（不等式）
*)
Check le : nat -> nat -> Prop.
Check lt : nat -> nat -> Prop.
(*
Standard Coq の不等式は Prop であり、 <= と < は、%coq_nat と表示される。
Stadnard Coq の不等式は done できない。
 *)

(**
## 相互変換のための補題：leP と ltP

boolの不等式と、Propの不等式(%coq_nat)の相互変換は、leP と ltP を使う。
一旦 %coq_nat に変換すれば、Standard Coq の omega などが使用できる。
*)
Goal forall n, n <= n.+1.
Proof.
  move=> n.
  apply/leP.
  (* (n <= n.+1)%coq_nat *)
  Fail done.                     (* done で終わらない。 *)
  apply/leP.
  (* n <= n.+1 *)
  done.
Qed.

Goal forall n, n < n.+1.
Proof.
  move=> n.
  apply/ltP.
  (* (n < n.+1)%coq_nat *)
  done.
Qed.

Locate "m <= n". (* leq m n : nat_scope (default interpretation) *)
Locate "m < n".  (* leq m.+1 n : nat_scope (default interpretation) *)
Locate "m >= n". (* leq n m : nat_scope (default interpretation) *)
Locate "m > n".  (* leq n.+1 m : nat_scope (default interpretation) *)

(**
<= 以外は、<= で定義されている。
そのため、m.+1 <= n が m < n と表示される場合がある。
CoqはできるだけNotationを使って表示しようとするためであり、結果として、
以下のように、< が一番よく使われるので、おどろかないようにする。
 *)
Check 1 <= 2.                               (* 0 < 2 *)
Check 2 >= 1.                               (* 0 < 2 *)
Check 0 <= 1.                               (* 0 <= 1 *)
Check 1 >= 0.                               (* 0 <= 1  *)

(**
## 場合分けのための補題： leqP と ltnP （これは覚えるべき補題）

(leP と ltP と紛らわしいが、別なもの）
*)

Goal forall m n, (if m <= n then n else m) = maxn n m.
Proof.
  move=> m n.
  rewrite /maxn.
  case: leqP.
  - done.                                   (* m <= n -> n = n *)
  - done.                                   (* n < m -> m = m *)
Qed.
(* if then else は = より結合度が低いので、括弧がいる。 *)

Goal forall m n, (if m <= n then m else n) = minn n m.
Proof.
  move=> m n.
  rewrite /minn.
  case: ltnP.
  - done.                                   (* n < m -> n = n *)
  - done.                                   (* m <= n -> m = m *)
Qed.

(**
## 補足説明
 *)
(**
m <= n で場合分けする。ちょっとめんどう。
 *)
Goal forall m n, (if m <= n then n else m) = maxn n m.
Proof.
  move=> m n.
  rewrite /maxn.
  case H : (m <= n).
  (* n = (if n < m then m else n) *)
  - rewrite leqNgt ltnS H.
    done.
  (* m = (if n < m then m else n) *)
  - rewrite leqNgt ltnS H.
    done.
Qed.

(**
ifP で場合分けする。
 *)
Goal forall m n, (if m <= n then n else m) = maxn n m.
Proof.
  move=> m n.
  rewrite /maxn.
  case: ifP => H.
  (* m <= n -> n = (if n < m then m else n) *)
  - rewrite leqNgt ltnS H.
    done.
  (* (m <= n) = false -> m = (if n < m then m else n) *)
  - rewrite leqNgt ltnS H.
    done.
Qed.

(**
# min, max
*)

Print minn.       (* minn = fun m n : nat => if m < n then m else n *)
Print maxn.       (* maxn = fun m n : nat => if m < n then n else m *)

(* 当然、可換である。 *)
Goal forall m n, minn m n = minn n m.
Proof.
  move=> m n.
    by rewrite minnC.
Qed.

Goal forall m n, n <= m -> minn n m = n.
Proof.
  move=> m n.
  rewrite /leq.
  move/eqP.
  rewrite minnE.
  move=> ->.
    by rewrite subn0.
Qed.

Goal forall m n, n <= m -> maxn m n = m.
Proof.
  move=> m n.
  rewrite /leq.
  move/eqP.
  rewrite maxnE.
  move=> ->.
    by rewrite addn0.
Qed.

(**
# iter

(略)
*)

(**
# parity

odd は 「odd(n.+1) -> ~~ odd(n)」 という再帰で定義されている。
なので、odd か even (= not odd) の証明は、単純な数学的帰納法で証明できる。
 *)

Print odd.
(*
odd =
fix odd (n : nat) : bool := match n with
                            | 0 => false
                            | n'.+1 => ~~ odd n'
                            end
 *)

Lemma oddn2 n : odd n.+2 = odd n.
Proof. rewrite /=. by rewrite negbK. Qed.

Lemma oddn1 n : odd n.+1 = ~~ odd n.
Proof. done. Qed.

Lemma odd_pred n : 1 <= n -> odd n.-1 = ~~ odd n.
Proof.
  elim: n => [// | n IHn H].
    by rewrite succnK oddn1 negbK.
Qed.

(**
# doubling, halving
 *)

Locate ".*2".      (* double n : nat_scope (default interpretation) *)
Print double.      (* double = nosimpl double_rec *)

Locate "./2".        (* half n : nat_scope (default interpretation) *)
Print half.          (* half =
                        fix half (n : nat) : nat := match n with
                            | 0 => n
                            | n'.+1 => uphalf n'
                            end
                            with uphalf (n : nat) : nat := match n with
                               | 0 => n
                               | n'.+1 => (half n').+1
                               end *)

(**
# exponentiation, factorial
 *)

Locate "m ^ n".    (* expn m n : nat_scope (default interpretation) *)
Print expn.        (* expn = nosimpl expn_rec *)

Locate "n `!".  (* factorial n : nat_scope (default interpretation) *)
Print factorial.                    (* factorial = nosimpl fact_rec *)

(**
# ex_minn, ex_maxn

(略)
 *)

(**
# これだけは憶えておきたい補題

以下も参照してください；
https://staff.aist.go.jp/reynald.affeldt/ssrcoq/ssrnat_doc.pdf
*)

Section Lemmas.
  Variables m n p q : nat.

  Check add0n n : 0 + n = n.          (* left_id 0 addn *)
  Check addn0 n : n + 0 = n.          (* right_id 0 addn *)
  Check add1n n : 1 + n = n.+1.       (* .+2 から .+4 も使用可能である。 *)
  Check addn1 n : n + 1 = n.+1.
  Check addnn n : n + n = n.*2.
  Check addSn m n : m.+1 + n = (m + n).+1.
  Check addnS m n : m + n.+1 = (m + n).+1.
  Check addSnnS m n : m.+1 + n = m + n.+1.

  Check addnC m n : m + n = n + m.             (* commutative addn *)
  Check addnA m n p : m + (n + p) = m + n + p. (* associative addn *)
  Check addnCA m n p : m + (n + p) = n + (m + p). (* left_commutative addn *)
  Check addnAC m n p : m + n + p = m + p + n. (* right_commutative addn *)
  Check addnACA m n p q : m + n + (p + q) = m + p + (n + q). (* interchange addn addn *)
  Check addKn m n : m + n - m = n.             (* cancel (addn n) (subn^~ n) *)
  Check addnK m n : n + m - m = n.             (* cancel (addn^~ n) (subn^~ n) *)

  Check subnn n : n - n = 0.                (* self_inverse *)

  Check mul0n n : 0 * n = 0.                (* left_zero 0 muln *)
  Check muln0 n : n * 0 = 0.                (* right_zero 0 muln *)
  Check mul1n n : 1 * n = n.                (* left_id 1 muln *)
  Check muln1 n : n * 1 = n.                (* right_id 1 muln *)
  Check mul2n n : 2 * n = n.*2.
  Check muln2 n : n * 2 = n.*2.
  Check mulnn n : n * n = n ^ 2.
  Check mulSn m n : m.+1 * n = n + m * n.
  Check mulSnr m n : m.+1 * n = m * n + n.
  Check mulnS m n : m * n.+1 = m + m * n.
  Check mulnSr m n : m * n.+1 = m * n + m.

  Check mulnC m n : m * n = n * m.             (* commutative muln *)
  Check mulnA m n p : m * (n * p) = m * n * p. (* associative muln *)
  Check mulnDl m n p : (m + n) * p = m * p + n * p. (* left_distributive muln addn *)
  Check mulnDr m n p : m * (n + p) = m * n + m * p. (* right_distributive muln addn *)
  Check mulnBl m n p : (m - n) * p = m * p - n * p. (* left_distributive muln subn *)
  Check mulnBr m n p : m * (n - p) = m * n - m * p. (* right_distributive muln subn *)
  Check mulnCA m n p : m * (n * p) = n * (m * p). (* left_commutative muln *)
  Check mulnAC m n p : m * n * p = m * p * n. (* right_commutative muln *)
  Check mulnACA m n p q : m * n * (p * q) = m * p * (n * q). (* interchange muln muln *)
End Lemmas.

(**
つぎの Search は結果がない（left_id で定義されているため）。
それらについては、ここで憶えてしまうしかない。
*)
Search _ (0 + _ = _).                       (* add0n は出てこない。 *)

(**
# 可換なとき、大きな式を扱うコツ

addn の場合

- ?addnA で左結合
- -?addnA で右結合

に変換できる。?は零回以上の繰り替えしで、すでにそうなっている場合にエラーにしないため。
*)

(**
## 3項を逆順にする。

1回の可換則では、隣どうししか入れ替えられないから、
3項を逆順にするには3回必要
*)
Goal 0 + 1 + 2 = 3.
Proof.
  rewrite ?addnA addnAC.                    (* 2番めを最後に *)
  rewrite -?addnA addnCA.                   (* 2番めを最初に *)
  rewrite ?addnA addnAC.                    (* 2番めを最後に *)
  done.
Qed.

(**
同上
 *)
Goal 0 + 1 + 2 = 3.
Proof.
  rewrite -?addnA addnCA.                   (* 2番めを最初に *)
  rewrite ?addnA addnAC.                    (* 2番めを最後に *)
  rewrite -?addnA addnCA.                   (* 2番めを最初に *)
  rewrite ?addnA.                           (* 左結合にする。 *)
  done.
Qed.

(**
## 項を入れ替える

任意の項を先頭または、最後にする方法。内容で項を指定する。

左結合で最後、右結合で先頭、にすれば、その項を取り出せる。
*)
Goal 0 + 1 + 2 + (3 + 4 + 5 + 6 + 7) + 8 + 9 = 45.
Proof.
  rewrite ?addnA.                           (* 左結合にする。 *)
  rewrite [_ + 4]addnC ?addnA.              (* 4 を先頭にする。 *)
  rewrite -?addnA.                          (* 右結合にする。 *)
  rewrite [6 + _]addnC -?addnA.             (* 6 を最後にする。 *)
  rewrite ?addnA.                           (* 左結合にする。 *)
  done.
Qed.

(* END *)


Set Warnings "-extraction-opaque-accessed,-extraction,-notation-overridden".
From Equations Require Import Equations.
From deriving Require Import deriving.

From QuickChick Require Import QuickChick.
Import GenLow GenHigh.

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From mathcomp Require Import zify. (* coq-mathcomp-zify *)

Global Set Bullet Behavior "None".
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Set Equations Transparent.

Inductive exp :=
  | ENum (n: nat)
  | EAdd (e1 e2 : exp)
  | ESub (e1 e2 : exp)
  | EMul (e1 e2 : exp)
  .

Definition exp_indDef := [indDef for exp_rect].
Canonical exp_indType := IndType exp exp_indDef.
Definition exp_eqMixin := [derive eqMixin for exp].
Canonical exp_eqType := EqType exp exp_eqMixin.

Implicit Type e : exp.
Derive (Arbitrary, Show) for exp.

Equations eval e : nat :=
  eval (ENum n) := n;
  eval (EAdd el er) := eval el + eval er;
  eval (EMul el er) := eval el * eval er;
  eval (ESub el er) := eval el - eval er.

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

Inductive instr :=
  | IPush (n : nat)
  | IAdd
  | ISub
  | IMul
  .

Implicit Type i : instr.
Derive (Arbitrary, Show) for instr.

Definition prog := seq instr.
Implicit Type p : prog.

Definition stack := seq nat.
Implicit Type s : stack.

Equations run p s : stack :=
  run [::] s := s;
  run (IPush n :: p) s := run p (n :: s);
  run (IAdd :: p) (x :: y :: s) := run p (y+x :: s);
  run (ISub :: p) (x :: y :: s) := run p (y-x :: s);
  run (IMul :: p) (x :: y :: s) := run p (y*x :: s);
  (* run (_ :: p) s := run p s. *)
  run (_ :: p) s := [::].
  (* error semantics: if a command does not have prereqs, die. *)

Equations compile e : prog :=
  compile (ENum n) := [:: IPush n];
  compile (EAdd el er) := compile el ++ compile er ++ [:: IAdd];
  compile (ESub el er) := compile el ++ compile er ++ [:: ISub];
  compile (EMul el er) := compile el ++ compile er ++ [:: IMul].

QuickChick (fun e =>
  run (compile e) [::] == [:: eval e]
).

Record stype := mk_stype {
  inp : nat; (* depth of the stack a prog consumes *)
  out : nat; (* height of the stack a prog leaves on top of unconsumed *)
}.

Notation "i ~~> o" :=
  (mk_stype i o)
  (at level 50, no associativity).

Definition s_merge st1 st2 : stype :=
  let: inp1 ~~> out1 := st1 in
  let: inp2 ~~> out2 := st2 in
    (inp1 + (inp2 - out1)) ~~> (out2 + (out1 - inp2)).

Equations s_infer_i i : stype :=
  s_infer_i (IPush _) := (0 ~~> 1);
  s_infer_i IAdd := 2 ~~> 1;
  s_infer_i ISub := 2 ~~> 1;
  s_infer_i IMul := 2 ~~> 1.

Definition s_infer p : stype :=
  foldr (fun i st => s_merge (s_infer_i i) st) (0 ~~> 0) p.
  (* s_infer [::] := 0 ~~> 0;
  s_infer (i :: p) := s_infer_i *)

Lemma s_mergeA : associative s_merge.
Proof.
  move=> [i1 o1] [i2 o2] [i3 o3].
  by congr mk_stype; lia.
Qed.

Lemma s_infer_cat p1 p2 :
  s_infer (p1 ++ p2) = s_merge (s_infer p1) (s_infer p2).
Proof.
  elim: p1 => /= [| i s IHp1].
  - case: (s_infer p2) => i o.
    by congr mk_stype; lia.
  by rewrite IHp1 s_mergeA.
Qed.

Lemma compile_typecheck e :
  s_infer (compile e) = 0 ~~> 1.
Proof.
  elim: e=> // e1 IHe1 e2 IHe2 /=;
  by rewrite !s_infer_cat IHe1 IHe2 //=.
Qed.

Lemma run_cat p1 p2 s :
  inp (s_infer p1) <= seq.size s ->
    run (p1 ++ p2) s = run p2 (run p1 s).
Proof.
  elim: p1 s=> // i p1 IHp1 s.
  case: i=> /=.
  - case: (s_infer p1) IHp1 => /= i o IHp1 n I1.
    rewrite IHp1 //=; lia.
  all: case: (s_infer p1) IHp1 => /= i o IHp1.
  all: case: s=> [| x [| y s]] //= I1.
  all: by rewrite IHp1 //=; lia.
Qed.

Lemma compile_correct e :
  run (compile e) [::] = [:: eval e].
Proof.
  move: [::].
  elim: e=> //= e1 IHe1 e2 IHe2 s;
  by rewrite !run_cat ?IHe2 ?IHe1 ?compile_typecheck.
Qed.


Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibProd LibEpsilon LibContainer
     LibSet LibRelation LibPer LibMonoid.
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import LibNatExtra LibIter LibRewrite
     LibFunOrd InverseNatNat Ackermann InverseAckermann MiscArith TLCBuffer
     UnionFind01Data UnionFind11Rank UnionFind21Parent.

(* Following Alstrup et al.'s paper, we now fix a parameter [r] and define
   variants of the level [k], the index [i], and the potential functions [phi]
   and [Phi] that depend on [r]. *)

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

Section Alstrup.

(* Fix the parameter [r], and assume [r] is at least 1. *)

Variable r : nat.

Hypothesis r_geq_1:
  1 <= r.

Section Potential.

(* In the following, we again assume that [F] is a ranked disjoint set forest
   with domain [D] and ranks [K]. *)

Variable V : Type.
Variable D : set V.
Variable F : binary V.
Variable K : V -> nat.
Hypothesis is_rdsf_F:
  is_rdsf D F K.

Notation p := (p F).

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

(* Alstrup et al. define the function [alphar] as follows (page 17).
   Note that their definition of [A] is not the same as ours -- they
   index [k] from 1 and up, whereas, following Tarjan, we index [k]
   from 0 and up -- so our definition of [alphar] looks different. *)

Definition defalphar :=
  fun k => A k r.

Definition prealphar n :=
  alphaf defalphar (n + 1).

Definition alphar (n : nat) :=
  prealphar n + 1.

(* [alphar n] is positive. *)

Lemma alphar_positive:
  forall n,
  alphar n > 0.
Proof using.
  clear r_geq_1.
  intros. unfold alphar. lia.
Qed.

(* [alphar] is monotonic. *)

Lemma alphar_monotonic:
  monotonic le le alphar.
Proof using r_geq_1.
  intros m n ?.
  unfold alphar, prealphar, defalphar.
  eapply plus_le_plus.
  eapply alphaf_monotonic; eauto with monotonic.
  eapply plus_le_plus.
  assumption.
Qed.

(* Like [alpha], [alphar] grows at most by one at a time. *)

Lemma alphar_grows_one_by_one:
  forall n,
  alphar (n + 1) <= alphar n + 1.
Proof using r_geq_1.
  intro.
  unfold alphar, prealphar, defalphar.
  eapply plus_le_plus.
  eauto using alpha_grows_one_by_one.
Qed.

(* If [r] is 1, then [alphar n] is as follows. *)

Lemma alphar_one:
  r = 1 ->
  forall n,
  alphar n = alpha (n + 1) + 1.
Proof using.
  intros h n. unfold alphar, prealphar, defalphar. rewrite h. reflexivity.
Qed.

(* [alphar r] is 1. (Exploited on page 18.) *)

Lemma alphar_r:
  alphar r = 1.
Proof using r_geq_1.
  intros. unfold alphar.
  cut (prealphar r <= 0). { lia. }
  unfold prealphar, defalphar.
  eapply alphaf_spec_reciprocal; eauto with monotonic.
  rewrite (@Abase_eq r). lia.
Qed.

(* If [r] is less than [n], then [alphar n] is at least two (page 17). *)

Lemma alphar_geq_two:
  forall n,
  r < n ->
  1 < alphar n.
Proof using r_geq_1.
  intros.
  change 1 with (0 + 1). eapply plus_lt_plus.
  unfold prealphar, defalphar.
  eapply alphaf_spec_direct_contrapositive; eauto with monotonic.
  rewrite Abase_eq. lia.
Qed.

(* [A (prealphar n) r] is greater than [n] (page 17). *)

Lemma A_prealphar_gt:
  forall n,
  n < A (prealphar n) r.
Proof using r_geq_1.
  intros.
  cut (n + 1 <= A (prealphar n) r). { lia. }
  change (A (prealphar n) r) with ((fun k => A k r) (prealphar n)).
  eapply f_alphaf; eauto with monotonic.
Qed.

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

(* The function [rankr x] is just the function obtained by adding [r] to the
   rank of each node. *)

Definition rankr x :=
  K x + r.

(* [rankr x] is of course at least [r]. *)

Lemma r_leq_rankr:
  forall x,
  r <= rankr x.
Proof using.
  clear r_geq_1.
  intros. unfold rankr. lia.
Qed.

(* Hence, [rankr x] is positive. *)

Lemma rankr_positive:
  forall x,
  rankr x > 0.
Proof using r_geq_1.
  intros. unfold rankr. lia.
Qed.

Hint Resolve rankr_positive : monotonic.
  (* used in conjunction with Akx_tends_to_infinity_along_k *)

(* [rankr] increases along a path. *)

Lemma rankr_increases_along_a_path:
  forall x y,
  path F x y ->
  rankr x <= rankr y.
Proof using is_rdsf_F.
  intros. unfold rankr. eapply plus_le_plus.
  eauto using rank_increases_along_a_path.
Qed.

(* The function [alphar . rankr] grows along a path. *)

Lemma alphar_rankr_grows_along_a_path:
  forall x y,
  path F x y ->
  alphar (rankr x) <= alphar (rankr y).
Proof using is_rdsf_F r_geq_1.
  eauto using alphar_monotonic, rankr_increases_along_a_path.
Qed.

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

Section NonRoot.

(* Let [x] be a non-root. *)

Variable x : V.
Hypothesis x_non_root: ~ is_root F x.

(* The rankr of [x] is less than the rank of its parent. *)

Lemma parent_has_greater_rankr:
  rankr x < rankr (p x).
Proof using is_rdsf_F x_non_root.
  clear r_geq_1.
  unfold rankr.
  forwards: parent_has_greater_rank; eauto.
  lia.
Qed.

(* The function [alphar . rankr] grows along edges. *)

Lemma alphar_rankr_grows_along_edges:
  alphar (rankr x) <= alphar (rankr (p x)).
Proof using is_rdsf_F x_non_root r_geq_1.
  eapply alphar_monotonic.
  forwards: parent_has_greater_rankr.
  lia.
Qed.

Lemma alphar_rankr_grows_along_edges_corollary:
  alphar (rankr x) <> alphar (rankr (p x)) ->
  alphar (rankr x) <  alphar (rankr (p x)).
Proof using is_rdsf_F x_non_root r_geq_1.
  forwards: alphar_rankr_grows_along_edges. lia.
Qed.

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

(* The level of [x] is defined as one plus the largest [k] such that
   [A k (rankr x)] is less than or equal to [rankr (p x)]. *)

Definition defk :=
  fun k => A k (rankr x).

Definition prek :=
  betaf defk (rankr (p x)).

Definition k :=
  prek + 1.

(* The following lemma proves that [k] is well-defined. *)

Lemma k_exists:
  A 0 (rankr x) <= rankr (p x).
Proof using is_rdsf_F x_non_root.
  rewrite Abase_eq.
  eapply parent_has_greater_rankr.
Qed.

Ltac k th :=
  eapply th with (f := defk);
  try solve [ unfold defk; eauto using k_exists with monotonic ].

(* The level of [x] seems to be a measure of the distance of the rank
   of [x] and the rank of its parent. In the case where these ranks
   are closest, [rankr (p x)] is [rankr x + 1], so [k] is 1. *)

Lemma k_is_one:
  K (p x) = K x + 1 ->
  k = 1.
Proof using r_geq_1.
  introv h. unfold k, prek.
  assert (f: rankr (p x) = rankr x + 1). { unfold rankr. lia. }
  rewrite f.
  unfold defk.
  rewrite beta_x_succ_x; eauto using rankr_positive.
Qed.

(* In the case where these ranks are furthest away, [rankr x] is [r] and
   [rankr (p x)] is, well, whatever it is. We find that the level [k] is
   less than [alphar (rankr (p x))]. (Page 18.) *)

Lemma k_lt_alphar:
  k < alphar (rankr (p x)).
Proof using is_rdsf_F x_non_root r_geq_1.
  intros.
  (* Eliminate the pesky ... + 1 on either side. *)
  eapply plus_lt_plus.
  (* By definition of [k], it suffices to prove [rankr (p x) < A (prealphar (rankr (p x)) (rankr x)]. *)
  unfold prek.
  k betaf_spec_direct_contrapositive.
  unfold defk.
  (* The lemma [A_prealphar_gt] yields [rankr (p x) < A (prealphar (rankr (p x)))],
     so the goal simplifies as follows. *)
  eapply Nat.lt_le_trans; [ eapply A_prealphar_gt | ].
  (* The result now follows from the fact that [A] is monotonic and [r] is less
     than or equal to [rankr x]. *)
  eapply Akx_monotonic_in_x. eapply r_leq_rankr.
Qed.

(* Another connection between [rankr] at [x] and at [p x]. *)

Lemma rankr_p_x_lt:
  rankr (p x) < A k (rankr x).
Proof using is_rdsf_F x_non_root r_geq_1.
  (* This holds by definition of [k]. *)
  k betaf_spec_reciprocal_contrapositive. (* tchac! *)
  { unfold k, prek. lia. }
Qed.

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

(* The index of [x] is defined as the largest [i] such that [i] iterations of
   [A prek] take us from [rankr x] to at most [rankr (p x)]. *)

Definition i :=
  betaf (fun i => iter i (A prek) (rankr x)) (rankr (p x)).
  (* If that sounds crazy: it is. *)

(* The following lemmas justify that [i] is well-defined. *)

Lemma i_exists:
  iter 0 (A prek) (rankr x) <= rankr (p x).
Proof using is_rdsf_F x_non_root.
  clear r_geq_1.
  simpl. generalize parent_has_greater_rankr. lia.
Qed.

Ltac i th :=
  unfold i; eapply th;
  eauto using iter_i_Akx_tends_to_infinity_along_i, iter_Ak_monotonic_in_i,
    i_exists.

(* [i] is at least 1. *)

Lemma i_ge_1:
  1 <= i.
Proof using is_rdsf_F x_non_root r_geq_1.
  (* By definition of [i], we must show that applying [A prek] once
     to [rankr x] takes us below or at [rankr (p x)]. *)
  i betaf_spec_reciprocal. simpl.
  (* And this is true by definition of [k]. *)
  k betaf_spec_direct. (* wow *)
Qed.

(* [i] is at most [rankr x]. *)

Lemma i_le_rank:
  i <= rankr x.
Proof using is_rdsf_F x_non_root r_geq_1.
  (* By definition of [i], we must show that applying [1 + rankr x] times
     the function [A prek] to [rankr x] takes us above [rankr (p x)]. *)
  i betaf_spec_direct_contrapositive_le.
  (* Since [rankr (p x)] is less than [A k (rankr x)], the goal simplifies
     as follows. *)
  eapply Nat.lt_le_trans. eapply rankr_p_x_lt.
  (* Now, by definition of [A], this is in fact an equality. *)
  unfold k. rewrite Nat.add_comm. rewrite Astep_eq. reflexivity.
Qed.

End NonRoot.

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

(* The potential of a vertex. *)

Definition phi x :=
  If is_root F x then
     alphar (rankr x) * (rankr x + 1)
  else If alphar (rankr x) = alphar (rankr (p x)) then
    (alphar (rankr x) - k x) * (rankr x) - i x + 1
  else
    0.

(* The total potential. *)

Definition Phi :=
  fold (monoid_make plus 0) phi D.

(* The following lemmas repeat the cases of the definition of [phi]. *)

Lemma phi_case_1:
  forall x,
  is_root F x ->
  phi x = alphar (rankr x) * (rankr x + 1).
Proof using.
  clear r_geq_1 is_rdsf_F.
  intros. unfold phi. cases_if. eauto.
Qed.

Lemma phi_case_2:
  forall x,
  ~ is_root F x ->
  alphar (rankr x) = alphar (rankr (p x)) ->
  phi x = (alphar (rankr x) - k x) * (rankr x) - i x + 1.
Proof using.
  clear r_geq_1 is_rdsf_F.
  intros. unfold phi. repeat cases_if. reflexivity.
Qed.

Lemma phi_case_3:
  forall x,
  ~ is_root F x ->
  alphar (rankr x) <> alphar (rankr (p x)) ->
  phi x = 0.
Proof using.
  clear r_geq_1 is_rdsf_F.
  intros. unfold phi. repeat cases_if. reflexivity.
Qed.

(* This lemma unifies the last two cases above. *)

Lemma phi_case_2_or_3:
  forall x,
  ~ is_root F x ->
  phi x <= (alphar (rankr x) - k x) * (rankr x) - i x + 1.
Proof using.
  clear r_geq_1.
  intros.
  tests : (alphar (rankr x) = alphar (rankr (p x))).
  { rewrite phi_case_2 by assumption. reflexivity. }
  { rewrite phi_case_3 by assumption. lia. }
Qed.

(* In case 2 above, the subtractions are safe: they cannot produce a
   negative number. The first subtraction always produces at least 1,
   while the second subtraction always produces at least 0. *)

Lemma phi_case_2_safe_k:
  forall x,
  ~ is_root F x ->
  alphar (rankr x) = alphar (rankr (p x)) ->
  k x < alphar (rankr x).
Proof using is_rdsf_F r_geq_1.
  introv ? hrank.
  forwards hk: k_lt_alphar; eauto.
  lia.
  (* We note that the equality hypothesis on the ranks is required.
     Indeed, in case 3, we could have [k x = alphar (rankr x)]. *)
Qed.

Lemma phi_case_2_safe_i:
  forall x,
  ~ is_root F x ->
  alphar (rankr x) = alphar (rankr (p x)) ->
  i x <= (alphar (rankr x) - k x) * (rankr x).
Proof using is_rdsf_F r_geq_1.
  introv ? hrank.
  rewrite i_le_rank by eauto.
  eapply mult_magnifies_left.
  forwards: phi_case_2_safe_k; eauto.
  lia.
Qed.

(* In case 1 above, [phi x] is at least 1. (Page 18.) *)

(* This property seems unused, so we do not name it. *)

Goal
  forall x,
  is_root F x ->
  1 <= phi x.
Proof using.
  clear r_geq_1.
  intros. rewrite phi_case_1 by assumption.
  eapply mult_positive.
  (* [alphar] is positive. *)
  { eapply alphar_positive. }
  (* [rankr x + 1] is not zero. *)
  { lia. }
Qed.

(* In case 2 above, [phi x] is at least 1. (Page 18.) *)

Lemma phi_case_2_lower_bound:
  forall x,
  ~ is_root F x ->
  alphar (rankr x) = alphar (rankr (p x)) ->
  1 <= phi x.
Proof using is_rdsf_F r_geq_1.
  introv h1 h2. rewrite phi_case_2 by assumption.
  forwards: phi_case_2_safe_i; eauto.
  lia.
Qed.

(* Alstrup et al. write, on page, 18, "if x is a nonroot leaf, then rankr (x) = r".
   This appears to be false: in the presence of path compression, a nonroot leaf
   can have nonzero rank. (Imagine it used to be a root with nonzero rank and (as
   per the numerous family condition) many descendants; but these descendants were
   removed by path compression.) Thus, I am unable to conclude that phi x = 0.
   This does not seem to be a problem: this remark in not exploited anywhere. *)

(* An upper bound on [phi x]. In any case, [phi x] is at most the formula that
   appears in case 1. *)

Lemma phi_upper_bound:
  forall x,
  phi x <= alphar (rankr x) * (rankr x + 1).
Proof using.
  clear r_geq_1 is_rdsf_F.
  intros. unfold phi. repeat cases_if.
  (* Case 1. *)
  { eauto. }
  (* Case 2. *)
  { lia_rewrite (alphar (rankr x) - k x <= alphar (rankr x)).
    assert (0 < alphar (rankr x)). { eapply alphar_positive. }
    generalize dependent (alphar (rankr x)). intros a ? ?.
    rewrite Nat.mul_add_distr_l.
    generalize (a * rankr x). intro ar.
    lia. }
  (* Case 3. *)
  { assert (forall x, 0 <= x). { intros. lia. }
    eauto. }
Qed.

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

(* Check the definitions shown in the paper. *)

Goal
  forall n,
  alphar n = LibMin.mmin le (fun k => A k r >= n + 1) + 1.
Proof.
  reflexivity.
Qed.

Goal
  forall x,
  rankr x = K x + r.
Proof.
  reflexivity.
Qed.

Goal
  forall x,
  k x = mmax le (fun k => rankr (p x) >= A k (rankr x)) + 1.
Proof.
  reflexivity.
Qed.

Goal
  forall x,
  i x = mmax le (fun i => rankr (p x) >= iter i (A (k x - 1)) (rankr x)).
Proof.
  intros.
  replace (k x - 1) with (prek x) by (unfold k; lia).
  reflexivity.
Qed.

Goal
  forall x,
  phi x =
    If is_root F x then
       alphar (rankr x) * (rankr x + 1)
    else If alphar (rankr x) = alphar (rankr (p x)) then
      (alphar (rankr x) - k x) * (rankr x) - i x + 1
    else
      0.
Proof.
  reflexivity.
Qed.

Goal
  Phi = fold (monoid_make plus 0) phi D.
Proof.
  reflexivity.
Qed.

End Potential.

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

(* When [D] is empty, [Phi] is zero. *)

Lemma Phi_empty:
  forall V F K,
  Phi (\{} : set V) F K = 0.
Proof using.
  intros. unfold Phi. rewrite fold_empty. reflexivity.
Qed.

(* If [x] is a root and has zero rank, then [phi x] is [r + 1]. *)

Lemma phi_root_zero_rank:
  forall V D F K x,
  @is_rdsf V D F K ->
  is_root F x ->
  K x = 0 ->
  phi F K x = r + 1.
Proof using r_geq_1.
  intros.
  rewrite phi_case_1 by assumption.
  assert (f: rankr K x = r). { unfold rankr. lia. }
  rewrite f.
  rewrite alphar_r by assumption.
  lia.
Qed.

(* Extending [D] with a new vertex augments [Phi] by [r + 1]. This relies on
   our invariant, which guarantees that [K] is zero outside [D]. *)

Lemma Phi_extend:
  forall V D F K x,
  @is_rdsf V D F K ->
  x \notin D ->
  Phi D F K + (r + 1) = Phi (D \u \{x}) F K.
Proof using r_geq_1.
  intros.
  unfold Phi.
  rewrite fold_union; eauto with finite typeclass_instances. 2: rew_set in *.
  rewrite fold_single; eauto with typeclass_instances.
  simpl.
  erewrite phi_root_zero_rank by eauto using only_roots_outside_D with is_dsf zero_rank. (* ha! *)
  reflexivity.
Qed.

End Alstrup.

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

(* Hints. *)

Hint Resolve alphar_monotonic : monotonic.

Hint Resolve rankr_positive : monotonic.
  (* used in conjunction with Akx_tends_to_infinity_along_k *)

Hint Resolve k_exists : k.

Hint Resolve i_exists iter_i_Akx_tends_to_infinity_along_i
iter_Ak_monotonic_in_i : i.

Ltac k th :=
  match goal with |- context[prek ?r ?F ?K ?x] =>
    eapply th with (f := defk r K x);
    unfold defk; eauto with k monotonic
  end.

Ltac i th :=
  match goal with |- context[i ?r ?F ?K ?x] =>
    eapply th with (f := fun i =>
      iter i
        (A (prek r F K x))
        (rankr r K x)
    ); eauto with i
  end.


Require Export Iron.Language.SystemF2Effect.Type.
Require Export Iron.Language.SystemF2Effect.Value.
Require Export Iron.Language.SystemF2Effect.Store.Bind.

(********************************************************************)
(* Small Step Evaluation (pure rules)
   These are pure transitions that don't depend on the store. *)
Inductive StepP : exp  -> exp -> Prop :=

 (* Value application. *)
 | SpAppSubst
   :  forall t11 x12 v2
   ,  StepP (XApp (VLam t11 x12) v2)
            (substVX 0 v2 x12)

 (* Type application. *)
 | SpAPPSubst
   :  forall k11 x12 t2
   ,  StepP (XAPP (VLAM k11 x12) t2)
            (substTX 0 t2 x12)

 (* Take the successor of a natural. *)
 | SpSucc
   :  forall n
   ,  StepP (XOp1 OSucc (VConst (CNat n)))
            (XVal (VConst (CNat (S n))))

 (* Test a natural for zero. *)
 | SpIsZero
   :  forall n
   ,  StepP (XOp1 OIsZero (VConst (CNat n)))
            (XVal (VConst (CBool (beq_nat n 0)))).

Hint Constructors StepP.

(********************************************************************)
(* Preservation for pure single step rules. *)
Lemma stepp_preservation
 :  forall se sp x x' t e
 ,  StepP  x x'
 -> Forall ClosedT se
 -> TypeX  nil nil se sp x  t e
 -> TypeX  nil nil se sp x' t e.
Proof.
 intros se sp x x' t e HS HC HT. gen t e.
 induction HS; intros; inverts_type; rip.

 Case "SpAppSubst".
  eapply subst_val_exp; eauto.

 Case "SpAPPSubst".
  rrwrite (TBot KEffect = substTT 0 t2 (TBot KEffect)).
  have HTE: (nil = substTE 0 t2 nil).
  have HSE: (se  = substTE 0 t2 se) by (symmetry; auto).
  rewrite HTE. rewrite HSE.
  eapply subst_type_exp; eauto.
   rrwrite (liftTE 0 se = se).
   snorm.

 Case "SpSucc".
  snorm. inverts H5. auto.

 Case "SpIsZero".
  snorm. inverts H5. auto.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                               Lib_Mult.v                                 *)
(****************************************************************************)

Require Export Lib_Plus.

Lemma plus_mult : forall n : nat, n + n = 2 * n.
intros n; simpl in |- *; elim plus_n_O; auto with arith.
Qed.
Hint Immediate plus_mult.

Lemma lt_mult_lt_O : forall n m : nat, 0 < n * m -> 0 < m -> 0 < n.
simple induction n; auto with arith.
Qed.

Lemma le_mult_cst : forall x y a : nat, x <= y -> a * x <= a * y.
intros.
elim H; auto with arith.
Qed.
Hint Immediate le_mult_cst.

Lemma le_mult_csts : forall a b c d : nat, a <= b -> c <= d -> a * c <= b * d.
intros.
apply le_trans with (a * d).
apply le_mult_cst; assumption.
elim mult_comm; elim mult_comm with d b.
apply le_mult_cst; assumption.
Qed.
Hint Immediate le_mult_csts.

Lemma lt_mult_n_Sn : forall n m : nat, 0 < m -> n * m < S n * m.
simple induction n; simple induction m; auto with arith.
intros; simpl in |- *.
elim plus_n_O; auto with arith.
intro.
elim mult_n_O; elim mult_n_O; auto with arith.
intros; simpl in |- *; apply lt_n_S; auto with arith.
Qed.
Hint Immediate lt_mult_n_Sn.

Lemma lt_mult_cst : forall x y a : nat, x < y -> 0 < a -> a * x < a * y.
intros.
elim H.
elim mult_comm; elim mult_comm with (S x) a.
apply lt_mult_n_Sn; assumption.
intros.
apply lt_trans with (a * m).
assumption.
elim mult_comm; elim mult_comm with (S m) a.
apply lt_mult_n_Sn; assumption.
Qed.
Hint Immediate lt_mult_cst.

Lemma lt_mult_csts : forall a b c d : nat, a < b -> c < d -> a * c < b * d.
intros.
apply le_lt_trans with (a * d).
apply le_mult_cst.
apply lt_le_weak; assumption.
elim mult_comm; elim mult_comm with d b.
apply lt_mult_cst.
assumption.
apply lt_O with c; auto with arith.
Qed.
Hint Immediate lt_mult_csts.

Lemma pred_mult : forall n m : nat, 0 < n -> n * m = pred n * m + m.
intros.
elim H; simpl in |- *; auto with arith.
Qed.
Hint Immediate pred_mult.

Lemma le_lt_plus_mult :
 forall n m p n' p' : nat, n <= n' -> p < p' -> n * m + p < n' * m + p'.
intros; apply le_lt_plus; auto with arith.
Qed.

Lemma le_mult_l : forall n m : nat, 0 < m -> n <= m * n.
intros.
rewrite (S_pred m 0); trivial.
simpl in |- *; auto with arith.
Qed.
Hint Immediate le_mult_l.

Lemma le_mult_r : forall n m : nat, 0 < m -> n <= n * m.
intros n m; elim (mult_comm m n); auto with arith.
Qed.
Hint Immediate le_mult_r.

Lemma lt_mult : forall n m : nat, 1 < m -> 0 < n -> n < n * m.
intros.
pattern n at 1 in |- *.
elim mult_1_r.
apply lt_mult_cst; auto with arith.
Qed.
Hint Immediate lt_mult.

Lemma lt_SO_mult : forall n m : nat, 1 < n -> 0 < m -> 1 < n * m.
intros.
apply lt_le_trans with (1 * n).
auto with arith.
simpl in |- *.
elim plus_n_O.
apply le_mult_r; auto with arith.
Qed.

Lemma plus_m_mult_n_m : forall n m : nat, m + n * m = S n * m.
simple induction n; simple induction m; simpl in |- *; auto with arith.
Qed.

Lemma y_eq_multxy : forall x y : nat, x = 1 \/ y = 0 -> y = x * y.
intros x y H; elim H; clear H; intros H; rewrite H; simpl in |- *;
 auto with arith.
Qed.

Lemma mult_plus_distr_left : forall n m p : nat, p * (n + m) = p * n + p * m.
intros; elim mult_comm.
elim (mult_comm n p).
elim (mult_comm m p).
auto with arith.
Qed.
Hint Immediate mult_plus_distr_left.

Lemma mult_minus_distr_left : forall n m p : nat, p * (n - m) = p * n - p * m.
intros.
rewrite (mult_comm p (n - m)); rewrite (mult_comm p n);
 rewrite (mult_comm p m); auto with arith.
Qed.
Hint Immediate mult_minus_distr_left.

Lemma mult_eq_zero : forall a b : nat, a * b = 0 -> a = 0 \/ b = 0.
intros a b; elim a.
auto.
intros n H_rec H.
right.
elim (plus_eq_zero (n * b) b); auto with arith.
simpl in H; elim plus_comm.
auto with arith.
Qed.
Hint Immediate mult_eq_zero.

Lemma lt_mult_S_S : forall n m : nat, 0 < S n * S m.
simple induction n; simpl in |- *; auto with arith.
Qed.
Hint Immediate lt_mult_S_S.

Lemma mult_S_O : forall n m : nat, 0 = S n * m -> 0 = m.
intros n m H.
elim (mult_eq_zero (S n) m); auto with arith.
intro; absurd (S n = 0); auto with arith.
Qed.

Lemma mult_reg_l : forall a b p : nat, p * a = p * b -> p = 0 \/ a = b.
intros a b p; generalize b; generalize a; clear a b.
simple induction a.
replace (p * 0) with 0.
intros.
cut (p = 0 \/ b = 0).
intro.
elim H0; auto with arith.
cut (p * b = 0).
elim (mult_eq_zero p b); auto with arith.
auto.
apply mult_n_O.
intros n H_rec.
simple induction b.
replace (p * 0) with 0.
intro.
apply (mult_eq_zero p (S n) H).
apply mult_n_O.
intros m H.
replace (p * S n) with (p * n + p).
replace (p * S m) with (p * m + p).
2: apply mult_n_Sm.
2: apply mult_n_Sm.
clear a; clear b.
intro.
elim (H_rec m); auto with arith.
apply (fun a b : nat => plus_reg_l a b p).
elim (plus_comm (p * n) p).
elim (plus_comm (p * m) p); trivial.
Qed.
Hint Immediate mult_reg_l.

Lemma mult_reg_l_bis : forall a b p : nat, 0 < p -> p * a = p * b -> a = b.
intros a b p H H1.
elim (mult_reg_l a b p); auto with arith.
intro; absurd (p = 0); auto with arith.
Qed.
Hint Immediate mult_reg_l_bis.

Lemma mult_eq_zero_bis : forall a b : nat, 0 < a -> a * b = 0 -> b = 0.
intros a b pos H.
elim (mult_eq_zero a b H); auto with arith.
intro h.
absurd (a = 0); auto with arith.
Qed.
Hint Immediate mult_eq_zero_bis.

Lemma lt_nm_mult : forall n m : nat, 0 < n -> 0 < m -> 0 < n * m.
intros n m H1 H2.
elim H1; elim H2; simpl in |- *; auto with arith.
Qed.
Hint Immediate lt_nm_mult.

Lemma same_quotient_order :
 forall b q q' r r' : nat, r < b -> q < q' -> q * b + r < q' * b + r'.
intros.
apply lt_le_trans with (q * b + b).
apply plus_lt_compat_l.
try trivial.
pattern b at 2 in |- *.
replace b with (1 * b).
elim mult_plus_distr_r.
apply le_trans with (q' * b).
elim (mult_comm b (q + 1)); elim (mult_comm b q').
apply le_mult_cst.
replace (q + 1) with (S q).
auto with arith.
elim plus_comm; simpl in |- *; auto with arith.
auto with arith.
simpl in |- *; auto with arith.
Qed.
Hint Immediate same_quotient_order.


(* week-01_functional-programming-in-Coq.v *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 15 Aug 2020 *)

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

(*
Your name:
Bernard Boey
Tristan Koh

Your e-mail address:
bernard@u.yale-nus.edu.sg
tristan.koh@u.yale-nus.edu.sg

Your student number:
A0191234L
A0191222R

*)

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

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

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

Definition test_add (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 1)
  &&
  (candidate 1 0 =n= 1)
  &&
  (candidate 1 1 =n= 2)
  &&
  (candidate 1 2 =n= 3)
  &&
  (candidate 2 1 =n= 3)
  &&
  (candidate 2 2 =n= 4)
  &&
  (candidate 2765 1313 =n= 4078)
  &&
  (candidate 2500 2500 =n= 5000)
  &&
  (candidate 0 5000 =n= 5000)
  &&
  (candidate 5000 0 =n= 5000)
  &&
  (candidate 1 4999 =n= 5000)
  &&
  (candidate 4999 1 =n= 5000)
  .

Fixpoint add_v1 (i j : nat) : nat :=
  match i with
    | O => j
    | S i' => S (add_v1 i' j)
  end.

Compute (test_add add_v1).

Fixpoint add_v2 (i j : nat) : nat :=
  match i with
    | O => j
    | S i' => add_v2 i' (S j)
  end.

Compute (test_add add_v2).

Definition add_v3 (i j : nat) : nat :=
  let fix visit n :=
    match n with
      | O => j
      | S n' => S (visit n')
    end
  in visit i.

Compute (test_add add_v3).

Definition add_v4 (i j : nat) : nat :=
  let fix visit n a :=
    match n with
      | O => a
      | S n' => visit n' (S a)
    end
  in visit i j.

Compute (test_add add_v4).

(* ***** *)

(* Exercise 1 *)

Definition test_mul (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 0)
  &&
  (candidate 1 0 =n= 0)
  &&
  (candidate 1 1 =n= 1)
  &&
  (candidate 1 2 =n= 2)
  &&
  (candidate 2 1 =n= 2)
  &&
  (candidate 2 2 =n= 4)
  .

Fixpoint mul_v1 (i j : nat) : nat :=
  match i with
    | O => O
    | S i' => add_v4 j (mul_v1 i' j)
  end.

Compute (test_mul mul_v1).

Definition mul_v2 (i j : nat) : nat :=
  let fix visit n :=
    match n with
      | O => O
      | S n' => add_v4 j (visit n')
    end
  in visit i.

Compute (test_mul mul_v2).

Definition mul_v3 (i j : nat) : nat :=
  let fix visit n a :=
    match n with
      | O => a
      | S n' => visit n' (add_v4 j a)
    end
  in visit i O.

Compute (test_mul mul_v3).

(* ***** *)

Definition test_power (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 1)
  &&
  (candidate 0 1 =n= 0)
  &&
  (candidate 1 0 =n= 1)
  &&
  (candidate 1 1 =n= 1)
  &&
  (candidate 1 2 =n= 1)
  &&
  (candidate 2 1 =n= 2)
  &&
  (candidate 2 2 =n= 4)
  &&
  (candidate 3 2 =n= 9)
  &&
  (candidate 2 3 =n= 8)
  &&
  (candidate 3 3 =n= 27)
  .

Fixpoint power_v1 (x n : nat) : nat :=
  match n with
    | O => 1
    | S n' => mul_v3 x (power_v1 x n')
  end.

Compute (test_power power_v1).

Definition power_v2 (x n : nat) : nat :=
  let fix visit i :=
    match i with
      | O => 1
      | S i' => mul_v3 x (visit i')
    end
  in visit n.

Compute (test_power power_v2).

Definition power_v3 (x n: nat) : nat :=
  let fix visit i a :=
    match i with
      | O => a
      | S i' => visit i' (mul_v3 x a)
    end
  in visit n 1.

Compute (test_power power_v3).

(* ***** *)

Definition test_fac (candidate: nat -> nat) : bool :=
  (candidate 0 =n= 1)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 2)
  &&
  (candidate 3 =n= 6)
  &&
  (candidate 4 =n= 24)
  &&
  (candidate 5 =n= 120)
  &&
  (candidate 6 =n= 720)
  .

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

Compute (test_fac fac_v1).

Definition fac_v2 (n : nat) : nat :=
  let fix visit i :=
    match i with
      | O => 1
      | S i' => mul_v3 i (visit i')
    end
  in visit n.

Compute (test_fac fac_v2).

Definition fac_v3 (n : nat) : nat :=
  let fix visit i a :=
    match i with
      | O => a
      | S i' => visit i' (mul_v3 i a)
    end
  in visit n 1.

Compute (test_fac fac_v3).

(* ***** *)

Definition test_fib (candidate: nat -> nat) : bool :=
  (candidate 0 =n= 0)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 1)
  &&
  (candidate 3 =n= 2)
  &&
  (candidate 4 =n= 3)
  &&
  (candidate 5 =n= 5)
  &&
  (candidate 6 =n= 8)
  &&
  (candidate 7 =n= 13)
  &&
  (candidate 8 =n= 21)
  &&
  (candidate 9 =n= 34)
  &&
  (candidate 10 =n= 55)
  .

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

Compute (test_fib fib_v1).

Definition fib_v2 (n : nat) : nat :=
  let fix visit n :=
      match n with
      | O => O
      | S n' => match n' with
                | O => 1
                | S n'' => add_v3 (visit n') (visit n'')
                end
      end
  in visit n.

Compute (test_fib fib_v2).

Definition fib_v3 (n : nat) : nat :=
  let fix visit n f0 f1:=
      match n with
      | O => f0
      | S n' => visit n' (add_v3 f0 f1) f0
      end
  in visit n 0 1.

Compute (test_fib fib_v3).

(* ***** *)

Notation "A =b= B" :=
  (eqb A B) (at level 70, right associativity).

Definition test_even (candidate: nat -> bool) : bool :=
  (candidate 0 =b= true)
  &&
  (candidate 1 =b= false)
  &&
  (candidate 2 =b= true)
  &&
  (candidate 3 =b= false)
  &&
  (candidate 4 =b= true)
  &&
  (candidate 5 =b= false)
  &&
  (candidate 6 =b= true)
  &&
  (candidate 7 =b= false)
  &&
  (candidate 8 =b= true)
  .

Fixpoint even_v1 (n : nat) : bool :=
  match n with
    | O => true
    | S n' => negb (even_v1 n')
  end.

Compute (test_even even_v1).

Definition even_v2 (n : nat) : bool :=
  let fix visit n :=
    match n with
      | O => true
      | S n' => negb (visit n')
    end
  in visit n.

Compute (test_even even_v2).

Definition even_v3 (n : nat) : bool :=
  let fix visit n a :=
    match n with
      | O => a
      | S n' => visit n' (negb a)
    end
  in visit n true.

Compute (test_even even_v3).

(* ***** *)

Definition test_odd (candidate: nat -> bool) : bool :=
  (candidate 0 =b= false)
  &&
  (candidate 1 =b= true)
  &&
  (candidate 2 =b= false)
  &&
  (candidate 3 =b= true)
  &&
  (candidate 4 =b= false)
  &&
  (candidate 5 =b= true)
  &&
  (candidate 6 =b= false)
  &&
  (candidate 7 =b= true)
  &&
  (candidate 8 =b= false)
  .

Fixpoint odd_v1 (n : nat) : bool :=
  match n with
    | O => false
    | S n' => negb (odd_v1 n')
  end.

Compute (test_odd odd_v1).

Definition odd_v2 (n : nat) : bool :=
  let fix visit n :=
    match n with
      | O => false
      | S n' => negb (visit n')
    end
  in visit n.

Compute (test_odd odd_v2).

Definition odd_v3 (n : nat) : bool :=
  let fix visit n a :=
    match n with
      | O => a
      | S n' => visit n' (negb a)
    end
  in visit n false.

Compute (test_odd odd_v3).

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

(* Exercise 2 *)

Inductive binary_tree :=
| Leaf : nat -> binary_tree
| Node : binary_tree -> binary_tree -> binary_tree.

Fixpoint beq_binary_tree (t1 t2 : binary_tree) : bool :=
  match t1 with
    Leaf n1 =>
    match t2 with
      Leaf n2 =>
      n1 =n= n2
    | Node t21 t22 =>
      false
    end
  | Node t11 t12 =>
    match t2 with
      Leaf n2 =>
      false
    | Node t21 t22 =>
      (beq_binary_tree t11 t21) && (beq_binary_tree t12 t22)
    end
  end.

Notation "A =bt= B" :=
  (beq_binary_tree A B) (at level 70, right associativity).

(* Number of nodes of a tree *)

(* Unit test *)

Definition test_number_of_nodes (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 10) =n= 0)
  &&
  (candidate (Node (Leaf 10)
                   (Leaf 20)) =n= 1)
  &&
  (candidate (Node (Leaf 10)
                   (Node (Leaf 20)
                         (Leaf 30))) =n= 2)
  &&
  (candidate (Node (Node (Leaf 10)
                            (Leaf 20))
                   (Leaf 30)) =n= 2)
  &&
  (candidate (Node (Node (Node (Leaf 30)
                               (Leaf 31))
                         (Leaf 20))
                   (Node (Leaf 21)
                         (Node (Leaf 32)
                               (Leaf 33))))
   =n= 5)
  &&
  (candidate (Node (Node (Node (Leaf 30)
                               (Node (Leaf 40)
                                     (Leaf 41)))
                         (Leaf 20))
                   (Node (Leaf 21)
                         (Node (Leaf 31)
                               (Leaf 21))))
   =n= 6).

(* Definition *)

Fixpoint number_of_nodes (t : binary_tree) : nat :=
  match t with
  | Leaf n =>
    0
  | Node t1 t2 =>
    S ((number_of_nodes t1) + (number_of_nodes t2))
  end.

Compute (test_number_of_nodes number_of_nodes).

(* Smallest leaf *)

(* Unit test *)
Definition test_smallest_leaf (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 10) =n= 10)
  &&
  (candidate (Node (Leaf 10)
                   (Leaf 20)) =n= 10)
  &&
  (candidate (Node (Leaf 10)
                   (Node (Leaf 20)
                         (Leaf 30))) =n= 10)
  &&
  (candidate (Node (Node (Leaf 20)
                            (Leaf 20))
                   (Leaf 30)) =n= 20)
  &&
  (candidate (Node (Node (Leaf 30)
                            (Leaf 40))
                   (Leaf 100)) =n= 30).

(* Function *)

Fixpoint smallest_leaf (t: binary_tree) : nat :=
  match t with
  | Leaf n => n
  | Node t1 t2 =>
    min (smallest_leaf t1) (smallest_leaf t2)
  end.

Compute (test_smallest_leaf smallest_leaf).

(* Weight of binary tree - Sum of integers in the leaves *)

Definition test_weight (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 10) =n= 10)
  &&
  (candidate (Node (Leaf 10)
                   (Leaf 20)) =n= 30)
  &&
  (candidate (Node (Leaf 10)
                   (Node (Leaf 20)
                         (Leaf 30))) =n= 60)
  &&
  (candidate (Node (Node (Leaf 10)
                            (Leaf 20))
                   (Leaf 30)) =n= 60)
  &&
  (candidate (Node (Node (Leaf 20)
                            (Leaf 20))
                   (Leaf 100)) =n= 140).

Fixpoint weight (t: binary_tree) : nat :=
  match t with
  | Leaf n =>
    n
  | Node t1 t2 =>
    (weight t1) + (weight t2)
  end.

Compute (test_weight weight).

(* Height of binary tree *)

(* Unit test *)

Definition test_height (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 10)
   =n= 0)
  &&
  (candidate (Node (Leaf 10)
                   (Leaf 20))
   =n= 1)
  &&
  (candidate (Node (Leaf 10)
                   (Node (Leaf 20)
                         (Leaf 30)))
   =n= 2)
  &&
  (candidate (Node (Leaf 10)
                   (Node (Leaf 20)
                         (Node (Leaf 30)
                               (Leaf 31))))
   =n= 3)
  &&
  (candidate (Node (Node (Node (Leaf 30)
                               (Leaf 31))
                         (Leaf 20))
                   (Node (Leaf 21)
                         (Node (Leaf 32)
                               (Leaf 33))))
   =n= 3)
  &&
  (candidate (Node (Node (Node (Leaf 30)
                               (Node (Leaf 40)
                                     (Leaf 41)))
                         (Leaf 20))
                   (Node (Leaf 21)
                         (Node (Leaf 31)
                               (Leaf 21))))
   =n= 4)
  &&
  (candidate (Node (Leaf 10)
                   (Node (Leaf 20)
                         (Node (Leaf 30)
                               (Node (Leaf 40)
                                     (Node (Leaf 50)
                                           (Node (Leaf 60)
                                                 (Node (Leaf 70)
                                                       (Leaf 71))))))))
   =n= 7).

(* Function *)

Fixpoint height (t: binary_tree) : nat :=
  match t with
  | Leaf n =>
    0
  | Node t1 t2 =>
    S(max (height t1) (height t2))
  end.

Compute (test_height height).

(* Well balancedness of a mobile *)

Definition test_well_balanced (candidate: binary_tree -> bool) : bool :=
  (candidate (Leaf 1)
   =b= true)
  &&
  (candidate (Node (Leaf 1)
                   (Leaf 1))
   =b= true)
  &&
  (candidate (Node (Leaf 1)
                   (Leaf 2))
   =b= false)
  &&
  (candidate (Node (Leaf 2)
                     (Leaf 1))
   =b= false)
  &&
  (candidate (Node (Node (Leaf 1)
                         (Leaf 1))
                   (Leaf 2))
   =b= true)
  &&
  (candidate (Node (Leaf 2)
                   (Node (Leaf 1)
                         (Leaf 1)))
   =b= true)
  &&
  (candidate (Node (Node (Leaf 2)
                         (Node (Leaf 1)
                               (Leaf 1)))
                   (Node (Node (Node (Leaf 1)
                                     (Leaf 1))
                               (Node (Leaf 1)
                                     (Leaf 1)))
                         (Leaf 6)))
   =b= false)
  &&
  (candidate (Node (Node (Leaf 4)
                         (Node (Leaf 2)
                               (Leaf 2)))
                   (Node (Node (Node (Leaf 2)
                                     (Leaf 1))
                               (Node (Leaf 1)
                                     (Leaf 2)))
                         (Leaf 6)))
   =b= false).

Inductive option :=
| None : option
| Some : nat -> option.

(* Function *)

(* Lambda dropped version *)

Definition well_balanced (t: binary_tree) : bool :=
  let fix visit t :=
      match t with
      | Leaf n => Some n
      | Node t1 t2 =>
        match visit t1 with
        | None => None
        | Some w1 =>
          (match visit t2 with
           | None => None
           | Some w2 =>
             if w1 =n= w2
             then Some (w1 + w2)
             else None
           end)
        end
      end
  in match visit t with
     | None => false
     | Some w => true
     end.

Compute (test_well_balanced well_balanced).

(* Mirror *)
Definition test_mirror (candidate: binary_tree -> binary_tree) : bool :=
  (candidate
     (Leaf 1)
   =bt= (Leaf 1))
  &&
  (candidate
     (Node (Leaf 10)
           (Leaf 20))
   =bt= (Node (Leaf 20)
           (Leaf 10)))
  &&
  (candidate
     (Node (Leaf 10)
           (Node (Leaf 20)
                 (Leaf 30)))
   =bt= (Node (Node (Leaf 30)
                 (Leaf 20))
           (Leaf 10)))
  &&
  (candidate
     (Node (Node (Leaf 10)
                 (Leaf 20))
           (Node (Leaf 30)
                 (Leaf 40)))
   =bt= (Node (Node (Leaf 40)
                 (Leaf 30))
           (Node (Leaf 20)
                 (Leaf 10)))).

(* Function *)
Fixpoint mirror (t: binary_tree) : binary_tree :=
  match t with
  | Leaf n => Leaf n
  | Node t1 t2 =>
    Node (mirror t2) (mirror t1)
  end.

Compute (test_mirror mirror).

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

(* Exercise 3 *)

Inductive binary_tree' :=
| Leaf' : binary_tree'
| Node' : binary_tree' -> nat -> binary_tree' -> binary_tree'.

Definition test_number_of_leaves' (candidate: binary_tree' -> nat) : bool :=
  (candidate Leaf' =n= 1)
  &&
  (candidate (Node' Leaf'
                    42
                    Leaf') =n= 2)
  &&
  (candidate (Node' Leaf'
                    42
                    (Node' Leaf'
                           42
                           Leaf')) =n= 3)
  &&
  (candidate (Node' (Node' Leaf'
                           42
                           Leaf')
                    42
                    Leaf') =n= 3)
  &&
  (candidate (Node' (Node' Leaf'
                           42
                           Leaf')
                    42
                    (Node' Leaf'
                           42
                           Leaf')) =n= 4)
  &&
  (candidate (Node' (Node' Leaf'
                           42
                           Leaf')
                    42 (Node' Leaf'
                              42 (Node' Leaf'
                                        42
                                        Leaf'))) =n= 5)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           Leaf')
                    42
                    (Node' Leaf'
                           42
                           Leaf')) =n= 5)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           Leaf')
                    42
                    (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           Leaf')) =n= 6)
  &&
  (candidate (Node' (Node' Leaf'
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))
                    42
                    (Node' Leaf'
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 6)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))
                    42
                    (Node' Leaf'
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 7)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           Leaf')
                    42
                    (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 7)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))
                    42
                    (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 8)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           (Node' Leaf'
                                  42
                                  (Node' Leaf'
                                         42
                                         Leaf')))
                    42
                    (Node' Leaf'
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 8)
  .

Fixpoint number_of_leaves'_v0 (t : binary_tree') : nat :=
  match t with
  | Leaf' => 1
  | Node' t1 n t2 => (number_of_leaves'_v0 t1) + (number_of_leaves'_v0 t2)
  end.

Compute (test_number_of_leaves' number_of_leaves'_v0).

Definition number_of_leaves'_v1 (t : binary_tree') : nat :=
  let fix visit t a :=
      match t with
      | Leaf' => S a
      | Node' t1 n t2 => visit t2 (visit t1 a)
      end
  in visit t 0.

Compute (test_number_of_leaves' number_of_leaves'_v1).

Definition test_number_of_nodes' (candidate: binary_tree' -> nat) : bool :=
  (candidate Leaf' =n= 0)
  &&
  (candidate (Node' Leaf'
                    42
                    Leaf') =n= 1)
  &&
  (candidate (Node' Leaf'
                    42
                    (Node' Leaf'
                           42
                           Leaf')) =n= 2)
  &&
  (candidate (Node' (Node' Leaf'
                           42
                           Leaf')
                    42
                    Leaf') =n= 2)
  &&
  (candidate (Node' (Node' Leaf'
                           42
                           Leaf')
                    42
                    (Node' Leaf'
                           42
                           Leaf')) =n= 3)
  &&
  (candidate (Node' (Node' Leaf'
                           42
                           Leaf')
                    42
                    (Node' Leaf'
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 4)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           Leaf')
                    42
                    (Node' Leaf'
                           42
                           Leaf')) =n= 4)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           Leaf')
                    42
                    (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           Leaf')) =n= 5)
  &&
  (candidate (Node' (Node' Leaf'
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))
                    42
                    (Node' Leaf'
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 5)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))
                    42
                    (Node' Leaf'
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 6)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           Leaf')
                    42
                    (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 6)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))
                    42
                    (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 7)
  &&
  (candidate (Node' (Node' (Node' Leaf'
                                  42
                                  Leaf')
                           42
                           (Node' Leaf'
                                  42
                                  (Node' Leaf'
                                         42
                                         Leaf')))
                    42
                    (Node' Leaf'
                           42
                           (Node' Leaf'
                                  42
                                  Leaf'))) =n= 7)
  .

Fixpoint number_of_nodes'_v0 (t : binary_tree') : nat :=
  match t with
  | Leaf' => O
  | Node' t1 n t2 => S ((number_of_nodes'_v0 t1) + (number_of_nodes'_v0 t2))
  end.

Compute (test_number_of_nodes' number_of_nodes'_v0).

Definition number_of_nodes'_v1 (t : binary_tree') : nat :=
  match number_of_leaves'_v1 t with
  | O => O
  | S n' => n'
  end.

Compute (test_number_of_nodes' number_of_nodes'_v1).

Definition number_of_nodes'_v2 (t : binary_tree') : nat :=
  let fix visit t a :=
      match t with
      | Leaf' => a
      | Node' t1 n t2 => visit t2 (visit t1 (S a))
      end
  in visit t 0.

Compute (test_number_of_nodes' number_of_nodes'_v2).

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

(* Exercise 4 *)

Inductive binary_tree'' :=
| Leaf'' : nat -> binary_tree''
| Node'' : binary_tree'' -> nat -> binary_tree'' -> binary_tree''.

Definition test_number_of_leaves'' (candidate: binary_tree'' -> nat) : bool :=
  (candidate (Leaf'' 21) =n= 1)
  &&
  (candidate (Node'' (Leaf'' 21)
                    42
                    (Leaf'' 21)) =n= 2)
  &&
  (candidate (Node'' (Leaf'' 21)
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))) =n= 3)
  &&
  (candidate (Node'' (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))
                    42
                    (Leaf'' 21)) =n= 3)
  &&
  (candidate (Node'' (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))) =n= 4)
  &&
  (candidate (Node'' (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))
                    42 (Node'' (Leaf'' 21)
                              42 (Node'' (Leaf'' 21)
                                        42
                                        (Leaf'' 21)))) =n= 5)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Leaf'' 21))
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))) =n= 5)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Leaf'' 21))
                    42
                    (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Leaf'' 21))) =n= 6)
  &&
  (candidate (Node'' (Node'' (Leaf'' 21)
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))) =n= 6)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))) =n= 7)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Leaf'' 21))
                    42
                    (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))) =n= 7)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))
                    42
                    (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))) =n= 8)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Node'' (Leaf'' 21)
                                         42
                                         (Leaf'' 21))))
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))) =n= 8)
  .

Fixpoint number_of_leaves''_v0 (t : binary_tree'') : nat :=
  match t with
  | Leaf'' n => 1
  | Node'' t1 n t2 => (number_of_leaves''_v0 t1) + (number_of_leaves''_v0 t2)
  end.

Compute (test_number_of_leaves'' number_of_leaves''_v0).

Definition number_of_leaves''_v1 (t : binary_tree'') : nat :=
  let fix visit t a :=
      match t with
      | Leaf'' n => S a
      | Node'' t1 n t2 => visit t2 (visit t1 a)
      end
  in visit t 0.

Compute (test_number_of_leaves'' number_of_leaves''_v1).

Definition test_number_of_nodes'' (candidate: binary_tree'' -> nat) : bool :=
  (candidate (Leaf'' 21) =n= 0)
  &&
  (candidate (Node'' (Leaf'' 21)
                    42
                    (Leaf'' 21)) =n= 1)
  &&
  (candidate (Node'' (Leaf'' 21)
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))) =n= 2)
  &&
  (candidate (Node'' (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))
                    42
                    (Leaf'' 21)) =n= 2)
  &&
  (candidate (Node'' (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))) =n= 3)
  &&
  (candidate (Node'' (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))
                    42 (Node'' (Leaf'' 21)
                              42 (Node'' (Leaf'' 21)
                                        42
                                        (Leaf'' 21)))) =n= 4)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Leaf'' 21))
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Leaf'' 21))) =n= 4)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Leaf'' 21))
                    42
                    (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Leaf'' 21))) =n= 5)
  &&
  (candidate (Node'' (Node'' (Leaf'' 21)
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))) =n= 5)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))) =n= 6)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Leaf'' 21))
                    42
                    (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))) =n= 6)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))
                    42
                    (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))) =n= 7)
  &&
  (candidate (Node'' (Node'' (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21))
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Node'' (Leaf'' 21)
                                         42
                                         (Leaf'' 21))))
                    42
                    (Node'' (Leaf'' 21)
                           42
                           (Node'' (Leaf'' 21)
                                  42
                                  (Leaf'' 21)))) =n= 7)
  .

Fixpoint number_of_nodes''_v0 (t : binary_tree'') : nat :=
  match t with
  | Leaf'' n => O
  | Node'' t1 n t2 => S ((number_of_nodes''_v0 t1) + (number_of_nodes''_v0 t2))
  end.

Compute (test_number_of_nodes'' number_of_nodes''_v0).

Definition number_of_nodes''_v1 (t : binary_tree'') : nat :=
  match number_of_leaves''_v1 t with
  | O => O
  | S n' => n'
  end.

Compute (test_number_of_nodes'' number_of_nodes''_v1).

Definition number_of_nodes''_v2 (t : binary_tree'') : nat :=
  let fix visit t a :=
      match t with
      | Leaf'' n => a
      | Node'' t1 n t2 => visit t2 (visit t1 (S a))
      end
  in visit t 0.

Compute (test_number_of_nodes'' number_of_nodes''_v2).

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

(* end of week-01_functional-programming-in-Coq.v *)


(** CS6225 Spring 2020 @ IITM : Problem Set 7 *)

Require Import Frap.

(* Authors:
 * Ben Sherman (sherman@csail.mit.edu),
 * Joonwon Choi (joonwonc@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

(* In this problem set, we will work with the following simple imperative language with
 * a nondeterministic choice operator. Your task is to define both big-step as well as
 * a particular kind of small-step operational semantics for this language
 * (one that is in fact deterministic), and to prove a theorem connecting the two:
 * if the small-step semantics aborts, then the big-step semantics may abort.
 *
 * This is the first problem set so far in this class that is truly open-ended.
 * We want to give you the flexibility to define the operational semantics as
 * you wish, and if you'd like you may even differ from the template shown here
 * if you find it more convenient.
 * Additionally, this is the first problem set where it is *NOT* sufficient to
 * just get the file compiling without any use of [admit] or [Admitted].
 * This will not necessarily guarantee that you have given reasonable semantics
 * for the programming language, and accordingly, will not necessarily
 * guarantee that you will earn full credit. For instance, if you define
 * your small-step semantics as the empty relation (which is incorrect),
 * the theorem you must prove to connect your big-step and small-step
 * semantics will be trivial.
 *)

(** * Syntax *)

(* Basic arithmetic expressions, as we've seen several times in class. *)
Inductive arith : Set :=
| Const : nat -> arith
| Var : var -> arith
| Plus : arith -> arith -> arith
| Eq : arith -> arith -> arith
(* should return 1 if the two expressions are equal, and 0 otherwise. *)
| Lt : arith -> arith -> arith
(* should return 1 if the first expression is less than then second, and 0 otherwise. *)
.

(* The simple imperative language with a [Choose] syntax for
 * nondeterminism. The intended meaning of the program
 * [Choose c c'] is that either [c] should run or [c'] should run.
 *)
Inductive cmd :=
| Assign : var -> arith -> cmd
| Skip : cmd
| Seq : cmd -> cmd -> cmd
| Choose : cmd -> cmd -> cmd (* Here's the main novelty: nondeterministic choice *)
| If : arith -> cmd (* then *) -> cmd (* else *) -> cmd
| While : arith -> cmd -> cmd
| Abort : cmd (* This command should immediately terminate the program *)
.

(** Notations *)

Delimit Scope cmd_scope with cmd.

Coercion Const : nat >-> arith.
Coercion Var : var >-> arith.
Infix "+" := Plus : arith_scope.
Infix "==" := Eq (at level 75) : arith_scope.
Infix "<" := Lt : arith_scope.
Delimit Scope arith_scope with arith.
Notation "x <- e" := (Assign x e%arith) (at level 75) : cmd_scope.
Infix "<|>" := Choose (at level 78) : cmd_scope.
Infix ";;" := Seq (at level 80) : cmd_scope.

Notation "'if_' c 'then' t 'else' f" := (If c%arith t f) (at level 75) : cmd_scope.
Notation "'while' c 'do' p" := (While c%arith p) (at level 75) : cmd_scope.

(** * Examples *)

(* All nondeterministic realizations of [test_prog1] terminate
 * (either normally or by aborting). [test_prog1 5] may abort,
 * but [test_prog1 6] always terminates normally.
 *)
Definition test_prog1 (k : nat) : cmd := (
  "target" <- 8 ;;
  ("x" <- 3 <|> "x" <- 4) ;;
  ("y" <- 1 <|> "y" <- k) ;;
  if_ "x" + "y" == "target"
     then Abort
     else Skip
  )%cmd.

(* No matter the value of [num_iters], [test_prog2 num_iters]
 * always may potentially fail to terminate, and always
 * may potentially abort.
 *)
Definition test_prog2 (num_iters : nat) : cmd := (
   "acc" <- 0 ;;
   "n" <- 0;;
   while ("n" < 1) do (
     (Skip <|> "n" <- 1) ;;
     "acc" <- "acc" + 1
   ) ;;
   if_ "acc" == S num_iters
     then Abort
     else Skip
  )%cmd.

(* We've seen the expression language in class a few times,
 * so here we'll just give you the interpreter for that
 * expression language.
 *)
Definition valuation := fmap var nat.

Fixpoint interp (e : arith) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x =>
    match v $? x with
    | None => 0
    | Some n => n
    end
  | Plus e1 e2 => interp e1 v + interp e2 v
  | Eq e1 e2 => if interp e1 v ==n interp e2 v then 1 else 0
  | Lt e1 e2 => if lt_dec (interp e1 v) (interp e2 v) then 1 else 0
  end.

(** ** Part 1: Big-step operational semantics *)

(* You should define some result type (say, [result]) for values that commands
   in the language run to, and define a big-step operational semantics
   [eval : valuation -> cmd -> result -> Prop]
   that says when a program *may* run to some result in *some* nondeterministic
   realization of the program. Then you should also define a predicate
   [big_aborted : result -> Prop]
   that describes which results indicate that the program aborted.
 *)

Definition result : Type.
Admitted.

(* 5 points *)
Definition eval : valuation -> cmd -> result -> Prop.
Admitted.

Definition big_aborted : result -> Prop.
Admitted.

(* Prove that your big-step semantics behaves appropriately
 * for the example program:
 *)

(* 5 points *)
Example test_prog1_reachable :
  exists res, eval $0 (test_prog1 5) res /\ big_aborted res.
Proof.
Admitted.

(* 5 points *)
Example test_prog1_unreachable :
  forall res, eval $0 (test_prog1 6) res -> big_aborted res -> False.
Proof.
Admitted.

  (** ** Part 2: Small-step deterministic operational semantics *)

(* Next, you should define a small-step operational semantics for this
   language that in some sense tries to run *all* possible nondeterministic
   realizations and aborts if any possible realization aborts.
   Define a type [state] that represents the underlying state that the
   small-step semantics should take steps on, and then define a small-step
   semantics
   [step : state -> state -> Prop]
   .

   Here's the twist: we ask that you define an operational semantics that
   is *deterministic*, in the sense of the following formal statement:
   [forall s1 s2 s2', step s1 s2 -> step s1 s2' -> s2 = s2'].

   The operational model that we have in mind in this: when we encounter
   a nondeterministic choice, we execute the left branch. If the left
   branch terminates without aborting, we backtrack and try the
   other nondeterministic choice.

   Note that if any possible realization does not terminate,
   we allow the deterministic small-step semantics to diverge as well.
   (It is actually possible to define a semantics that always "finds" aborts,
   even if some branches of nondeterminism diverge!  However, the proof of that
   variant would likely be significantly more complicated, and we haven't tried
   it ourselves.)

   Define a function
   [init : valuation -> cmd -> state]
   that builds starting states for the small-step semantics,
   a predicate
   [small_aborted : state -> Prop]
   that describes which states are considered aborted, and
   a predicate
   [small_terminated : state -> Prop]
   that describes states that have run to completion without any
   nondeterministic branch aborting.
 *)

Definition state : Type.
Admitted.

(* 5 points *)
Definition step : state -> state -> Prop.
Admitted.

Definition init : valuation -> cmd -> state.
Admitted.

Definition small_aborted : state -> Prop.
Admitted.

Definition small_terminated : state -> Prop.
Admitted.

(* Prove that your small-step semantics behaves appropriately
 * for the example program:
 *)

(* 5 points *)
Example test_prog1_reachable_small :
  exists st, step^* (init $0 (test_prog1 5)) st /\ small_aborted st.
Proof.
Admitted.

(* 5 points *)
Example test_prog1_unreachable_small :
  forall st, step^* (init $0 (test_prog1 6)) st -> small_aborted st -> False.
Proof.
Admitted.

(** ** Part 3: A lemma on big step semantics *)

(* 10 points *)
Lemma lem: forall c1 c2 c3 v res,
  eval v (c1;;(c2;;c3))%cmd res ->
  eval v ((c1;;c2);;c3)%cmd res.
Proof.
Admitted.

(** ** Part 4: Connection between big- and small-step semantics *)

(* Prove the following theorem demonstrating the connection between the big-step
 * and small-step semantics:
 *
 * If the small-step semantics aborts, then the big-step semantics may
 * potentially abort.
 *)

(* 40 points *)
Theorem small_abort_big_may_abort : forall v c s,
         step^* (init v c) s
      -> small_aborted s
      -> exists res, eval v c res /\ big_aborted res.
Proof.
Admitted.

 (* As an additional challenge, you  you may want to prove the following
 * theorem. Note that this is *NOT* required for this assignment and
 * will not affect your grade.
 *
 * If the small-step semantics terminates without aborting, then the
 * big-step semantics may *not* abort.
 *)

(*
Theorem small_terminates_big_will_not_abort :
       forall v c s,
         step^* (init v c) s
      -> small_terminated s
      -> forall res,
             eval v c res
          -> big_aborted res
          -> False.
Proof.
Admitted.
*)


(* Test patterns unification *)

Lemma l1 : (forall P, (exists x:nat, P x) -> False)
         -> forall P, (exists x:nat, P x /\ P x) -> False.
Proof.
intros; apply (H _ H0).
Qed.

Lemma l2 :  forall A:Set, forall Q:A->Set,
           (forall (P: forall x:A, Q x -> Prop),
                   (exists x:A, exists y:Q x, P x y) -> False)
         -> forall (P: forall x:A, Q x -> Prop),
                   (exists x:A, exists y:Q x, P x y /\ P x y) -> False.
Proof.
intros; apply (H _ H0).
Qed.

Lemma l3 : (forall P, ~(exists x:nat, P x))
         -> forall P:nat->Prop, ~(exists x:nat, P x -> P x).
Proof.
intros; apply H.
Qed.

(* Example submitted for Zenon *)

Axiom zenon_noteq : forall T : Type, forall t : T, ((t <> t) -> False).
Axiom zenon_notall : forall T : Type, forall P : T -> Prop,
  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).

  (* Must infer "P := fun x => x=x" in zenon_notall *)
Check (fun _h1 => (zenon_notall nat _ (fun _T_0 =>
          (fun _h2 => (zenon_noteq _ _T_0 _h2))) _h1)).

(* Core of an example submitted by Ralph Matthes (#849)

   It used to fail because of the K-variable x in the type of "sum_rec ..."
   which was not in the scope of the evar ?B. Solved by a head
   beta-reduction of the type "(fun _ : unit + unit => L unit) x" of
   "sum_rec ...". Shall we used more reduction when solving evars (in
   real_clean)?? Is there a risk of starting too long reductions?

   Note that the example originally came from a non re-typable
   pretty-printed term (the checked term is actually re-printed the
   same form it is checked).
*)

Set Implicit Arguments.
Inductive L (A:Set) : Set := c : A -> L A.
Parameter f: forall (A:Set)(B:Set), (A->B) -> L A -> L B.
Parameter t: L (unit + unit).

Check (f (fun x : unit + unit =>
  sum_rec (fun _ : unit + unit => L unit)
    (fun y => c y) (fun y => c y) x) t).

(* Test patterns unification in apply *)

Require Import Arith.
Parameter x y : nat.
Parameter G:x=y->x=y->Prop.
Parameter K:x<>y->x<>y->Prop.
Lemma l4 : (forall f:x=y->Prop, forall g:x<>y->Prop,
            match eq_nat_dec x y with left a => f a | right a => g a end)
   -> match eq_nat_dec x y with left a => G a a | right a => K a a end.
Proof.
intros.
apply H.
Qed.

(* Test unification modulo eta-expansion (if possible) *)

(* In this example, two instances for ?P (argument of hypothesis H) can be
   inferred (one is by unifying the type [Q true] and [?P true] of the
   goal and type of [H]; the other is by unifying the argument of [f]);
   we need to unify both instances up to allowed eta-expansions of the
   instances (eta is allowed if the meta was applied to arguments)

   This used to fail before revision 9389 in trunk
*)

Lemma l5 :
   forall f : (forall P, P true), (forall P, f P = f P) ->
   forall Q, f (fun x => Q x) = f (fun x => Q x).
Proof.
intros.
apply H.
Qed.

(* Test instanciation of evars by unification *)

Goal (forall x, 0 + x = 0 -> True) -> True.
intros; eapply H.
rewrite <- plus_n_Sm. (* should refine ?x with S ?x' *)
Abort.

(* Check handling of identity equation between evars *)
(* The example failed to pass until revision 10623 *)

Lemma l6 :
  (forall y, (forall x, (forall z, y = 0 -> y + z = 0) -> y + x = 0) -> True)
  -> True.
intros.
eapply H.
intros.
apply H0. (* Check that equation ?n[H] = ?n[H] is correctly considered true *)
reflexivity.
Qed.

(* Check treatment of metas erased by K-redexes at the time of turning
   them to evas *)

Inductive nonemptyT (t : Type) : Prop := nonemptyT_intro : t -> nonemptyT t.
Goal True.
try case nonemptyT_intro. (* check that it fails w/o anomaly *)
Abort.

(* Test handling of return type and when it is decided to make the
   predicate dependent or not - see "bug" #1851 *)

Goal forall X (a:X) (f':nat -> X), (exists f : nat -> X, True).
intros.
exists (fun n => match n with O => a | S n' => f' n' end).
constructor.
Qed.

(* Check use of types in unification (see Andrej Bauer's mail on
   coq-club, June 1 2009; it did not work in 8.2, probably started to
   work after Sozeau improved support for the use of types in unification) *)

Goal (forall (A B : Set) (f : A -> B), (fun x => f x) = f) ->
 forall (A B C : Set) (g : (A -> B) -> C) (f : A -> B), g (fun x => f x) = g f.
Proof.
  intros.
  rewrite H with (f:=f0).