Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. rewrite append_nil. reflexivity.
   - simpl. rewrite IHx. rewrite append_assoc. reflexivity.
Qed.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (qreva x (rev y))) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite rev_rev. rewrite append_nil. reflexivity.
   - intros. simpl. rewrite (eq_refl : Cons n (rev y) = append (rev (Cons n Nil)) (rev y)). rewrite <- rev_append. rewrite IHx. lfind. Admitted.


Require Export bbv.HexNotation.
Require Import Coq.ZArith.BinInt.

Notation "'Ox' a" := (Z.of_N (hex a)) (at level 50).

Goal Ox"41" = 65%Z.
Proof. reflexivity. Qed.


Require Import POCS.

(** * Specification of variables.

    This layer describes mutable variables.  In this lab assignment,
    we will be assuming that this layer is already provided for us,
    and that its implementation meets its specification.  Your job
    will be to familiarize yourself with the lab infrastructure by
    writing procedures, specifications, and proofs for code on top
    of these mutable variables.
 *)

(** There are three variables, which we will call [x], [y], and [z].
    To refer to a particular variable name, we use this type.
  *)
Inductive var :=
| VarX
| VarY
| VarZ.

Instance var_eq : EqualDec var.
Proof.
  hnf.
  destruct x, y; simpl;
    (left; congruence) || (right; congruence).
Defined.

(** The values of these variables comprise the state: *)
Record State := mkState {
            StateX: nat;
            StateY: nat;
            StateZ: nat;
            }.

(** [StateVar] extracts a particular variable by its [var] name
    from a [State].
  *)
Definition StateVar (v:var) (state:State) : nat :=
  match v with
  | VarX => StateX state
  | VarY => StateY state
  | VarZ => StateZ state
  end.

(** * Operations on variables.

    We provide two operations for dealing with variables:
    reading a variable and writing a value to a variable.

    To meaningfully write code on top of these variables,
    it's important to know what reading and writing a variable
    does.  We will capture this with the following specifications.
  *)

(** The specification for reading a variable, [read_spec], is
    parametrized by the variable that we are reading, [v].
  *)

Definition read_spec v : Specification _ _ unit _ :=
  fun (_ : unit) state => {|

(** The precondition is [True], reflecting the fact that it's
    always OK to read any variable [v]. *)
    pre := True;

(** The postcondition has two parts to it.  First, it says
    that the resulting state after reading a variable, [state'],
    is the same as the state before reading the variable, [state].
    In other words, reading a variable doesn't change the state. *)
    post := fun r state' =>
            state' = state /\

(** The second part of the postcondition says that the return
    value [r] is the value of the variable [v] in the [state]. *)
            r = StateVar v state;

(** Since our framework supports reasoning about crashes, we must
    supply a recovered condition, but here we will ignore crashes
    by saying that recovery can never occur, by stating [False]. *)
    recovered := fun _ _ => False
  |}.

(** The specification for writing a variable, [write_spec] is
    parametrized by two things: the variable being modified, [v],
    and the value being written to that variable, [val].
    The precondition and recovery condition are the same as for
    reading ([True] and [False] respectively).
  *)
Definition write_spec v val : Specification _ _ unit _ :=
  fun (_ : unit) state => {|
    pre := True;

(** The postcondition says that the return value is always equal
    to [tt] (a way of representing a procedure that has no return
    value), and *)
    post := fun r state' =>
      r = tt /\

(** the new state, [state'], is updated based on which variable
    we were trying to modify. *)
      match v with
      | VarX => state' = mkState val (StateY state) (StateZ state)
      | VarY => state' = mkState (StateX state) val (StateZ state)
      | VarZ => state' = mkState (StateX state) (StateY state) val
      end;
    recovered := fun _ _ => False
  |}.

(** * Variables module

    An implementation of variables must implement the following module type and
    must prove that that its code implements the spec correctly using refinement.

    If we were to implement this module in Haskell, we would provide Haskell code
    for [read] and [write], and ensure that this code meets the required specification.

    For this lab assignment, we will simply assume that such an implementation exists,
    and focus on writing code, specs, and proofs in the lab infrastructure.

    In the next lab assignment, you will use a similar variables layer that supports
    extraction to Haskell, and allows you to really run your programs.
  *)

Module Type VarsAPI.

  Axiom init : proc InitResult.
  Axiom read : var -> proc nat.
  Axiom write : var -> nat -> proc unit.
  Axiom recover : proc unit.

  Axiom abstr : Abstraction State.

  Axiom init_ok : init_abstraction init recover abstr inited_any.
  Axiom read_ok : forall v, proc_spec (read_spec v) (read v) recover abstr.
  Axiom write_ok : forall v val, proc_spec (write_spec v val) (write v val) recover abstr.
  Axiom recover_wipe : rec_wipe recover abstr no_crash.

  Hint Resolve init_ok : core.
  Hint Resolve read_ok : core.
  Hint Resolve write_ok : core.
  Hint Resolve recover_wipe : core.

End VarsAPI.


Require Import List PeanoNat BinNat Lia.
Import ListNotations.

Require Import Undecidability.CounterMachines.CM1.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Lemma iter_plus {X: Type} {f: X -> X} {x: X} {n m: nat} :
  Nat.iter (n + m) f x = Nat.iter m f (Nat.iter n f x).
Proof. by rewrite Nat.add_comm /Nat.iter nat_rect_plus. Qed.

Lemma mod_frac_lt {n m: nat} : (S m) mod (n + 1) = 0 -> S m < (S m * (n + 2)) / (n + 1).
Proof.
  have ->: S m * (n + 2) = S m + S m * (n + 1) by lia.
  have := Nat.div_mod_eq (S m) (n + 1).
  rewrite Nat.div_add; lia.
Qed.

(* Config is discrete *)
Lemma Config_eq_dec (x' y' : Config) : {x' = y'} + {x' <> y'}.
Proof. do ? decide equality. Qed.

(* halting conditions *)
Lemma haltingP {M : Cm1} {x: Config}:
  halting M x <-> (length M <= state x \/ value x = 0).
Proof.
  move: x => [p c] /=.
  constructor; first last.
  { case; rewrite /halting /=; last by move=> ->.
    move: c => [|c]; first done. by move=> /nth_error_None ->. }
  have [* | /nth_error_Some] : length M <= p \/ p < length M by lia.
  { by left. }
  rewrite /halting /=.
  move: c => [|c]; first by (move=> *; right).
  case: (nth_error M p); last done.
  move=> [q n] _. move Hr: (S c mod (n + 1)) => r.
  move: r Hr => [/mod_frac_lt |r _ [?]]; last by lia.
  move: (S c) => ? ? []. lia.
Qed.

(* halting is monotone *)
Lemma halting_monotone {M : Cm1} {x: Config} {n m: nat} : n <= m ->
  halting M (Nat.iter n (step M) x) -> halting M (Nat.iter m (step M) x).
Proof.
  move=> ? ?. have -> : m = n + (m-n) by lia.
  rewrite iter_plus. elim: (m-n); first done.
  move=> * /=. by congruence.
Qed.

(* remination respect reachability *)
Lemma terminating_reaches_iff {M : Cm1} {k x y} :
  (Nat.iter k (CM1.step M) x = y ->
  ((exists m, CM1.halting M (Nat.iter m (CM1.step M) y))) <->
  (exists n, CM1.halting M (Nat.iter n (CM1.step M) x))).
Proof.
  move=> Hxy. split.
  - move=> [m Hm]. exists (k+m). by rewrite iter_plus Hxy.
  - move=> [n] /(halting_monotone (m := k+n)) => /(_ ltac:(lia)).
    rewrite iter_plus Hxy => ?.
    by exists n.
Qed.

Lemma step_value_monotone (M : Cm1) (x: Config) :
  value x <= value (step M x).
Proof.
  move: x => [p [|c]] /=; first by lia.
  case: (nth_error M p) => /=; last by lia.
  move=> [j n]. move Hr: (S c mod (n + 1)) => [|r] /=; last by lia.
  have := mod_frac_lt Hr. move=> /=. by lia.
Qed.

Lemma run_value_monotone (M : Cm1) (x: Config) (n: nat) :
  value x <= value (Nat.iter n (step M) x).
Proof.
  elim: n=> /=; first by lia.
  move=> n IH. have := step_value_monotone M (Nat.iter n (step M) x).
  by lia.
Qed.

Lemma value_monotone {M : Cm1} {x: Config} {n m: nat} :
  n <= m -> value (Nat.iter n (step M) x) <= value (Nat.iter m (step M) x).
Proof.
  move=> ?. have ->: (m = n + (m - n)) by lia.
  rewrite iter_plus. by apply: run_value_monotone.
Qed.

Lemma inc_value_mod {M : Cm1} {p: Config} : value p < value (step M p) ->
  exists t, nth_error M (state p) = Some t /\ ((value p) mod ((snd t)+1) = 0).
Proof.
  rewrite /step. move: p => [i [|c]] /=; first by lia.
  case: (nth_error M i) => /=; last by lia.
  move=> [j n]. move Hr: (S c mod (n + 1)) => [|r] /=; last by lia.
  move=> _. by exists (j, n).
Qed.

Lemma step_progress (M : Cm1) (x: Config) :
  state x < length M -> 1 <= value x ->
    step M x = {| state := 1 + state x; value := value x |} \/
    value x < value (step M x).
Proof.
  move=> ? ?. rewrite /step. have ->: value x = S (value x - 1) by lia.
  move Ho: (nth_error M (state x)) => o. case: o Ho; first last.
  { move /nth_error_None. by lia. }
  move=> [j n] _. case H: (S (value x - 1) mod (n + 1)); last by left.
  right => /=. by apply: mod_frac_lt.
Qed.

Definition config_weight (M: Cm1) : Config -> nat :=
  fun '{| state := p; value := v |} => p + length M * v.

(* the weight of a configuration strictly increases until the counter machine halts *)
Lemma config_weight_step_monotone {M: Cm1} {x: Config} :
  not (halting M x) -> config_weight M x < config_weight M (step M x).
Proof.
  move=> Hx. suff: not (config_weight M (step M x) <= config_weight M x) by lia.
  move: x Hx => [p v].
  rewrite /config_weight /=. case: v => [|v].
  { move=> + /ltac:(exfalso). by apply. }
  move Ho: (nth_error M p) => o. case: o Ho; first last.
  { move=> Hp + /ltac:(exfalso). apply. move=> /=. by rewrite Hp. }
  move=> [j n] Hp ?. case Hr: (S v mod (n + 1)); last by lia.
  have := mod_frac_lt Hr.
  have : p < length M.
  { apply /nth_error_Some. by rewrite Hp. }
  by nia.
Qed.

Lemma config_weight_run_monotone {M: Cm1} {x: Config} {n: nat} :
  not (halting M (Nat.iter n (step M) x)) -> config_weight M x < config_weight M (Nat.iter (1+n) (step M) x).
Proof.
  elim: n; first by move /config_weight_step_monotone.
  move=> n IH HSn.
  have /IH : not (halting M (Nat.iter n (step M) x)).
  { move=> Hn. apply: HSn. move: Hn. apply: halting_monotone. by lia. }
  have := config_weight_step_monotone HSn.
  move=> /=. by lia.
Qed.

(* a non-terminating run of a counter machine has no duplicates *)
Theorem acyclicity {M: Cm1} {n: nat} {x: Config} :
  not (halting M (Nat.iter n (step M) x)) ->
  NoDup (map (fun i => Nat.iter i (step M) x) (seq 0 (2+n))).
Proof.
  elim: n.
  { move=> /= Hx.
    apply: NoDup_cons; first by case.
    by apply: NoDup_cons; [ case | apply: NoDup_nil ]. }
  move=> n IH HSn.
  have /IH : not (halting M (Nat.iter n (step M) x)).
  { move=> Hn. apply: HSn. move: Hn. apply: halting_monotone. by lia. }
  have ->: seq 0 (2 + S n) = seq 0 (2 + n) ++ [2 + n].
  { have ->: 2 + S n = (2 + n) + 1 by lia. by rewrite [seq 0 (2 + n + 1)] seq_app. }
  rewrite map_app.
  set f := (fun i : nat => Nat.iter i (step M) x).
  have : Add (f (2+n)) (map f (seq 0 (2 + n)) ++ []) (map f (seq 0 (2 + n)) ++ map f [2 + n]) by apply: Add_app.
  rewrite app_nil_r. move /(@NoDup_Add Config) => H Hfn.
  apply /H. constructor; first done.
  rewrite in_map_iff. move=> [i]. rewrite in_seq /f. move=> [+ ?].
  have ->: 2 + n = i + (1 + (1+n - i)) by lia.
  rewrite iter_plus. set x' := Nat.iter i (step M) x.
  move=> Hx'.
  suff: config_weight M x' < config_weight M (Nat.iter (1 + (1+n - i)) (step M) x').
  { rewrite -Hx'. by lia. }
  apply: config_weight_run_monotone. subst x'.
  rewrite -iter_plus. by have ->: i + (1 + n - i) = S n by lia.
Qed.


Require Import Bool Arith List CpdtTactics SfLib LibTactics.
Require Import Coq.Program.Equality.

Set Implicit Arguments.

Require Import Identifier Environment.

Definition state := @Env nat.
Definition update_st := @update_env nat.
Definition empty_state := @empty_env nat.

Inductive exp: Type :=
| ENum : nat -> exp
| EId  : id  -> exp
| EPlus: exp -> exp -> exp.
Lemma eq_exp_dec: forall e1 e2: exp, {e1 = e2} + {e1 <> e2}.
Proof.
  decide equality.
  apply eq_nat_dec.
  apply eq_id_dec.
Qed.

Local Hint Resolve eq_exp_dec.
Local Hint Resolve eq_id_dec.

Tactic Notation "exp_cases" tactic (first) ident (c) :=
 first;
 [Case_aux c "ENum" | Case_aux c "EId" | Case_aux c "EPlus" ].

Inductive eval : exp -> state -> nat -> Prop:=
   | eval_const : forall n st, eval (ENum n) st n
   | eval_var: forall x st u,
        st x = Some u ->
        eval (EId x) st u
   | eval_plus  : forall e1 e2 st u v z,
        eval e1 st u ->
        eval e2 st v ->
        z = u + v ->
        eval (EPlus e1 e2) st z.
Tactic Notation "eval_cases" tactic (first) ident (c) :=
 first;
 [Case_aux c "eval_const" | Case_aux c "eval_var" | Case_aux c "eval_plus" ].

Lemma eval_const_aux : forall st n u,
  eval (ENum n) st u -> u = n.
Proof.
  intros.
  inversion H.
  crush.
Qed.

Lemma eval_var_aux : forall st x u,
  eval (EId x) st u -> st x = Some u.
Proof.
  intros. inversion H. assumption.
Qed.

(* Eval is deterministic *)
Theorem eval_is_det: forall e st u v,
  eval e st u ->
  eval e st v ->
  u = v.
Proof.
  intros.
  generalize dependent v.

  eval_cases (induction H) Case.
     intros; inversion H0; crush.
     intros; inversion H0; crush.
     intros. inversion H2. crush.
Qed.
Hint Rewrite eval_is_det.

Inductive cmd : Type :=
  | CStop : cmd
  | CSkip : cmd
  | CAss  : id  -> exp -> cmd
  | CSeq  : cmd -> cmd -> cmd
  | CIf   : exp -> cmd -> cmd -> cmd
  | CWhile: exp -> cmd -> cmd.

Tactic Notation "cmd_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "STOP" | Case_aux c "SKIP"
  | Case_aux c "::=" | Case_aux c ";;"
  | Case_aux c "IFB" | Case_aux c "WHILE" ].

Notation "'STOP'" := CStop.
Notation "'SKIP'" := CSkip.
Notation "x '::=' a" :=(CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Inductive config : Type :=
   | Config
       ( c : cmd)
       ( st: state).
Notation "'〈' c ',' st '〉'" := (Config c st) (at level 0).

Reserved Notation "cfg '⇒' cfg'" (at level 40).

Definition cmd_of cfg :=
  match cfg with
    | Config c _ => c
  end.
Hint Unfold cmd_of.

Definition state_of cfg :=
  match cfg with
    | Config _ m => m
  end.
Hint Unfold state_of.

(* lifiting reasoning about STOP to configurations *)

Definition is_stop cfg := cmd_of cfg = STOP.
Hint Unfold is_stop.
Definition is_not_stop cfg := cmd_of cfg <> STOP.
Hint Unfold is_not_stop.

Inductive step : config -> config -> Prop :=
  | step_skip : forall st,
      〈 SKIP, st 〉 ⇒ 〈 STOP, st 〉
  | step_assign: forall x e v st st',
       eval e st v ->
       st' = update_st st x v ->
      〈 x ::= e, st 〉 ⇒  〈 STOP, st'〉
  | step_seq1 : forall c1 c1' c2 st st',
      〈 c1, st 〉⇒ 〈 c1', st' 〉->
      c1' <> STOP ->
      〈 c1 ;; c2, st 〉⇒ 〈 c1' ;; c2, st' 〉
  | step_seq2 : forall c1 c2 st st',
      〈 c1, st 〉⇒ 〈 STOP, st' 〉->
      〈 c1 ;; c2, st 〉⇒ 〈 c2, st' 〉
  | step_if1 : forall e u c1 c2 st,
       eval e st u -> u <> 0 ->
      〈 IFB e THEN c1 ELSE c2 FI, st 〉⇒〈 c1, st 〉
  | step_if2 : forall e c1 c2 st,
       eval e st 0 ->
      〈 IFB e THEN c1 ELSE c2 FI, st 〉⇒〈 c2, st 〉
  | step_while : forall e c st,
      〈 WHILE e DO c END, st 〉⇒
          〈 IFB e THEN c;; WHILE e DO c END ELSE SKIP FI, st 〉
where "cfg '⇒' cfg' " := (step cfg cfg').

Lemma eq_cmd_dec: forall c1 c2: cmd, {c1 = c2} + { c1<>c2 }.
Proof.
  decide equality.
Qed.
Local Hint Resolve eq_cmd_dec.


Require Import Arith.
Require Import NatMisc.
Require Import Fin.
Require Import Vector.
Require Import FinVectorMisc.
Import VectorNotations.
Require Import SigmaMisc.
Require Import NotationsMisc.
Require Import Omega.
From Equations Require Import Equations.
Set Equations Transparent.
Unset Equations WithK.

(* decidable propositions *)

Definition DecProp : Type := { P : Prop & {P} + {~P} }.

(* funny names for the projections *)
Definition holds : DecProp -> Prop := @projT1 _ _.

Definition decide (P : DecProp) : {holds P} + {~(holds P)} := projT2 P.

Definition dpTrue : DecProp := {| True ; left I |}.

Equations dpNot (P : DecProp) : DecProp :=
  dpNot {| P ; decP |} := {| ~P ; _ |}.
Next Obligation. destruct decP; intuition. Defined.

Definition dpNot1 (P : DecProp) : holds (dpNot P) <-> ~ (holds P).
Proof. destruct P; intuition. Defined.

Definition lem (P : DecProp) : {holds P} + {holds (dpNot P)}.
Proof. destruct P. intuition. Defined.

Definition dpFalse : DecProp := dpNot dpTrue.

Lemma dpFalse1 (P : DecProp) : holds (dpNot P) <-> ~ (holds P).
Proof. destruct P. intuition. Defined.

Equations dpOr (P Q : DecProp) : DecProp :=
  dpOr {| P ; decP |} {| Q ; decQ |} := {| P \/ Q ; _ |}.
Next Obligation. destruct decP; destruct decQ; intuition. Defined.

Lemma dpOr1 (P Q : DecProp) : holds (dpOr P Q) <-> (holds P) \/ (holds Q).
Proof. destruct P; destruct Q; program_simpl. reflexivity. Defined.

Equations dpAnd (P Q : DecProp) : DecProp :=
  dpAnd {| P ; decP |} {| Q ; decQ |} := {| P /\ Q ; _ |}.
Next Obligation. destruct decP; destruct decQ; intuition. Defined.

Lemma dpAnd1 (P Q : DecProp) : holds (dpAnd P Q) <-> (holds P) /\ (holds Q).
Proof. destruct P; destruct Q; program_simpl; reflexivity. Defined.

Equations dpImp (P Q : DecProp) : DecProp :=
  dpImp {| P ; decP |} {| Q ; decQ |} := {| P -> Q ; _ |}.
Next Obligation. destruct decP; destruct decQ; intuition. Defined.

Lemma dpImp1 (P Q : DecProp) : holds (dpImp P Q) <-> (holds P) -> (holds Q).
Proof. destruct P; destruct Q; program_simpl; intuition. Defined.

Lemma dpContra (P Q : DecProp) :
               holds (dpImp (dpNot P) (dpNot Q)) <-> holds (dpImp Q P).
Proof. destruct P; destruct Q. program_simpl. intuition. Defined.

Equations dpIff (P Q : DecProp) : DecProp :=
  dpIff P Q := dpAnd (dpImp P Q) (dpImp Q P).

Lemma dpIff1 (P Q : DecProp) :
             holds (dpIff P Q) <-> holds (dpImp P Q) /\ holds (dpImp Q P).
Proof. destruct P; destruct Q; program_simpl; intuition. Defined.

Definition dpFinEq {n : nat} (x y : Fin.t n) : DecProp :=
  {| x = y ; t_eqdec _ x y |}.

Lemma dpFinEq1 {n : nat} (x y : Fin.t n) : holds (dpFinEq x y) <-> x = y.
Proof. intuition. Defined.

Definition dpFinLt {n : nat} (x y : Fin.t n) : DecProp :=
  {| x <~ y ; ltFDecidable x y |}.

Lemma dpFinLt1 {n : nat} (x y : Fin.t n) : holds (dpFinLt x y) <-> x <~ y.
Proof. intuition. Defined.

(* decidable predicates on Fin.t n ... *)

Definition DPF (n : nat) : Type := (Fin.t n) -> DecProp.

Definition InDPF {n : nat} (P : DPF n) (x : Fin.t n) : Prop := holds (P x).

Definition decideInDPF {n : nat} (P : DPF n) (x : Fin.t n) :
                       {InDPF P x} + {~(InDPF P x)} := decide (P x).

Definition emptyDPF {n : nat} : DPF n := fun x => dpFalse.

Lemma emptyDPF1 {n : nat} (x : Fin.t n) : ~ (InDPF emptyDPF x).
Proof. intuition. Defined.

Definition fullDPF {n : nat} : DPF n := fun x => dpTrue.

Lemma fullDPF1 {n : nat} (x : Fin.t n) : InDPF fullDPF x.
Proof. exact I. Defined.

Definition dpfMeet {n : nat} (s1 s2 : DPF n) : DPF n :=
  fun x => dpAnd (s1 x) (s2 x).

Lemma dpfMeet1 {n : nat} (s1 s2 : DPF n) (x : Fin.t n) :
               InDPF (dpfMeet s1 s2) x <->
               InDPF s1 x /\ InDPF s2 x.
Proof. unfold InDPF, dpfMeet; rewrite dpAnd1; intuition. Defined.

Definition dpfJoin {n : nat} (s1 s2 : DPF n) : DPF n :=
  fun x => dpOr (s1 x) (s2 x).

Lemma dpfJoin1 {n : nat} (s1 s2 : DPF n) (x : Fin.t n) :
               InDPF (dpfJoin s1 s2) x <->
               InDPF s1 x \/ InDPF s2 x.
Proof. unfold InDPF, dpfJoin; rewrite dpOr1; intuition. Defined.

Definition dpfComplement {n : nat} (s : DPF n) : DPF n :=
  fun x => dpNot (s x).

Lemma dpfComplement1 {n : nat} (s : DPF n) (x : Fin.t n) :
                     InDPF (dpfComplement s) x <-> ~ InDPF s x.
Proof. unfold InDPF, dpfComplement; rewrite dpNot1; intuition. Defined.

Definition dpfShrink {n : nat} (s : DPF (S n)) : DPF n :=
  fun x => s (FS x).

Lemma dpfShrink1 {n : nat} (s : DPF (S n)) (x : Fin.t n) :
                 InDPF s (FS x) <-> InDPF (dpfShrink s) x.
Proof. split; intros; program_simpl. Defined.

Lemma dpfShrinkMeet {n : nat} (s1 s2 : DPF (S n)) (x : Fin.t n) :
                    InDPF (dpfMeet (dpfShrink s1) (dpfShrink s2)) x <->
                    InDPF (dpfShrink (dpfMeet s1 s2)) x.
Proof. intuition. Defined.

Lemma dpfShrinkJoin {n : nat} (s1 s2 : DPF (S n)) (x : Fin.t n) :
                    InDPF (dpfJoin (dpfShrink s1) (dpfShrink s2)) x <->
                    InDPF (dpfShrink (dpfJoin s1 s2)) x.
Proof. intuition. Defined.

Lemma dpfShrinkComplement {n : nat} (s : DPF (S n)) (x : Fin.t n) :
                          InDPF (dpfComplement (dpfShrink s)) x <->
                          InDPF (dpfShrink (dpfComplement s)) x.
Proof. intuition. Defined.

Definition dpfSingle {n : nat} (x : Fin.t n) : DPF n :=
  fun y => dpFinEq x y.

Equations dpfAll {n : nat} (s : DPF n) : DecProp :=
  dpfAll {n:=0}      _  := dpTrue ;
  dpfAll {n:=(S _)}  s  := dpAnd (s F1) (dpfAll (dpfShrink s)).

Equations dpfAny {n : nat} (s : DPF n) : DecProp :=
  dpfAny {n:=0}      _ := dpFalse ;
  dpfAny {n:=(S _)}  s := dpOr (s F1) (dpfAny (dpfShrink s)).

Lemma dpfAnyToWitness {n : nat} {s : DPF n} (any : holds (dpfAny s)) :
                    { x : Fin.t n & InDPF s x }.
Proof.
  induction n.
  - intuition.
  - destruct (decide (dpfAny (dpfShrink s))) as [anyS | notAnyS].
    + destruct (IHn _ anyS); exists (FS x); assumption.
    + destruct (decide (s F1)) as [sF1 | notSF1].
      * exists F1; assumption.
      * rewrite dpfAny_equation_2 in any.
        rewrite dpOr1 in any; apply False_rec; intuition.
Defined.

Lemma dpfWitnessToAny {n : nat} {s : DPF n} (w : {x : Fin.t n & InDPF s x}) :
                      holds (dpfAny s).
Proof.
  induction n.
  - program_simpl; apply Fin.case0; assumption.
  - destruct w; induction x; program_simpl.
    + rewrite dpOr1. intuition.
    + rewrite dpOr1. rewrite dpfShrink1 in i. intuition.
Defined.

Definition dpfNone {n : nat} (s : DPF n) : DecProp :=
  dpNot (dpfAny s).

Equations dpfAbove {n : nat} (x : Fin.t n) : DPF n :=
  dpfAbove {n:=0} x    :=! x;
  dpfAbove {n:=(S _)}  x := fun y => dpFinLt x y.

Lemma dpfAbove1 {n : nat} (x y : Fin.t n) :
                InDPF (dpfAbove x) y <-> x <~ y.
Proof.
  induction n.
  - apply Fin.case0. assumption.
  - unfold InDPF. program_simpl. intuition.
Defined.

Lemma dpfShrinkAbove {n : nat} (x : Fin.t n) (y : Fin.t n) :
                     InDPF (dpfAbove x) y <->
                     InDPF (dpfShrink (dpfAbove (FS x))) y.
Proof.
  induction n.
  - apply Fin.case0; assumption.
  - repeat rewrite dpfAbove_equation_2.
    unfold dpfShrink, InDPF. repeat rewrite dpFinLt1.
    apply iff_sym.
    apply ltFFS.
Defined.

Lemma dpfShrinkAboveF1 {n : nat} (y : Fin.t n) :
                        InDPF (dpfShrink (dpfAbove F1)) y.
Proof.
  induction n.
  - apply Fin.case0.
  - rewrite <- dpfShrink1.
    rewrite dpfAbove1.
    unfold "<~".
    rewrite toNat_equation_2. rewrite toNat_equation_3.
    omega.
Defined.

(* dpfNoneAbove s x <=> forall y.  x <~ y -> ~ (s y) *)

Equations dpfNoneAbove {n : nat} (s : DPF n) : DPF n :=
  dpfNoneAbove s := fun x => dpfNone (dpfMeet (dpfAbove x) s).

Lemma dpfShrinkNoneAbove {n : nat} (s : DPF (S n)) (x : Fin.t n) :
                         InDPF (dpfNoneAbove (dpfShrink s)) x <->
                         InDPF (dpfShrink (dpfNoneAbove s)) x.
Proof.
  unfold dpfNoneAbove. repeat rewrite <- dpfShrink1.
  unfold InDPF, dpfNone. repeat rewrite dpNot1. intuition.
  - destruct (dpfAnyToWitness H0).
    rewrite dpfMeet1 in i.
    dependent induction x0.
    + destruct i as [absurd _].
      rewrite dpfAbove1 in absurd.
      exact (notLtF1 absurd).
    + assert (holds (dpfAny (dpfMeet (dpfAbove x) (dpfShrink s)))).
      * apply dpfWitnessToAny. exists x0.
        rewrite dpfMeet1.
        destruct i.
        { split.
          - rewrite dpfAbove1. rewrite <- ltFFS.
            rewrite dpfAbove1 in H1; assumption.
          - exact H2.
        }
      * intuition.
  - destruct (dpfAnyToWitness H0).
    rewrite dpfMeet1 in i.
    assert (holds (dpfAny (dpfMeet (dpfAbove (FS x)) s))).
    + apply dpfWitnessToAny. exists (FS x0).
      rewrite dpfMeet1; destruct i; split.
      * rewrite dpfAbove1. rewrite ltFFS. rewrite dpfAbove1 in H1; assumption.
      * rewrite dpfShrink1; assumption.
    + intuition.
Defined.

Equations dpfMax {n : nat} (s : DPF n) : DPF n :=
  dpfMax s := dpfMeet s (dpfNoneAbove s).

Lemma dpfShrinkMax {n : nat} (s : DPF (S n)) (x : Fin.t n):
                   InDPF (dpfMax (dpfShrink s)) x <->
                   InDPF (dpfShrink (dpfMax s)) x.
Proof.
  unfold dpfMax.
  rewrite <- dpfShrinkMeet.
  repeat rewrite dpfMeet1.
  rewrite dpfShrinkNoneAbove.
  intuition.
Defined.

Lemma dpfShrinkMaxAny {n : nat} (s : DPF (S n)) :
                      holds (dpfAny (dpfMax (dpfShrink s))) <->
                      holds (dpfAny (dpfShrink (dpfMax s))).
Proof.
  split; intro; apply dpfWitnessToAny;
  destruct (dpfAnyToWitness H) as [x xP]; exists x.
  - rewrite <- dpfShrinkMax; assumption.
  - rewrite dpfShrinkMax; assumption.
Defined.

Lemma dpfMaxIffAny {n : nat} (s : DPF n) :
                   holds (dpfAny s) <-> holds (dpfAny (dpfMax s)).
Proof.
  induction n; split; program_simpl;
  rewrite dpOr1 in *.
  - destruct (decide (dpfAny (dpfShrink s))).
    + right.
      rewrite (IHn (dpfShrink s)) in h.
      rewrite dpfShrinkMaxAny in h; assumption.
    + left. unfold dpfMax, dpfMeet. rewrite dpAnd1.
      destruct H; split.
      * assumption.
      * unfold dpfNoneAbove, dpfNone.
        rewrite dpNot1.
        intro. apply n0. apply dpfWitnessToAny.
        destruct (dpfAnyToWitness H0).
        rewrite dpfMeet1 in i.
        { destruct i. dependent induction x.
          - apply False_rec.
            rewrite dpfAbove1 in H1. exact (notLtF1 H1).
          - exists x. rewrite <- dpfShrink1; assumption.
        }
      * apply False_rec. exact (n0 H).
      * apply False_rec. exact (n0 H).
  - destruct H.
    + unfold dpfMax, dpfMeet in H. rewrite dpAnd1 in H; intuition.
    + right.
      rewrite (IHn (dpfShrink s)).
      rewrite dpfShrinkMaxAny; assumption.
Defined.

Lemma dpfMaxOrNone {n : nat} (s : DPF n) :
                   {holds (dpfAny (dpfMax s))} + {holds (dpfNone s)}.
Proof.
  assert ({holds (dpfAny s)} + {holds (dpfNone s)}) by apply lem.
  destruct H.
  + rewrite (dpfMaxIffAny s) in h. intuition.
  + intuition.
Defined.

Lemma dpfMaxWitnessOrNone {n : nat} (s : DPF n) :
                          { x : Fin.t n & InDPF (dpfMax s) x } +
                          {holds (dpfNone s)}.
Proof.
  destruct (dpfMaxOrNone s) as [maxS | noS].
  - left. apply dpfAnyToWitness; assumption.
  - intuition.
Defined.


(***************************************************************************
* Church-Rosser Property in Pure Lambda-Calculus - Definitions             *
* Arthur Chargueraud, March 2007                                           *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.
Implicit Types x : var.

(* ********************************************************************** *)
(** ** Description of the Task (only part which has to be trusted) *)

(* ********************************************************************** *)
(** Grammar of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_app  : trm -> trm -> trm
  | trm_abs  : trm -> trm.

(* ********************************************************************** *)
(** Operation to open up abstractions. *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(* ********************************************************************** *)
(** Definition of well-formedness of a term *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_app : forall t1 t2,
      term t1 -> term t2 -> term (trm_app t1 t2)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1).

(* ********************************************************************** *)
(** Definition of the body of an abstraction *)

Definition body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

(* ********************************************************************** *)
(** Definition of the beta relation *)

Definition relation := trm -> trm -> Prop.

Inductive beta : relation :=
  | beta_red : forall t1 t2,
      body t1 ->
      term t2 ->
      beta (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | beta_app1 : forall t1 t1' t2,
      term t2 ->
      beta t1 t1' ->
      beta (trm_app t1 t2) (trm_app t1' t2)
  | beta_app2 : forall t1 t2 t2',
      term t1 ->
      beta t2 t2' ->
      beta (trm_app t1 t2) (trm_app t1 t2')
  | beta_abs : forall L t1 t1',
     (forall x, x \notin L -> beta (t1 ^ x) (t1' ^ x)) ->
     beta (trm_abs t1) (trm_abs t1').

(* ********************************************************************** *)
(** Definition of the reflexive-transitive closure of a relation *)

Inductive star_ (R : relation) : relation :=
  | star_refl : forall t,
      term t ->
      star_ R t t
  | star_trans : forall t2 t1 t3,
      star_ R t1 t2 -> star_ R t2 t3 -> star_ R t1 t3
  | star_step : forall t t',
      R t t' -> star_ R t t'.

Notation "R 'star'" := (star_ R) (at level 69).

(* ********************************************************************** *)
(** Definition of the reflexive-symmetric-transitive closure of a relation *)

Inductive equiv_ (R : relation) : relation :=
  | equiv_refl : forall t,
      term t ->
      equiv_ R t t
  | equiv_sym: forall t t',
      equiv_ R t t' ->
      equiv_ R t' t
  | equiv_trans : forall t2 t1 t3,
      equiv_ R t1 t2 -> equiv_ R t2 t3 -> equiv_ R t1 t3
  | equiv_step : forall t t',
      R t t' -> equiv_ R t t'.

Notation "R 'equiv'" := (equiv_ R) (at level 69).

(* ********************************************************************** *)
(** Definition of confluence and of the Church-Rosser property
 (Our goal is to prove the Church-Rosser Property for beta relation) *)

Definition confluence (R : relation) :=
  forall M S T, R M S -> R M T ->
  exists P, R S P /\ R T P.

Definition church_rosser (R : relation) :=
  forall t1 t2, (R equiv) t1 t2 ->
  exists t, (R star) t1 t /\ (R star) t2 t.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
     Aux.v

     Auxillary functions & Theorems
  **********************************************************************)
Require Export List.
Require Export Arith.
Require Export Tactic.
Require Import Inverse_Image.
Require Import Wf_nat.

(**************************************
   Some properties on list operators: app, map,...
**************************************)

Section List.
Variables (A : Set) (B : Set) (C : Set).
Variable f : A ->  B.

(**************************************
  An induction theorem for list based on length
**************************************)

Theorem list_length_ind:
 forall (P : list A ->  Prop),
 (forall (l1 : list A),
  (forall (l2 : list A), length l2 < length l1 ->  P l2) ->  P l1) ->
 forall (l : list A),  P l.
intros P H l;
 apply well_founded_ind with ( R := fun (x y : list A) => length x < length y );
 auto.
apply wf_inverse_image with ( R := lt ); auto.
apply lt_wf.
Qed.

Definition list_length_induction:
 forall (P : list A ->  Set),
 (forall (l1 : list A),
  (forall (l2 : list A), length l2 < length l1 ->  P l2) ->  P l1) ->
 forall (l : list A),  P l.
intros P H l;
 apply well_founded_induction
      with ( R := fun (x y : list A) => length x < length y ); auto.
apply wf_inverse_image with ( R := lt ); auto.
apply lt_wf.
Qed.

Theorem in_ex_app:
 forall (a : A) (l : list A),
 In a l ->  (exists l1 : list A , exists l2 : list A , l = l1 ++ (a :: l2)  ).
intros a l; elim l; clear l; simpl; auto.
intros H; case H.
intros a1 l H [H1|H1]; auto.
exists (nil (A:=A)); exists l; simpl; auto.
rewrite H1; auto.
case H; auto; intros l1 [l2 Hl2]; exists (a1 :: l1); exists l2; simpl; auto.
rewrite Hl2; auto.
Qed.

(**************************************
 Properties on app
**************************************)

Theorem length_app:
 forall (l1 l2 : list A),  length (l1 ++ l2) = length l1 + length l2.
intros l1; elim l1; simpl; auto.
Qed.

Theorem app_inv_head:
 forall (l1 l2 l3 : list A), l1 ++ l2 = l1 ++ l3 ->  l2 = l3.
intros l1; elim l1; simpl; auto.
intros a l H l2 l3 H0; apply H; injection H0; auto.
Qed.

Theorem app_inv_tail:
 forall (l1 l2 l3 : list A), l2 ++ l1 = l3 ++ l1 ->  l2 = l3.
intros l1 l2; generalize l1; elim l2; clear l1 l2; simpl; auto.
intros l1 l3; case l3; auto.
intros b l H; absurd (length ((b :: l) ++ l1) <= length l1).
simpl; rewrite length_app; auto with arith.
rewrite <- H; auto with arith.
intros a l H l1 l3; case l3.
simpl; intros H1; absurd (length (a :: (l ++ l1)) <= length l1).
simpl; rewrite length_app; auto with arith.
rewrite H1; auto with arith.
simpl; intros b l0 H0; injection H0.
intros H1 H2; rewrite H2, (H _ _ H1); auto.
Qed.

Theorem app_inv_app:
 forall l1 l2 l3 l4 a,
 l1 ++ l2 = l3 ++ (a :: l4) ->
  (exists l5 : list A , l1 = l3 ++ (a :: l5) ) \/
  (exists l5 , l2 = l5 ++ (a :: l4) ).
intros l1; elim l1; simpl; auto.
intros l2 l3 l4 a H; right; exists l3; auto.
intros a l H l2 l3 l4 a0; case l3; simpl.
intros H0; left; exists l; injection H0; intros; subst; auto.
intros b l0 H0; case (H l2 l0 l4 a0); auto.
injection H0; auto.
intros [l5 H1].
left; exists l5; injection H0; intros; subst; auto.
Qed.

Theorem app_inv_app2:
 forall l1 l2 l3 l4 a b,
 l1 ++ l2 = l3 ++ (a :: (b :: l4)) ->
  (exists l5 : list A , l1 = l3 ++ (a :: (b :: l5)) ) \/
  ((exists l5 , l2 = l5 ++ (a :: (b :: l4)) ) \/
   l1 = l3 ++ (a :: nil) /\ l2 = b :: l4).
intros l1; elim l1; simpl; auto.
intros l2 l3 l4 a b H; right; left; exists l3; auto.
intros a l H l2 l3 l4 a0 b; case l3; simpl.
case l; simpl.
intros H0; right; right; injection H0; split; auto.
rewrite H2; auto.
intros b0 l0 H0; left; exists l0; injection H0; intros; subst; auto.
intros b0 l0 H0; case (H l2 l0 l4 a0 b); auto.
injection H0; auto.
intros [l5 HH1]; left; exists l5; injection H0; intros; subst; auto.
intros [H1|[H1 H2]]; auto.
right; right; split; auto; injection H0; intros; subst; auto.
Qed.

Theorem same_length_ex:
 forall (a : A) l1 l2 l3,
 length (l1 ++ (a :: l2)) = length l3 ->
  (exists l4 ,
   exists l5 ,
   exists b : B ,
   length l1 = length l4 /\ (length l2 = length l5 /\ l3 = l4 ++ (b :: l5))   ).
intros a l1; elim l1; simpl; auto.
intros l2 l3; case l3; simpl; (try (intros; discriminate)).
intros b l H; exists (nil (A:=B)); exists l; exists b; (repeat (split; auto)).
intros a0 l H l2 l3; case l3; simpl; (try (intros; discriminate)).
intros b l0 H0.
case (H l2 l0); auto.
intros l4 [l5 [b1 [HH1 [HH2 HH3]]]].
exists (b :: l4); exists l5; exists b1; (repeat (simpl; split; auto)).
rewrite HH3; auto.
Qed.

(**************************************
  Properties on map
**************************************)

Theorem in_map_inv:
 forall (b : B) (l : list A),
 In b (map f l) ->  (exists a : A , In a l /\ b = f a ).
intros b l; elim l; simpl; auto.
intros tmp; case tmp.
intros a0 l0 H [H1|H1]; auto.
exists a0; auto.
case (H H1); intros a1 [H2 H3]; exists a1; auto.
Qed.

Theorem in_map_fst_inv:
 forall a (l : list (B * C)),
 In a (map (fst (B:=_)) l) ->  (exists c , In (a, c) l ).
intros a l; elim l; simpl; auto.
intros H; case H.
intros a0 l0 H [H0|H0]; auto.
exists (snd a0); left; rewrite <- H0; case a0; simpl; auto.
case H; auto; intros l1 Hl1; exists l1; auto.
Qed.

Theorem length_map: forall l,  length (map f l) = length l.
intros l; elim l; simpl; auto.
Qed.

Theorem map_app: forall l1 l2,  map f (l1 ++ l2) = map f l1 ++ map f l2.
intros l; elim l; simpl; auto.
intros a l0 H l2; rewrite H; auto.
Qed.

Theorem map_length_decompose:
 forall l1 l2 l3 l4,
 length l1 = length l2 ->
 map f (app l1 l3) = app l2 l4 ->  map f l1 = l2 /\ map f l3 = l4.
intros l1; elim l1; simpl; auto; clear l1.
intros l2; case l2; simpl; auto.
intros; discriminate.
intros a l1 Rec l2; case l2; simpl; clear l2; auto.
intros; discriminate.
intros b l2 l3 l4 H1 H2.
injection H2; clear H2; intros H2 H3.
case (Rec l2 l3 l4); auto.
intros H4 H5; split; auto.
subst; auto.
Qed.

(**************************************
  Properties of flat_map
**************************************)

Theorem in_flat_map:
 forall (l : list B) (f : B ->  list C) a b,
 In a (f b) -> In b l ->  In a (flat_map f l).
intros l g; elim l; simpl; auto.
intros a l0 H a0 b H0 [H1|H1]; apply in_or_app; auto.
left; rewrite H1; auto.
right; apply H with ( b := b ); auto.
Qed.

Theorem in_flat_map_ex:
 forall (l : list B) (f : B ->  list C) a,
 In a (flat_map f l) ->  (exists b , In b l /\ In a (f b) ).
intros l g; elim l; simpl; auto.
intros a H; case H.
intros a l0 H a0 H0; case in_app_or with ( 1 := H0 ); simpl; auto.
intros H1; exists a; auto.
intros H1; case H with ( 1 := H1 ).
intros b [H2 H3]; exists b; simpl; auto.
Qed.

(**************************************
  Properties of fold_left
**************************************)

Theorem fold_left_invol:
  forall (f: A -> B -> A) (P: A -> Prop) l a,
  P a ->  (forall x y, P x -> P (f x y)) -> P (fold_left f l a).
intros f1 P l; elim l; simpl; auto.
Qed.

Theorem fold_left_invol_in:
  forall (f: A -> B -> A) (P: A -> Prop) l a b,
  In b l -> (forall x, P (f x b)) -> (forall x y, P x -> P (f x y)) ->
  P (fold_left f l a).
intros f1 P l; elim l; simpl; auto.
intros a1 b HH; case HH.
intros a1 l1 Rec a2 b [V|V] V1 V2; subst; auto.
apply fold_left_invol; auto.
apply Rec with (b := b); auto.
Qed.

End List.

(**************************************
  Propertie of list_prod
**************************************)

Theorem length_list_prod:
 forall (A : Set) (l1 l2 : list A),
  length (list_prod l1 l2) = length l1 * length l2.
intros A l1 l2; elim l1; simpl; auto.
intros a l H; rewrite length_app; rewrite length_map; rewrite H; auto.
Qed.

Theorem in_list_prod_inv:
 forall (A B : Set) a l1 l2,
 In a (list_prod l1 l2) ->
  (exists b : A , exists c : B , a = (b, c) /\ (In b l1 /\ In c l2)  ).
intros A B a l1 l2; elim l1; simpl; auto; clear l1.
intros H; case H.
intros a1 l1 H1 H2.
case in_app_or with ( 1 := H2 ); intros H3; auto.
case in_map_inv with ( 1 := H3 ); intros b1 [Hb1 Hb2]; auto.
exists a1; exists b1; split; auto.
case H1; auto; intros b1 [c1 [Hb1 [Hb2 Hb3]]].
exists b1; exists c1; split; auto.
Qed.


Require Import Coq.Init.Datatypes.
Require Import Coq.Program.Tactics.
Import Coq.Init.Notations.
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Print LoadPath.
Require Import equivalencesDefinitions.
Require Import propositionsSets.

Section contractibleMaps.

Axiom funcExt:
  forall X:Type, forall B:X->Type,
  forall H0 H1:forall x:X, B x,
  (forall x:X, Id (H0 x) (H1 x)) -> Id H0 H1.

Definition isContractibleImpliesIsSet (X:Type):
IsContractible X -> IsSet X.
Proof.
intro. induction X0. apply isSet. intros.
assert (Id p (comp (reverse (H x0)) (H x1))).
- induction p. induction (H x). simpl. apply refl.
- intros. assert (Id q (comp (reverse (H x0)) (H x1))).
  -- induction q. induction (H x). simpl. apply refl.
  -- induction X0. induction X1. apply refl.
Defined.

Definition isContractibleIsProp (X:Type):
IsProp(IsContractible X).
Proof.
apply isProp. intros K L.
apply isContractibleImpliesIsSet in K as M.
induction L, K, M. assert (Id c c0).
- induction (H0 c). apply refl.
- induction X0. assert (forall x0:X, Id (H x0) (H0 x0)).
-- intro. induction (H1 x x0 (H0 x0) (H x0)). apply refl.
-- apply (funcExt X (Id x) H H0) in X0. induction X0.
    apply refl.
Defined.

Definition dependentProps {X:Type} (B:X->Type):
(forall x:X, IsProp(B x)) -> IsProp(forall x:X,B x).
Proof.
intro H. apply isProp. intros L M.
assert (forall x:X, Id (L x) (M x)).
- intro. induction (H x). induction (H0 (L x) (M x)).
  apply refl.
- apply funcExt. intro. apply (X0 x).
Defined.

Definition isContractibleMapIsProp {X Y:Type} (f:X->Y):
  IsProp(IsContractibleMap f).
Proof.
apply isProp. intros. induction x0, x1.

assert (forall y:Y, IsProp(IsContractible (Fibre f y))).
- intro. apply isContractibleIsProp.
- assert (Id H0 H).
-- apply funcExt. intro. induction (X0 x).
    induction (H1 (H x) (H0 x)). apply refl.
-- induction X1. apply refl.
Defined.

End contractibleMaps.

Section allImplyQinv.

Definition halfAdjointImpliesQinv {X Y:Type} (f:X->Y):
HalfAdjointEquiv f -> Qinv f.
Proof.
intro p. induction p. apply (qinv f g).
- apply n.
- apply e.
Defined.

Definition biinvImpliesQinv {X Y:Type} (f:X->Y):
  Biinv f -> Qinv f.
Proof.
  intro. induction X0. apply (qinv f g n).
  intros.
  specialize e with y as e0. specialize n with (h y) as n0.
  specialize e with y as e1.
  apply appl with g in e0. apply appl with f in e0.
  apply appl with f in n0. induction e1. apply n0.
Defined.

Definition invOfContractibleMap {X Y:Type}
  (f:X->Y) (H:IsContractibleMap f):
  Y->X.
Proof.
intro y. induction H. induction (H y).
induction c. apply x.
Defined.

Definition invIsSection {X Y:Type}
  (f:X->Y) (H:IsContractibleMap f):
  forall y:Y, Id (f(invOfContractibleMap f H y)) y.
Proof.
intro. induction H. simpl. induction (H y).
simpl. induction c. apply H1.
Defined.

Definition fibreInclusion {X Y:Type} (f:X->Y) (y:Y):
Fibre f y -> X.
Proof.
intro. induction X0. apply x.
Defined.

Definition invIsRetraction {X Y:Type}
  (f:X->Y) (H:IsContractibleMap f):
  forall x:X, Id (invOfContractibleMap f H (f x)) x.
Proof.
intro. unfold invOfContractibleMap. unfold IsContractible_rect.
simpl. unfold IsContractibleMap_rect. simpl. induction H. simpl.
induction (H (f x)). simpl. induction c. simpl.
specialize H0 with (fibre f (f x) x (refl (f x))).
apply (appl (fibreInclusion f (f x))) in H0.
simpl in H0. apply H0.
Defined.

Definition isContractibleMapImpliesQinv {X Y:Type} (f:X->Y):
IsContractibleMap f -> Qinv f.
Proof.
intro. induction X0.
apply (qinv f (invOfContractibleMap f (isContractibleMap f H))).
- apply invIsRetraction.
- apply invIsSection.
Defined.

End allImplyQinv.

Section halfAdjointEquivContr.

Definition idInFibres {X Y:Type}
  (f:X->Y) (y:Y) (x0 x1:X) (H0:Id (f x0) y) (H1:Id (f x1) y)
  (gamma:Id x0 x1) (K: Id (comp (appl f gamma) H1) H0):
  Id (fibre f y x0 H0) (fibre f y x1 H1).
Proof.
induction gamma. simpl in K. induction K. apply refl.
Defined.

Definition reverseInvolution {X:Type} {x0 x1:X}
  (f:Id x0 x1):
  Id (reverse (reverse f)) f.
Proof.
induction f. simpl. apply refl.
Defined.

Definition functoriality {X Y:Type} {x0 x1 x2:X} {f:X->Y}
  {p:Id x0 x1} {q:Id x1 x2}:
  Id (comp (appl f p) (appl f q)) (appl f (comp p q)).
Proof.
induction p. induction q. simpl. apply refl.
Defined.

Definition idInFibresAlt {X Y:Type}
  (f:X->Y) (y:Y) (x0 x1:X) (H0:Id (f x0) y) (H1:Id (f x1) y)
  (gamma:Id x0 x1) (K: Id (appl f gamma) (comp H0 (reverse H1))):
  Id (fibre f y x0 H0) (fibre f y x1 H1).
Proof.
assert (Id (comp (appl f gamma) H1) H0).
- induction gamma. simpl in K. assert (Id H1 H0).
-- induction H0. simpl in K. apply reverse.
    apply (appl reverse) in K. simpl in K.
    assert (Id (reverse (reverse H1)) H1).
--- apply reverseInvolution.
--- induction X0. apply K.
-- induction X0. simpl. apply refl.
- apply (idInFibres
          f
          y
          x0
          x1
          H0
          H1
          gamma).
apply X0.
Defined.

Definition halfAdjointEquivImpliesContractible {X Y:Type}
  (f:X->Y):
  HalfAdjointEquiv f -> IsContractibleMap f.
Proof.
intro. induction X0. apply isContractibleMap.
intro.
apply (isContractible
        (Fibre f y)
        (fibre f y (g y) (e y))).
intro p. induction p.
apply (idInFibresAlt
        f
        y
        (g y)
        x
        (e y)
        H
        (comp (reverse (appl g H)) (n x))).
assert (Id  (appl f (comp (reverse (appl g H)) (n x)))
            (comp (appl f (reverse (appl g H))) (appl f (n x)))).
-- apply reverse. apply functoriality.
-- assert (Id (appl f (comp (reverse (appl g H)) (n x)))
            (comp (appl f (reverse (appl g H))) (e(f x)))).
--- induction (t x). apply X0.
--- apply (comp X1). clear X0. clear X1. induction H.
    simpl. induction (e x0). simpl. apply refl.
Defined.

End halfAdjointEquivContr.


(* In this file we prove that the circulation of any blockchain implementing our
semantics is as expected: the sum of all rewards paid out in blocks. *)
From Coq Require Import List.
From Coq Require Import Permutation.
From Coq Require Import ZArith.
From Coq Require Import Psatz.
From Coq Require Import Morphisms.
From ConCert.Utils Require Import Automation.
From ConCert.Utils Require Import Extras.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Finite.
Import ListNotations.

Section Circulation.
Context {ChainBase : ChainBase}.
Context `{Finite Address}.

Local Open Scope Z.
Definition circulation (env : Environment) :=
  sumZ (env_account_balances env) (elements Address).

(* We prove first that over any single action, the circulation is preserved.
The idea behind this proof is that addrs contain from and to, so
we can move them to the beginning of the sum, and it easily follows that
the sum of their balances is the same as before. For the rest of the
list the total balance will then not be affected which follows by induction. *)

Lemma address_reorganize {a b : Address} :
  a <> b ->
  exists suf, Permutation ([a; b] ++ suf) (elements Address).
Proof.
  intros a_neq_b.
  apply (NoDup_incl_reorganize _ [a; b]);
    repeat constructor; unfold incl; auto.
  intros Hin.
  cbn in *.
  intuition.
Qed.

Lemma eval_action_from_to_same
      {pre : Environment}
      {act : Action}
      {post : Environment}
      {new_acts : list Action}
      (eval : ActionEvaluation pre act post new_acts) :
  eval_from eval = eval_to eval ->
  circulation post = circulation pre.
Proof.
  intros from_eq_to.
  unfold circulation.
  induction (elements Address) as [| x xs IH].
  - reflexivity.
  - cbn in *.
    rewrite IH, (account_balance_post eval), from_eq_to.
    lia.
Qed.

Local Hint Resolve eval_action_from_to_same : core.

Lemma eval_action_circulation_unchanged
      {pre : Environment}
      {act : Action}
      {post : Environment}
      {new_acts : list Action} :
  ActionEvaluation pre act post new_acts ->
  circulation post = circulation pre.
Proof.
  intros eval.
  destruct (address_eqb_spec (eval_from eval) (eval_to eval))
    as [from_eq_to | from_neq_to]; eauto.
  destruct (address_reorganize from_neq_to) as [suf perm].
  apply Permutation_sym in perm.
  unfold circulation.
  rewrite 2!(sumZ_permutation perm).
  cbn.
  rewrite (account_balance_post_to eval from_neq_to).
  rewrite (account_balance_post_from eval from_neq_to).
  enough (sumZ (env_account_balances pre) suf = sumZ (env_account_balances post) suf)
    by lia.

  pose proof (Permutation_NoDup perm) as perm_set.
  assert (from_not_in_suf: ~In (eval_from eval) suf).
  { apply (in_NoDup_app _ [eval_from eval; eval_to eval] _); intuition. }
  assert (to_not_in_suf: ~In (eval_to eval) suf).
  { apply (in_NoDup_app _ [eval_from eval; eval_to eval] _); intuition. }

  clear perm perm_set.
  pose proof (account_balance_post_irrelevant eval) as balance_irrel.
  induction suf as [| x xs IH]; auto.
  cbn in *.
  rewrite IH, balance_irrel; auto.
Qed.

Local Hint Resolve eval_action_circulation_unchanged : core.

Instance circulation_proper :
  Proper (EnvironmentEquiv ==> eq) circulation.
Proof.
  intros x y [].
  unfold circulation, env_account_balances.
  induction (elements Address) as [|z zs IH]; auto.
  cbn.
  now
    repeat
    match goal with
    | [H: _ |- _] => rewrite H
  end.
Qed.

(* Now we prove that adding a block _does_ increase the circulation
by what we would expect. *)
Lemma circulation_add_new_block header env :
  circulation (add_new_block_to_env header env) =
  (circulation env + block_reward header)%Z.
Proof.
  assert (Hperm: exists suf, Permutation ([block_creator header] ++ suf) (elements Address)).
  { apply NoDup_incl_reorganize; repeat constructor; unfold incl; auto. }
  destruct Hperm as [suf perm].
  symmetry in perm.
  pose proof (Permutation_NoDup perm (elements_set Address)) as perm_set.
  unfold circulation.
  rewrite perm.
  cbn.
  unfold add_balance.
  rewrite address_eq_refl.
  match goal with
  | [|- ?a + ?b + ?c = ?b + ?d + ?a] => enough (c = d) by lia
  end.

  pose proof (in_NoDup_app
                (block_creator header)
                [block_creator header] suf ltac:(intuition) perm_set) as not_in_suf.
  clear perm perm_set.
  induction suf as [| x xs IH]; auto.
  cbn in *.
  apply Decidable.not_or in not_in_suf.
  destruct (address_eqb_spec x (block_creator header)); try tauto.
  specialize (IH (proj2 not_in_suf)).
  lia.
Qed.

(* We then get a lemma over steps *)
Lemma step_circulation {prev next} (step : ChainStep prev next) :
  circulation next =
  match step with
  | step_block _ _ header _ _ _ _ _ =>
    circulation prev + block_reward header
  | _ => circulation prev
  end%Z.
Proof.
  destruct_chain_step; try rewrite_environment_equiv.
  - (* New block *)
    now rewrite circulation_add_new_block.
  - (* New action *)
    erewrite eval_action_circulation_unchanged; eauto.
  - (* Invalid User Action *)
    intuition.
  - (* Permute queue *)
    intuition.
Qed.

(* And combining these gives the final result. *)
Theorem chain_trace_circulation
        {state : ChainState}
        (trace : ChainTrace empty_state state) :
  circulation state = sumZ block_reward (trace_blocks trace).
Proof.
  remember empty_state as from eqn:eq.
  induction trace as [| from mid to xs IH x]; subst.
  - unfold circulation.
    induction (elements Address); auto.
  - rewrite (step_circulation x).
    cbn.
    destruct_chain_step; auto.
    cbn.
    rewrite <- IH by auto.
    lia.
Qed.
End Circulation.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Axiom Max_is_ge : forall (x:Z) (y:Z), (x <= (Zmax x y))%Z /\
  (y <= (Zmax x y))%Z.

Axiom Max_is_some : forall (x:Z) (y:Z), ((Zmax x y) = x) \/ ((Zmax x y) = y).

Axiom Min_is_le : forall (x:Z) (y:Z), ((Zmin x y) <= x)%Z /\
  ((Zmin x y) <= y)%Z.

Axiom Min_is_some : forall (x:Z) (y:Z), ((Zmin x y) = x) \/ ((Zmin x y) = y).

Axiom Max_x : forall (x:Z) (y:Z), (y <= x)%Z -> ((Zmax x y) = x).

Axiom Max_y : forall (x:Z) (y:Z), (x <= y)%Z -> ((Zmax x y) = y).

Axiom Min_x : forall (x:Z) (y:Z), (x <= y)%Z -> ((Zmin x y) = x).

Axiom Min_y : forall (x:Z) (y:Z), (y <= x)%Z -> ((Zmin x y) = y).

Axiom Max_sym : forall (x:Z) (y:Z), (y <= x)%Z -> ((Zmax x y) = (Zmax y x)).

Axiom Min_sym : forall (x:Z) (y:Z), (y <= x)%Z -> ((Zmin x y) = (Zmin y x)).

Inductive tree  :=
  | Null : tree
  | Tree : Z -> tree -> tree -> tree .

Set Implicit Arguments.
Fixpoint mem(v:Z) (t:tree) {struct t}: Prop :=
  match t with
  | Null => False
  | (Tree x l r) => (x = v) \/ ((mem v l) \/ (mem v r))
  end.
Unset Implicit Arguments.

Set Implicit Arguments.
Fixpoint ge_tree(v:Z) (t:tree) {struct t}: Prop :=
  match t with
  | Null => True
  | (Tree x l r) => (x <= v)%Z /\ ((ge_tree v l) /\ (ge_tree v r))
  end.
Unset Implicit Arguments.

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem ge_trans : forall (t:tree) (x:Z) (y:Z), ((y <= x)%Z /\ (ge_tree y
  t)) -> (ge_tree x t).
(* YOU MAY EDIT THE PROOF BELOW *)
induction t.
intros; simpl; auto.
intros x y.
simpl.
intros (H,(I,(J,K))).
split; auto with zarith.
split.
apply IHt1 with (y:=y); auto with zarith.
apply IHt2 with (y:=y); auto with zarith.
Qed.
(* DO NOT EDIT BELOW *)


Require Import FormalMath.Algebra.Group.
Require Import FormalMath.lib.Sets_ext.

Class GrAct (A X: Type) := gr_act : A -> X -> X.
Infix "⊙" := gr_act (at level 50): math_scope.
Notation "(⊙)" := gr_act (only parsing) : math_scope.
Notation "( x ⊙)" := (gr_act x) (only parsing) : math_scope.
Notation "(⊙ x )" := (fun y => y ⊙ x) (only parsing) : math_scope.

Class GroupAction (A X: Type) `{G: Group A} {Ga: GrAct A X}: Prop := {
  gr_act_prop :> Proper ((=) ==> (==) ==> (==)) (⊙);
  gr_act_ident: forall x: X, one ⊙ x == x;
  gr_act_compat: forall (g h: A) (x: X), (g & h) ⊙ x == g ⊙ (h ⊙ x); }.

Section GROUPACTION_PROP.

  Variable (A X: Type).
  Context `{GA: GroupAction A X}.

  Definition orbit (x: X): Ensemble X := Im Full_set (⊙ x).

  Lemma orbit_the_same: forall (g: A) (x: X), orbit x == orbit (g ⊙ x).
  Proof.
    intros. apply Extensionality_Ensembles. split; repeat intro; unfold orbit in *.
    - destruct H as [g' ?]. exists (g' & (neg g)). 1: constructor.
      now rewrite <- gr_act_compat, op_assoc, neg_left, one_right.
    - destruct H as [g' ?]. exists (g' & g). 1: constructor.
      now rewrite gr_act_compat.
  Qed.

End GROUPACTION_PROP.

Section SUBGROUP_ACTION.

  Context `{SA: SubGroupCondition A P}.
  Context `{Ga: GrAct A X}.
  Context `{GRA: !GroupAction A X}.

  Global Instance subgroup_act: GrAct (Subpart A P) X := fun g x => 'g ⊙ x.

  Instance: Proper ((=) ==> (==) ==> (==)) subgroup_act.
  Proof.
    intros [x] [y] ? a b ?. unfold subgroup_act. subst. red in H0.
    unfold subgroup_equiv in H0. unfold cast, subgroup_rep in *. simpl in *.
    now rewrite H0.
  Qed.

  Global Instance subgroup_action: GroupAction (Subpart A P) X.
  Proof.
    constructor.
    - apply _.
    - intros. unfold one, subgroup_gunit, gr_act, subgroup_act, cast, subgroup_rep.
      simpl. apply gr_act_ident.
    - intros [g] [h] ?. unfold bi_op, gr_act, subgroup_act, subgroup_binop, cast,
                        subgroup_rep. simpl. apply gr_act_compat.
  Qed.

End SUBGROUP_ACTION.


Require Import CSet CMap CMapDomain Infra.PartialOrder Infra.OptionPO.

Set Implicit Arguments.

Definition leMap X `{OrderedType X} Y `{PartialOrder Y} (d d': Map [X, Y]) : Prop :=
 (forall x, poLe (find x d) (find x d')).

Lemma leMap_irreflexive X `{OrderedType X} Y `{PartialOrder Y} (x y:Map [X,Y])
: ~leMap x y -> ~Equal x y.
Proof.
  intros. intro. eapply H1.
  hnf; intros. rewrite H2.
  reflexivity.
Qed.

Instance leMap_ref X `{OrderedType X} Y `{PartialOrder Y} : Reflexive (@leMap X _ Y _).
Proof.
  hnf; intros. hnf; intros. reflexivity.
Qed.

Lemma le_domain_find X `{OrderedType X} Y `{PartialOrder Y} x (d d':Map [X, Y])
  : (forall x, x \In domain d ∪ domain d' ->
              poLe ((find x d)) ((find x d')))
    -> poLe (find x d) (find x d').
Proof.
  intros DEQ. specialize (DEQ x). revert DEQ.
  case_eq (find x d'); intros; eauto.
  - eapply find_domain' in H1; eauto.
    eapply DEQ. cset_tac.
  - simpl. case_eq (find x d); intros; eauto; simpl.
    + pose proof H2. eapply find_domain' in H2.
    exploit DEQ; eauto. cset_tac. simpl in *.
    rewrite H3 in H4. eauto.
Qed.

Instance leMap_proper X `{OrderedType X} Y `{PartialOrder Y} (d d':Map [X, Y])
  : Proper (_eq ==> iff) (fun x => find x d ⊑ find x d').
Proof.
  unfold Proper, respectful; intros.
  split; intros.
  - rewrite <- H1; eauto.
  - rewrite H1; eauto.
Qed.

Instance leMap_dec X `{OrderedType X} Y `{PartialOrder Y}
  :  forall d d' : Map [X, Y], Computable (leMap d d').
Proof.
  intros; hnf; intros.
  edestruct (@set_quant_computable _ _ (domain d ∪ domain d')
                                   (fun x => poLe ((find x d))
                                               (find x d'))).
  - eapply leMap_proper.
  - hnf; intros.
    eauto with typeclass_instances.
  - left; eauto.
    hnf; intros.
    eapply le_domain_find; eauto.
  - right; eauto.
Defined.

Instance leMap_tran X `{OrderedType X} Y `{PartialOrder Y}
  : Transitive (@leMap X _ Y _).
Proof.
  hnf. unfold leMap; intros.
  etransitivity; eauto.
Qed.

Definition eqMap X `{OrderedType X} Y `{PartialOrder Y}
           (d d' : Map [X, Y]) : Prop :=
 (forall x, poEq (find x d) (find x d')).

Instance eqMap_Equiv  X `{OrderedType X} Y `{PartialOrder Y}
  : Equivalence (@eqMap X _ Y _).
Proof.
  constructor; unfold eqMap; hnf; intros.
  - reflexivity.
  - symmetry; eauto.
  - etransitivity; eauto.
Qed.

Lemma eq_domain_find X `{OrderedType X} Y `{PartialOrder Y} x (d d':Map [X, Y])
  : (forall x, x \In domain d ∪ domain d' -> poEq (find x d)
                                               (find x d'))
    -> poEq (find x d) (find x d').
Proof.
  intros DEQ. specialize (DEQ x). revert DEQ.
  case_eq (find x d'); intros; eauto.
  - eapply find_domain' in H1; eauto.
    eapply DEQ. cset_tac.
  - simpl. case_eq (find x d); intros; eauto; simpl.
    + pose proof H2. eapply find_domain' in H2.
    exploit DEQ; eauto. cset_tac. simpl in *.
    rewrite H3 in H4. eauto.
Qed.

Instance eqDom_dec X `{OrderedType X} Y `{PartialOrder Y}
  :  forall d d' : Map [X, Y], Computable (eqMap d d').
Proof.
  intros; hnf; intros.
  edestruct (@set_quant_computable _ _ (domain d ∪ domain d')
                                   (fun x => poEq ((find x d))
                                               ((find x d')))).
  - unfold Proper, respectful; intros.
    split; intros.
    rewrite <- H1; eauto.
    rewrite H1; eauto.
  - hnf; intros.
    eauto with typeclass_instances.
  - left; eauto.
    hnf; intros. eapply eq_domain_find; eauto.
  - right; eauto.
Defined.

Instance leMap_anti X `{OrderedType X} Y `{PartialOrder Y}
  : Antisymmetric (Map [X, Y]) (@eqMap X _ Y _) (@leMap X _ Y _).
Proof.
  hnf. unfold leMap, Equal.
  intros. hnf; intros.
  eapply poLe_antisymmetric in H1; eauto.
Qed.

Set Implicit Arguments.

Instance find_eqMap_proper  X `{OrderedType X} Y `{PartialOrder Y}
  : Proper (_eq ==> @eqMap X _ Y _  ==> poEq) find.
Proof.
  unfold Proper, respectful, eqMap.
  intros. rewrite H2, H1. reflexivity.
Qed.

Instance Dom_semilattice_ltDom  X `{OrderedType X} Y `{PartialOrder Y}
  : PartialOrder (Map [X, Y]) := {
  poLe := @leMap X _ Y _;
  poLe_dec := (@leMap_dec X _ Y _);
  poEq := @eqMap X _ Y _;
  poEq_dec := _
}.
Proof.
  intros. hnf; intros.
  rewrite H1. reflexivity.
Defined.

Lemma leMap_domain X `{OrderedType X} Y `{PartialOrder Y} x y
  : leMap x y -> domain x ⊆ domain y.
Proof.
  unfold leMap. intros.
  hnf; intros.
  specialize (H1 a).
  eapply domain_find in H2. dcr.
  rewrite H3 in H1. inv H1.
  eapply find_domain. congruence.
Qed.

Instance ltMap_proper X `{OrderedType X} Y `{PartialOrder Y} (d d':Map [X, Y])
  : Proper (_eq ==> iff) (fun x => find x d ⊏ find x d').
Proof.
  unfold Proper, respectful; intros.
  split; intros.
  - rewrite <- H1; eauto.
  - rewrite H1; eauto.
Qed.

Lemma leMap_remove X `{OrderedType X} Y `{PartialOrder Y} (m m':Map [X, Y]) x
  : leMap m m'
    -> leMap (remove x m) (remove x m').
Proof.
  unfold leMap; intros LE y.
  specialize (LE y).
  decide (x === y).
  - rewrite !MapFacts.remove_eq_o; eauto.
  - rewrite !MapFacts.remove_neq_o; eauto.
Qed.

Lemma eqMap_remove X `{OrderedType X} Y `{PartialOrder Y} (m m':Map [X, Y]) x
  : eqMap m m'
    -> eqMap (remove x m) (remove x m').
Proof.
  unfold eqMap; intros LE y.
  specialize (LE y).
  decide (x === y).
  - rewrite !MapFacts.remove_eq_o; eauto.
  - rewrite !MapFacts.remove_neq_o; eauto.
Qed.


Require Import Iron.Language.SystemF2.SubstTypeType.
Require Import Iron.Language.SystemF2.SubstTypeExp.
Require Import Iron.Language.SystemF2.TyJudge.

(* Substitution of exps in exps preserves typing *)
Theorem subst_exp_exp_ix
 :  forall ix ke te x1 t1 x2 t2
 ,  get  ix te = Some t2
 -> TYPE ke te           x1 t1
 -> TYPE ke (delete ix te) x2 t2
 -> TYPE ke (delete ix te) (substXX ix x2 x1) t1.
Proof.
 intros. gen ix ke te t1 x2 t2.
 induction x1; intros; inverts_type; simpl; eauto.

 Case "XVar".
  fbreak_nat_compare.
  SCase "n = ix".
   rewrite H in H3. inverts H3. auto.

  SCase "n < ix".
   apply TYVar; auto.

  SCase "n > ix".
   apply TYVar; auto.
   rewrite <- H3.
   destruct n.
    burn.
    simpl. nnat. apply get_delete_below; burn.

 Case "XLAM".
  eapply (IHx1 ix) in H5.
  apply TYLAM.
   unfold liftTE. rewrite map_delete. eauto.
   eapply get_map. eauto.
   unfold liftTE. rewrite <- map_delete.
    apply type_kienv_weaken. auto.

 Case "XLam".
  apply TYLam; auto.
   rewrite delete_rewind.
   eauto using type_tyenv_weaken.
Qed.

Theorem subst_exp_exp
 :  forall ke te x1 t1 x2 t2
 ,  TYPE ke (te :> t2) x1 t1
 -> TYPE ke te x2 t2
 -> TYPE ke te (substXX 0 x2 x1) t1.
Proof.
 intros.
 rrwrite (te = delete 0 (te :> t2)).
 eapply subst_exp_exp_ix; burn.
Qed.


Require Import FOL.
Require Import Tarski.
Require Import PA.
Require Import Vector.

Inductive bterm `{funcs_signature} :=
| bVar : nat -> bterm
| bFunc : forall (f : syms), vec bterm (ar_syms f) -> bterm
| bEmbedT : term -> bterm.

Inductive bform `{funcs_signature, preds_signature, operators} :=
  | bFal : bform
  | bAtom : forall (P : preds), vec bterm (ar_preds P) -> bform
  | bBin : binop -> bform  -> bform  -> bform
  | bQuant : quantop -> (bterm -> bform)  -> bform
  | bFree : (bterm -> bform)  -> bform.

Fixpoint conv_term `{funcs_signature} i (b : bterm) : term :=
  match b with
  | bVar m => var (i - m)
  | bEmbedT t => t
  | bFunc f v => func f (Vector.map (conv_term i) v)
  end.

Fixpoint conv `{funcs_signature, preds_signature, operators} i (phi : bform) : form :=
  match phi with
  | bFal => fal
  | bAtom p v => atom p (Vector.map (conv_term i) v)
  | bBin op t1 t2 => bin op (conv i t1) (conv i t2)
  | bQuant op f => quant op (conv (S i) (f (bVar (S i))))
  | bFree f => conv (S i) (f (bVar (S i)))
  end.

Declare Scope hoas_scope.
Delimit Scope hoas_scope with hoas.

Notation "'Free' x .. y , p" := (bFree Ex (fun x => .. (bFree Ex (fun y => p)) ..))
(at level 50, x binder, left associativity,
  format "'[' 'Free'  '/  ' x  ..  y ,  '/  ' p ']'") : hoas_scope.
Notation "'∀'' x .. y , p" := (bQuant All (fun x => .. (bQuant All (fun y => p)) ..))
(at level 50, x binder,  left associativity,
  format "'[' '∀''  '/  ' x  ..  y ,  '/  ' p ']'") : hoas_scope.
Notation "'∃'' x .. y , p" := (bQuant Ex (fun x => .. (bQuant Ex (fun y => p)) ..))
(at level 50, x binder, left associativity,
  format "'[' '∃''  '/  ' x  ..  y ,  '/  ' p ']'") : hoas_scope.
Notation "⊥" := (bFal) : hoas_scope.
Notation "A ∧ B" := (bBin Conj A B) (at level 41) : hoas_scope.
Notation "A ∨ B" := (bBin Disj A B) (at level 42) : hoas_scope.
Notation "A '-->' B" := (bBin Impl A B) (at level 43, right associativity) : hoas_scope.

Definition convert `{funcs_signature, preds_signature, operators} f := (@conv _ _ _ 0 f).
Arguments convert {_ _ _} f%hoas.

Notation "<< f" := (ltac:(let y := eval cbn -[subst_form] in (convert f) in exact y)) (at level 200, only parsing).

Coercion bEmbedT : term >-> bterm.
Definition vec_term := Vector.t term.
Definition vec_bterm := Vector.t bterm.
Definition vec_bEmbedT' : forall n, vec_term n -> vec_bterm n := @Vector.map term bterm bEmbedT.
Coercion vec_bEmbedT := vec_bEmbedT'.

(*
Section Test.
  Require Import Deduction.
  Require Import List.

  Variable p : peirce.

  Goal forall phi, nil ⊢ ∀ phi.
  Abort.

  (* TODO: Why ist the `%hoas` needed? *)
  Goal nil ⊢ << (∀' a, a == a)%hoas.
  Abort.

End Test.
*)


Require Import Equations.Prop.Equations.

Inductive term : Set :=
| Var (n : nat)
| App (t : term) (l : term_list)

with term_list : Set :=
| nilt : term_list
| const : term -> term_list -> term_list.

Equations id_term (t : term) : term := {
id_term (Var n) := Var n;
id_term (App t l) := App (id_term t) (id_tlist l) }

id_tlist (t : term_list) : term_list := {
  id_tlist nilt := nilt;
  id_tlist (const t tl) := const (id_term t) (id_tlist tl) }.

Goal (forall t : term, id_term_graph t (id_term t)) *
(forall t : term_list, id_tlist_graph t (id_tlist t)).
  split.
  Fail all:mfix f 1 1.
  all:mfix f1 f2 1 1.
  destruct t; constructor; simp id_term.
  destruct t; constructor; simp id_term.
Defined.


Require Import LogicalRelations.
Require Export Coq.Bool.Bool.

(** * Relations for [sumbool] *)

(** ** Symmetric relation *)

(** NB: With proof irrelevance this is the same as [eq]. *)

Inductive sumbool_rel {P1 P2 Q1 Q2}: rel (sumbool P1 Q1) (sumbool P2 Q2):=
  | left_rel_def H1 H2: sumbool_rel (left H1) (left H2)
  | right_rel_def H1 H2: sumbool_rel (right H1) (right H2).

Global Instance left_rel:
  Monotonic (@left) (forallr _ _ : ⊤, forallr _ _ : ⊤, ⊤ ++> sumbool_rel).
Proof.
  constructor; eauto.
Qed.

Global Instance right_rel:
  Monotonic (@right) (forallr _ _ : ⊤, forallr _ _ : ⊤, ⊤ ++> sumbool_rel).
Proof.
  constructor; eauto.
Qed.

(** ** Directed relation *)

Inductive sumbool_le {P1 P2 Q1 Q2}: rel (sumbool P1 Q1) (sumbool P2 Q2):=
  | left_le b1 H2: Related b1 (left H2) sumbool_le
  | right_le H1 b2: Related (right H1) b2 sumbool_le.

Global Existing Instance left_le.
Global Existing Instance right_le.

(** * Definitions for [leb] *)

(** ** Properties *)

Global Instance leb_preo:
  PreOrder leb.
Proof.
  split.
  - intros [|]; simpl; eauto.
  - intros [|]; simpl; eauto.
    intros [|]; simpl; eauto.
    discriminate.
Qed.

Lemma leb_rdestruct:
  RDestruct leb (fun P => P false false /\ P true true /\ P false true).
Proof.
  intros b1 b2 Hb P (HPff & HPtt & HPft).
  destruct b1, b2; eauto; discriminate.
Qed.

Hint Extern 0 (RDestruct leb _) =>
  eapply leb_rdestruct : typeclass_instances.

Global Instance leb_transport_eq_true x y:
  Transport Bool.leb x y (x = true) (y = true).
Proof.
  clear.
  destruct x, y; firstorder.
Qed.

(** ** Monotonicity of various definitions *)

Lemma true_leb b:
  Related b true leb.
Proof.
  destruct b; reflexivity.
Qed.

Hint Extern 0 (Related _ true _) =>
  eapply true_leb : typeclass_instances.

Lemma false_leb b:
  Related false b leb.
Proof.
  destruct b; reflexivity.
Qed.

Hint Extern 0 (Related false _ _) =>
  eapply false_leb : typeclass_instances.

Global Instance negb_leb:
  Monotonic negb (leb --> leb).
Proof.
  unfold negb.
  rauto.
Qed.

Global Instance andb_leb:
  Monotonic andb (leb ++> leb ++> leb).
Proof.
  unfold andb.
  rauto.
Qed.

Global Instance orb_leb:
  Monotonic orb (leb ++> leb ++> leb).
Proof.
  unfold orb.
  rauto.
Qed.

Global Instance implb_leb:
  Monotonic implb (leb --> leb ++> leb).
Proof.
  unfold implb.
  rauto.
Qed.


Require Import Coq.Strings.String Coq.ZArith.ZArith Coq.Lists.List Coq.Logic.FunctionalExtensionality Coq.Sets.Ensembles
        Fiat.Computation Fiat.ADT Fiat.ADTRefinement Fiat.ADTNotation Fiat.ADTRefinement.BuildADTRefinements
        Examples.CacheADT.KVEnsembles.

Open Scope string_scope.

Section CacheSpec.

  Variable Key : Type.
  Variable Value : Type.

  Definition CacheSig : ADTSig :=
    ADTsignature {
        Constructor "EmptyCache"  : unit -> rep,
        Method "AddKey" : rep x (Key * Value) -> rep x bool,
        Method "UpdateKey" : rep x (Key * (Value -> Value)) -> rep x bool,
        Method "LookupKey"   : rep x Key -> rep x (option Value)
  }.

  Definition CacheSpec : ADT CacheSig :=
    ADTRep (Ensemble (Key * Value)) {
        Def Constructor "EmptyCache" (_ : unit) : rep :=
          ret (fun _ => False),
        meth "AddKey" (r : rep, kv : Key * Value) : bool :=
            { r' | (SubEnsembleInsert kv r (fst r')) /\
                   ((usedKey r (fst kv) /\ snd r' = false) \/
                    (~ usedKey r (fst kv) /\ snd r' = true))},
        meth "UpdateKey" (r : rep, kv : Key * (Value -> Value)) : bool :=
              { r' |
                (Same_set _ (fst r') (EnsembleUpdateKey (fst kv) r (snd kv)))
                 /\ ((usedKey r (fst kv) /\ snd r' = true) \/
                     (~ usedKey r (fst kv) -> snd r' = false))},
        meth "LookupKey" (r : rep, k : Key) : option Value :=
                v <- {v | ValidLookup r k v};
        ret (r, v)
      }.

End CacheSpec.


Require Import Nat.
Require Import PPS.Env.

Set Implicit Arguments.

Section ImpModell.

  Inductive Val : Type :=
  | VInt      : nat -> Val
  | Undefined : Val.

  Definition Ref := nat.
  Definition Name := nat.

  Inductive Ty : Type :=
  | Int    : Ty.

  Definition Env := listMap Name Ref.

  Definition Memory := totalMap Ref Val.

  Reserved Notation "E '|-l' val" (at level 80).

  Notation "E ; x" := (union (cons x nil) E) (at level 40).

  Section EnvRelation.

    Inductive Lookup : Env -> (Name * Ref) -> Prop :=
    | LAxiom : forall E x beta,
        E; (x, beta) |-l (x, beta)
    | LRule : forall E x y beta gamma,
        E |-l (x,beta) ->
        E; (y, gamma) |-l (x, beta)
    where "E '|-l' val" := (Lookup E val).

  End EnvRelation.
  Notation "E '|-l' val" := (Lookup E val).

  Section Exp.

    Inductive ArithExp : Type :=
    | Num : nat -> ArithExp
    | Var : Name -> ArithExp
    | Plus : ArithExp -> ArithExp -> ArithExp
    | Mult : ArithExp -> ArithExp -> ArithExp.

  End Exp.

  Reserved Notation "EM '|-R' e ⇓ v" (at level 80).
  Section EvalR.

    Inductive evalR : (Env * Memory) -> ArithExp -> nat -> Prop :=
    | EvVarR  : forall E M x l val,
        E |-l (x, l) ->
        M l = VInt val ->
        (E,M) |-R (Var x) ⇓ val
    | EvNumR  : forall E M n, (E,M) |-R Num n ⇓ n

    | EvPlusR : forall E M e1 e2 v1 v2 v,
        (E,M) |-R e1 ⇓ v1 ->
        (E,M) |-R e2 ⇓ v2 ->
        v = v1 + v2 ->
        (E,M) |-R Plus e1 e2 ⇓ v

    | EvMultR : forall E M e1 e2 v1 v2 v,
        (E,M) |-R e1 ⇓ v1 ->
        (E,M) |-R e2 ⇓ v2 ->
        v = v1 * v2 ->
        (E,M) |-R Mult e1 e2 ⇓ v

    where "EM '|-R' e ⇓ v" := (evalR EM e v).

  End EvalR.
  Notation "EM '|-R' e ⇓ v" := (evalR EM e v).

  (* >>>>>>>>>>>>>>>>>>>>> *)
  Reserved Notation "EM '|-L' e ⇓ v" (at level 80).
  Section EvalL.

    Inductive evalL : (Env * Memory) -> ArithExp -> Ref -> Prop :=
    | EvVarL : forall E M x l,
        E |-l (x, l) ->
        (E,M) |-L (Var x) ⇓ l
  where "EM '|-L' e ⇓ v" := (evalL EM e v).

  End EvalL.
  Notation "EM '|-L' e ⇓ v" := (evalL EM e v).
  (* <<<<<<<<<<<<<<<<<<<<< *)

  Section Stm.

    Inductive Stm : Type :=
    | Ass    : ArithExp -> ArithExp -> Stm
    | Decl   : Name -> Stm
    | Seq    : Stm -> Stm -> Stm.

    Reserved Notation "'<' E '|' M '>' alpha '<' E' '|' M' '>'"
             (at level 40, E at level 39, M at level 39, M' at level 40,
              E' at level 39, alpha at level 39).
    Notation "M '[' var ↦ val ']'" := (updateTMap eqb M var val)
                                    (at level 40, right associativity).

    Inductive IsFree : Ref -> Memory -> Prop :=
    | isFree : forall x M,
        M x = Undefined ->
        IsFree x M.

    Inductive eval : Env * Memory -> Stm -> Env * Memory -> Prop :=
    | EvDecl : forall E M l n,
        IsFree l M ->
        < E | M > Decl n < E; (n, l) | M [l ↦ VInt 0] >

    | EvAss : forall E M e1 e2 l v,
        (* >>>>>>>>>>>>>>>>>>>>> *)
        (E,M) |-L e1 ⇓ l ->
        (* <<<<<<<<<<<<<<<<<<<<< *)
        (E,M) |-R e2 ⇓ v ->
        < E | M > Ass e1 e2 < E | M [l ↦ VInt v] >

    | EvSeq : forall E M E' M' E'' M'' S1 S2,
        < E | M > S1 < E' | M' > ->
        < E' | M' > S2 < E'' | M'' > ->
        < E | M > Seq S1 S2 < E'' | M'' >
    where "'<' E '|' M '>' alpha '<' E' '|' M' '>'" := (eval (E,M) alpha (E',M')).

  End Stm.

End ImpModell.


Require Import GeoCoq.Axioms.tarski_axioms.
Require Import GeoCoq.Axioms.gupta_inspired_variant_axioms.
Require Import GeoCoq.Tarski_dev.Ch05_bet_le.

Section Tarski_neutral_dimensionless_to_Gupta_inspired_variant_of_Tarski_neutral_dimensionless.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma cong_inner_transitivity' : forall A B C D E F, Cong A B E F -> Cong C D E F -> Cong A B C D.
Proof.
  intros A B C D E F H1 H2; apply (cong_inner_transitivity E F); apply cong_symmetry; assumption.
Qed.

Lemma inner_pasch' : forall A B C P Q,
  Bet A P C -> Bet B Q C -> A <> P -> P <> C -> B <> Q -> Q <> C ->
  ~ (Bet A B C \/ Bet B C A \/ Bet C A B) ->
  exists x : Tpoint, Bet P x B /\ Bet Q x A.
Proof.
  intros A B C P Q; intros; apply inner_pasch with C; assumption.
Qed.

Instance T_to_GI : Gupta_inspired_variant_of_Tarski_neutral_dimensionless_with_decidable_point_equality.
Proof.
exact (Build_Gupta_inspired_variant_of_Tarski_neutral_dimensionless_with_decidable_point_equality
  Tpoint Bet Cong eq_dec_points
  cong_pseudo_reflexivity cong_inner_transitivity' cong_identity
  segment_construction five_segment between_symmetry between_inner_transitivity inner_pasch'
  PA PB PC lower_dim).
Defined.

End Tarski_neutral_dimensionless_to_Gupta_inspired_variant_of_Tarski_neutral_dimensionless.

Section Tarski_2D_to_Gupta_inspired_variant_of_Tarski_2D.

Context `{T2D:Tarski_2D}.

Instance T2D_to_TG2D : Gupta_inspired_variant_of_Tarski_2D T_to_GI.
Proof.
  split; intros A B C P Q HPQ HAB HAC HBC; apply upper_dim, HPQ.
Defined.

End Tarski_2D_to_Gupta_inspired_variant_of_Tarski_2D.

Section Tarski_euclidean_to_Gupta_inspired_variant_of_Tarski_euclidean.

Context `{TE:Tarski_euclidean}.

Instance T_euclidean_to_TG_euclidean : Gupta_inspired_variant_of_Tarski_euclidean T_to_GI.
Proof.
  split; intros A B C D T H1 H2 HBD HDC HNCol.
  assert (A <> D) by (intro; subst; apply HNCol; right; right; apply between_symmetry, H2).
  apply euclid with D; assumption.
Defined.

End Tarski_euclidean_to_Gupta_inspired_variant_of_Tarski_euclidean.


(* Copyright (c) 2022, choukh <choukyuhei@gmail.com> *)

Require Import GOO.Ordinal.Ord.

Local Open Scope 序数域.

Notation 递增序列 f := (∀ n m, (n < m)%nat → f n < f m).

Fixpoint 良构 α : Prop :=
  match α with
  | ∅ => True
  | α⁺ => 良构 α
  | lim f => (∀ n, 良构 (f n)) ∧ 递增序列 f
  end.

Lemma 递增序列弱放大 : ∀ f n, 递增序列 f → [n] ≤ f n.
Proof.
  intros. induction n. constructor. apply 后继_弱保序 in IHn.
  apply 弱序_传递 with (f n)⁺. apply IHn.
  apply 小于即后继小于等于. apply H. auto.
Qed.

Lemma 有限序数良构 : ∀ n, 良构 [n].
Proof. induction n. easy. simpl. apply IHn. Qed.

Lemma 自然数序嵌入 : ∀ n m, (n < m)%nat → [n] < [m].
Proof.
  intros n m. revert n. induction m; intros n H. easy.
  inversion H. simpl. easy. apply 强序_传递 with [m]. apply IHm. apply H1. simpl. easy.
Qed.

Theorem ω_良构 : 良构 ω.
Proof. unfold ω. split. apply 有限序数良构. apply 自然数序嵌入. Qed.
Global Hint Resolve ω_良构 : core.

Lemma 序列_极限_介入 : ∀ f n, f n ≤ lim f.
Proof. intros. apply 弱序_极限_介入 with n. easy. Qed.
Global Hint Resolve 序列_极限_介入 : core.

Lemma 递增序列_极限_介入 : ∀ f n, 递增序列 f → f n < lim f.
Proof. intros. apply 强弱传递 with (f (S n)). apply H. auto. auto. Qed.

Lemma 递增序列存在非零取值 : ∀ f, 递增序列 f → ∃ n, f n ≠ [0].
Proof.
  intros f Inc. exists 1. intros C.
  assert (f 0 < f 1). apply Inc. auto.
  rewrite C in H. destruct H as [d _]. destruct d.
Qed.

Lemma 递增序列极限大于等于ω : ∀ f, 递增序列 f → ω ≤ lim f.
Proof.
  intros. constructor. intros n.
  apply 弱序_极限_介入 with n. apply 递增序列弱放大. apply H.
Qed.

Corollary 递增序列极限大于零 : ∀ f, 递增序列 f → ∅ < lim f.
Proof.
  intros. eapply 强弱传递 with ω. auto. apply 递增序列极限大于等于ω. apply H.
Qed.

Lemma 递增序列极限内有任意大的项 : ∀ α f, 递增序列 f → α < lim f → ∃ n, α < f n.
Proof with auto.
  intros α f Inc H. induction α as [|α IH|g IH].
  - exists 1. apply 弱强传递 with (f 0). constructor. apply Inc. auto.
  - destruct IH as [n Hn]. apply 强序_传递 with α⁺...
    exists (S n). apply 弱强传递 with (f n)... apply 小于即后继小于等于...
  - destruct H as [d H]. destruct d as [n d]. simpl in H.
    inversion_clear H. exists n. apply 弱强传递 with (d ⇠ f n).
    constructor. apply H0. exists d. reflexivity.
Qed.

Lemma 良构非零则大于零 : ∀ α, 良构 α → α ≠ [0] → [0] < α.
Proof.
  intros. induction α as [| |f IH]. exfalso. easy. easy.
  destruct H as [WF Inc]. apply 递增序列存在非零取值 in Inc as [n H].
  apply 强序_极限_介入 with n. apply IH. apply WF. apply H.
Qed.

Theorem 良构对零排中 : ∀ α, 良构 α → α = [0] ∨ [0] < α.
Proof.
  intros. destruct α as [| |f]. left. easy. right. easy.
  right. destruct H as [WF Inc]. apply 递增序列存在非零取值 in Inc as [n H].
  apply 强序_极限_介入 with n. apply 良构非零则大于零. apply WF. apply H.
Qed.

Lemma 小于等于零则弱等于零 : ∀ α, α ≤ ∅ → α ≃ ∅.
Proof.
  intros. destruct α as [| |f]. easy.
  - exfalso. apply 非弱序_后继_零 with α. easy.
  - split. easy. constructor.
Qed.

Lemma 良构弱等于零则等于零 : ∀ α, 良构 α → α ≃ [0] → α = [0].
Proof.
  intros α WF [H _]. destruct α as [| |f]. easy.
  - exfalso. eapply 非弱序_后继_零. apply H.
  - exfalso. destruct WF as [WF Inc].
    apply 递增序列存在非零取值 in Inc as [n H0].
    apply 良构非零则大于零 in H0; auto. apply 强序_反转 in H0.
    apply H0. apply 弱序_极限_除去. apply H.
Qed.

Theorem 良构小于等于零则等于零 : ∀ α, 良构 α → α ≤ ∅ → α = [0].
Proof. intros. apply 良构弱等于零则等于零; auto. apply 小于等于零则弱等于零; auto. Qed.

Theorem 良构对ω排中 : ∀ α, 良构 α → α < ω ∨ ω ≤ α.
Proof.
  intros α WF. induction α as [|α IH|f IH].
  - left. apply ω大于零.
  - simpl in WF. pose proof (IH WF) as [].
    + left. apply 有限序数后继. easy.
    + right. apply 弱序_传递 with α; easy.
  - right. apply 递增序列极限大于等于ω. apply WF.
Qed.

Corollary 良构无穷序数后继 : ∀ α, 良构 α → ω ≤ α⁺ → ω ≤ α.
Proof with auto.
  intros α WF Inf. pose proof (良构对ω排中 α) as []...
  exfalso. apply 弱序_反转 in Inf. apply Inf. apply 有限序数后继...
Qed.

Theorem 良构有限序数有自然数表示 : ∀ α, 良构 α → α < ω → ∃ n, α = [n].
Proof with auto.
  intros α WF Fin. induction α as [|α IH|f IH].
  - exists 0...
  - assert (Hn: ∃ n, α = [n]). apply IH... apply 强序_传递 with α⁺...
    destruct Hn as [n Hn]. exists (S n). rewrite Hn...
  - exfalso. eapply 强序_反转. apply Fin. apply 递增序列极限大于等于ω. apply WF.
Qed.