(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Some facts and definitions concerning choice and description in
       intuitionistic logic.

We investigate the relations between the following choice and
description principles

- AC_rel  = relational form of the (non extensional) axiom of choice
            (a "set-theoretic" axiom of choice)
- AC_fun  = functional form of the (non extensional) axiom of choice
            (a "type-theoretic" axiom of choice)
- DC_fun  = functional form of the dependent axiom of choice
- ACw_fun = functional form of the countable axiom of choice
- AC!     = functional relation reification
            (known as axiom of unique choice in topos theory,
             sometimes called principle of definite description in
             the context of constructive type theory)

- GAC_rel = guarded relational form of the (non extensional) axiom of choice
- GAC_fun = guarded functional form of the (non extensional) axiom of choice
- GAC!    = guarded functional relation reification

- OAC_rel = "omniscient" relational form of the (non extensional) axiom of choice
- OAC_fun = "omniscient" functional form of the (non extensional) axiom of choice
            (called AC* in Bell [[Bell]])
- OAC!

- ID_iota    = intuitionistic definite description
- ID_epsilon = intuitionistic indefinite description

- D_iota     = (weakly classical) definite description principle
- D_epsilon  = (weakly classical) indefinite description principle

- PI      = proof irrelevance
- IGP     = independence of general premises
            (an unconstrained generalisation of the constructive principle of
             independence of premises)
- Drinker = drinker's paradox (small form)
            (called Ex in Bell [[Bell]])

We let also

- IPL_2   = 2nd-order impredicative minimal predicate logic (with ex. quant.)
- IPL^2   = 2nd-order functional minimal predicate logic (with ex. quant.)
- IPL_2^2 = 2nd-order impredicative, 2nd-order functional minimal pred. logic (with ex. quant.)

with no prerequisite on the non-emptyness of domains

Table of contents

1. Definitions

2. IPL_2^2 |- AC_rel + AC! = AC_fun

3.1. typed IPL_2 + Sigma-types + PI |- AC_rel = GAC_rel  and  IPL_2 |- AC_rel + IGP -> GAC_rel and IPL_2 |- GAC_rel = OAC_rel

3.2. IPL^2 |- AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker

3.3. D_iota -> ID_iota  and  D_epsilon <-> ID_epsilon + Drinker

4. Derivability of choice for decidable relations with well-ordered codomain

5. Equivalence of choices on dependent or non dependent functional types

6. Non contradiction of constructive descriptions wrt functional choices

7. Definite description transports classical logic to the computational world

8. Choice -> Dependent choice -> Countable choice

References:

[[Bell]] John L. Bell, Choice principles in intuitionistic set theory,
unpublished.

[[Bell93]] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic
Type Theories, Mathematical Logic Quarterly, volume 39, 1993.

[[Carlström05]] Jesper Carlström, Interpreting descriptions in
intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005.
*)

Set Implicit Arguments.

(**********************************************************************)
(** * Definitions *)

(** Choice, reification and description schemes *)

Section ChoiceSchemes.

Variables A B :Type.

Variable P:A->Prop.

Variable R:A->B->Prop.

(** ** Constructive choice and description *)

(** AC_rel *)

Definition RelationalChoice_on :=
  forall R:A->B->Prop,
    (forall x : A, exists y : B, R x y) ->
    (exists R' : A->B->Prop, subrelation R' R /\ forall x, exists! y, R' x y).

(** AC_fun *)

Definition FunctionalChoice_on :=
  forall R:A->B->Prop,
    (forall x : A, exists y : B, R x y) ->
    (exists f : A->B, forall x : A, R x (f x)).

(** DC_fun *)

Definition FunctionalDependentChoice_on :=
  forall (R:A->A->Prop),
    (forall x, exists y, R x y) -> forall x0,
    (exists f : nat -> A, f 0 = x0 /\ forall n, R (f n) (f (S n))).

(** ACw_fun *)

Definition FunctionalCountableChoice_on :=
  forall (R:nat->A->Prop),
    (forall n, exists y, R n y) ->
    (exists f : nat -> A, forall n, R n (f n)).

(** AC! or Functional Relation Reification (known as Axiom of Unique Choice
    in topos theory; also called principle of definite description *)

Definition FunctionalRelReification_on :=
  forall R:A->B->Prop,
    (forall x : A, exists! y : B, R x y) ->
    (exists f : A->B, forall x : A, R x (f x)).

(** ID_epsilon (constructive version of indefinite description;
    combined with proof-irrelevance, it may be connected to
    Carlström's type theory with a constructive indefinite description
    operator) *)

Definition ConstructiveIndefiniteDescription_on :=
  forall P:A->Prop,
    (exists x, P x) -> { x:A | P x }.

(** ID_iota (constructive version of definite description; combined
    with proof-irrelevance, it may be connected to Carlström's and
    Stenlund's type theory with a constructive definite description
    operator) *)

Definition ConstructiveDefiniteDescription_on :=
  forall P:A->Prop,
    (exists! x, P x) -> { x:A | P x }.

(** ** Weakly classical choice and description *)

(** GAC_rel *)

Definition GuardedRelationalChoice_on :=
  forall P : A->Prop, forall R : A->B->Prop,
    (forall x : A, P x -> exists y : B, R x y) ->
    (exists R' : A->B->Prop,
      subrelation R' R /\ forall x, P x -> exists! y, R' x y).

(** GAC_fun *)

Definition GuardedFunctionalChoice_on :=
  forall P : A->Prop, forall R : A->B->Prop,
    inhabited B ->
    (forall x : A, P x -> exists y : B, R x y) ->
    (exists f : A->B, forall x, P x -> R x (f x)).

(** GFR_fun *)

Definition GuardedFunctionalRelReification_on :=
  forall P : A->Prop, forall R : A->B->Prop,
    inhabited B ->
    (forall x : A, P x -> exists! y : B, R x y) ->
    (exists f : A->B, forall x : A, P x -> R x (f x)).

(** OAC_rel *)

Definition OmniscientRelationalChoice_on :=
  forall R : A->B->Prop,
    exists R' : A->B->Prop,
      subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y.

(** OAC_fun *)

Definition OmniscientFunctionalChoice_on :=
  forall R : A->B->Prop,
    inhabited B ->
    exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x).

(** D_epsilon *)

Definition EpsilonStatement_on :=
  forall P:A->Prop,
    inhabited A -> { x:A | (exists x, P x) -> P x }.

(** D_iota *)

Definition IotaStatement_on :=
  forall P:A->Prop,
    inhabited A -> { x:A | (exists! x, P x) -> P x }.

End ChoiceSchemes.

(** Generalized schemes *)

Notation RelationalChoice :=
  (forall A B, RelationalChoice_on A B).
Notation FunctionalChoice :=
  (forall A B, FunctionalChoice_on A B).
Definition FunctionalDependentChoice :=
  (forall A, FunctionalDependentChoice_on A).
Definition FunctionalCountableChoice :=
  (forall A, FunctionalCountableChoice_on A).
Notation FunctionalChoiceOnInhabitedSet :=
  (forall A B, inhabited B -> FunctionalChoice_on A B).
Notation FunctionalRelReification :=
  (forall A B, FunctionalRelReification_on A B).

Notation GuardedRelationalChoice :=
  (forall A B, GuardedRelationalChoice_on A B).
Notation GuardedFunctionalChoice :=
  (forall A B, GuardedFunctionalChoice_on A B).
Notation GuardedFunctionalRelReification :=
  (forall A B, GuardedFunctionalRelReification_on A B).

Notation OmniscientRelationalChoice :=
  (forall A B, OmniscientRelationalChoice_on A B).
Notation OmniscientFunctionalChoice :=
  (forall A B, OmniscientFunctionalChoice_on A B).

Notation ConstructiveDefiniteDescription :=
  (forall A, ConstructiveDefiniteDescription_on A).
Notation ConstructiveIndefiniteDescription :=
  (forall A, ConstructiveIndefiniteDescription_on A).

Notation IotaStatement :=
  (forall A, IotaStatement_on A).
Notation EpsilonStatement :=
  (forall A, EpsilonStatement_on A).

(** Subclassical schemes *)

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

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

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

(**********************************************************************)
(** * AC_rel + AC! = AC_fun

   We show that the functional formulation of the axiom of Choice
   (usual formulation in type theory) is equivalent to its relational
   formulation (only formulation of set theory) + functional relation
   reification (aka axiom of unique choice, or, principle of (parametric)
   definite descriptions) *)

(** This shows that the axiom of choice can be assumed (under its
   relational formulation) without known inconsistency with classical logic,
   though functional relation reification conflicts with classical logic *)

Lemma description_rel_choice_imp_funct_choice :
  forall A B : Type,
    FunctionalRelReification_on A B -> RelationalChoice_on A B -> FunctionalChoice_on A B.
Proof.
  intros A B Descr RelCh R H.
  destruct (RelCh R H) as (R',(HR'R,H0)).
  destruct (Descr R') as (f,Hf).
  firstorder.
  exists f; intro x.
  destruct (H0 x) as (y,(HR'xy,Huniq)).
  rewrite <- (Huniq (f x) (Hf x)).
  apply HR'R; assumption.
Qed.

Lemma funct_choice_imp_rel_choice :
  forall A B, FunctionalChoice_on A B -> RelationalChoice_on A B.
Proof.
  intros A B FunCh R H.
  destruct (FunCh R H) as (f,H0).
  exists (fun x y => f x = y).
  split.
  intros x y Heq; rewrite <- Heq; trivial.
  intro x; exists (f x); split.
    reflexivity.
    trivial.
Qed.

Lemma funct_choice_imp_description :
  forall A B, FunctionalChoice_on A B -> FunctionalRelReification_on A B.
Proof.
  intros A B FunCh R H.
  destruct (FunCh R) as [f H0].
  (* 1 *)
  intro x.
  destruct (H x) as (y,(HRxy,_)).
  exists y; exact HRxy.
  (* 2 *)
  exists f; exact H0.
Qed.

Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr :
  forall A B, FunctionalChoice_on A B <->
    RelationalChoice_on A B /\ FunctionalRelReification_on A B.
Proof.
  intros A B; split.
  intro H; split;
    [ exact (funct_choice_imp_rel_choice H)
      | exact (funct_choice_imp_description H) ].
  intros [H H0]; exact (description_rel_choice_imp_funct_choice H0 H).
Qed.

(**********************************************************************)
(** * Connection between the guarded, non guarded and omniscient choices *)

(** We show that the guarded formulations of the axiom of choice
   are equivalent to their "omniscient" variant and comes from the non guarded
   formulation in presence either of the independance of general premises
   or subset types (themselves derivable from subtypes thanks to proof-
   irrelevance) *)

(**********************************************************************)
(** ** AC_rel + PI -> GAC_rel and AC_rel + IGP -> GAC_rel and GAC_rel = OAC_rel *)

Lemma rel_choice_and_proof_irrel_imp_guarded_rel_choice :
  RelationalChoice -> ProofIrrelevance -> GuardedRelationalChoice.
Proof.
  intros rel_choice proof_irrel.
  red in |- *; intros A B P R H.
  destruct (rel_choice _ _ (fun (x:sigT P) (y:B) => R (projT1 x) y)) as (R',(HR'R,H0)).
  intros (x,HPx).
  destruct (H x HPx) as (y,HRxy).
  exists y; exact HRxy.
  set (R'' := fun (x:A) (y:B) => exists H : P x, R' (existT P x H) y).
  exists R''; split.
  intros x y (HPx,HR'xy).
    change x with (projT1 (existT P x HPx)); apply HR'R; exact HR'xy.
  intros x HPx.
  destruct (H0 (existT P x HPx)) as (y,(HR'xy,Huniq)).
  exists y; split. exists HPx; exact HR'xy.
  intros y' (H'Px,HR'xy').
    apply Huniq.
    rewrite proof_irrel with (a1 := HPx) (a2 := H'Px); exact HR'xy'.
Qed.

Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice :
  forall A B, inhabited B -> RelationalChoice_on A B ->
    IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B.
Proof.
  intros A B Inh AC_rel IndPrem P R H.
  destruct (AC_rel (fun x y => P x -> R x y)) as (R',(HR'R,H0)).
  intro x. apply IndPrem. exact Inh. intro Hx.
  apply H; assumption.
  exists (fun x y => P x /\ R' x y).
  firstorder.
Qed.

Lemma guarded_rel_choice_imp_rel_choice :
  forall A B, GuardedRelationalChoice_on A B -> RelationalChoice_on A B.
Proof.
  intros A B GAC_rel R H.
  destruct (GAC_rel (fun _ => True) R) as (R',(HR'R,H0)).
  firstorder.
  exists R'; firstorder.
Qed.

Lemma subset_types_imp_guarded_rel_choice_iff_rel_choice :
  ProofIrrelevance -> (GuardedRelationalChoice <-> RelationalChoice).
Proof.
  auto decomp using
    guarded_rel_choice_imp_rel_choice,
    rel_choice_and_proof_irrel_imp_guarded_rel_choice.
Qed.

(** OAC_rel = GAC_rel *)

Corollary guarded_iff_omniscient_rel_choice :
  GuardedRelationalChoice <-> OmniscientRelationalChoice.
Proof.
  split.
  intros GAC_rel A B R.
  apply (GAC_rel A B (fun x => exists y, R x y) R); auto.
  intros OAC_rel A B P R H.
  destruct (OAC_rel A B R) as (f,Hf); exists f; firstorder.
Qed.

(**********************************************************************)
(** ** AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker *)

(** AC_fun + IGP = GAC_fun *)

Lemma guarded_fun_choice_imp_indep_of_general_premises :
  GuardedFunctionalChoice -> IndependenceOfGeneralPremises.
Proof.
  intros GAC_fun A P Q Inh H.
  destruct (GAC_fun unit A (fun _ => Q) (fun _ => P) Inh) as (f,Hf).
  tauto.
  exists (f tt); auto.
Qed.

Lemma guarded_fun_choice_imp_fun_choice :
  GuardedFunctionalChoice -> FunctionalChoiceOnInhabitedSet.
Proof.
  intros GAC_fun A B Inh R H.
  destruct (GAC_fun A B (fun _ => True) R Inh) as (f,Hf).
  firstorder.
  exists f; auto.
Qed.

Lemma fun_choice_and_indep_general_prem_imp_guarded_fun_choice :
  FunctionalChoiceOnInhabitedSet -> IndependenceOfGeneralPremises
  -> GuardedFunctionalChoice.
Proof.
  intros AC_fun IndPrem A B P R Inh H.
  apply (AC_fun A B Inh (fun x y => P x -> R x y)).
  intro x; apply IndPrem; eauto.
Qed.

Corollary fun_choice_and_indep_general_prem_iff_guarded_fun_choice :
  FunctionalChoiceOnInhabitedSet /\ IndependenceOfGeneralPremises
  <-> GuardedFunctionalChoice.
Proof.
  auto decomp using
    guarded_fun_choice_imp_indep_of_general_premises,
    guarded_fun_choice_imp_fun_choice,
    fun_choice_and_indep_general_prem_imp_guarded_fun_choice.
Qed.

(** AC_fun + Drinker = OAC_fun *)

(** This was already observed by Bell [[Bell]] *)

Lemma omniscient_fun_choice_imp_small_drinker :
  OmniscientFunctionalChoice -> SmallDrinker'sParadox.
Proof.
  intros OAC_fun A P Inh.
  destruct (OAC_fun unit A (fun _ => P)) as (f,Hf).
  auto.
  exists (f tt); firstorder.
Qed.

Lemma omniscient_fun_choice_imp_fun_choice :
  OmniscientFunctionalChoice -> FunctionalChoiceOnInhabitedSet.
Proof.
  intros OAC_fun A B Inh R H.
  destruct (OAC_fun A B R Inh) as (f,Hf).
  exists f; firstorder.
Qed.

Lemma fun_choice_and_small_drinker_imp_omniscient_fun_choice :
  FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox
  -> OmniscientFunctionalChoice.
Proof.
  intros AC_fun Drinker A B R Inh.
  destruct (AC_fun A B Inh (fun x y => (exists y, R x y) -> R x y)) as (f,Hf).
  intro x; apply (Drinker B (R x) Inh).
  exists f; assumption.
Qed.

Corollary fun_choice_and_small_drinker_iff_omniscient_fun_choice :
  FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox
  <-> OmniscientFunctionalChoice.
Proof.
  auto decomp using
    omniscient_fun_choice_imp_small_drinker,
    omniscient_fun_choice_imp_fun_choice,
    fun_choice_and_small_drinker_imp_omniscient_fun_choice.
Qed.

(** OAC_fun = GAC_fun *)

(** This is derivable from the intuitionistic equivalence between IGP and Drinker
but we give a direct proof *)

Theorem guarded_iff_omniscient_fun_choice :
  GuardedFunctionalChoice <-> OmniscientFunctionalChoice.
Proof.
  split.
  intros GAC_fun A B R Inh.
  apply (GAC_fun A B (fun x => exists y, R x y) R); auto.
  intros OAC_fun A B P R Inh H.
  destruct (OAC_fun A B R Inh) as (f,Hf).
  exists f; firstorder.
Qed.

(**********************************************************************)
(** ** D_iota -> ID_iota  and  D_epsilon <-> ID_epsilon + Drinker *)

(** D_iota -> ID_iota *)

Lemma iota_imp_constructive_definite_description :
  IotaStatement -> ConstructiveDefiniteDescription.
Proof.
  intros D_iota A P H.
  destruct D_iota with (P:=P) as (x,H1).
  destruct H; red in H; auto.
  exists x; apply H1; assumption.
Qed.

(** ID_epsilon + Drinker <-> D_epsilon *)

Lemma epsilon_imp_constructive_indefinite_description:
  EpsilonStatement -> ConstructiveIndefiniteDescription.
Proof.
  intros D_epsilon A P H.
  destruct D_epsilon with (P:=P) as (x,H1).
  destruct H; auto.
  exists x; apply H1; assumption.
Qed.

Lemma constructive_indefinite_description_and_small_drinker_imp_epsilon :
  SmallDrinker'sParadox -> ConstructiveIndefiniteDescription ->
  EpsilonStatement.
Proof.
  intros Drinkers D_epsilon A P Inh;
  apply D_epsilon; apply Drinkers; assumption.
Qed.

Lemma epsilon_imp_small_drinker :
  EpsilonStatement -> SmallDrinker'sParadox.
Proof.
  intros D_epsilon A P Inh; edestruct D_epsilon; eauto.
Qed.

Theorem constructive_indefinite_description_and_small_drinker_iff_epsilon :
  (SmallDrinker'sParadox * ConstructiveIndefiniteDescription ->
  EpsilonStatement) *
  (EpsilonStatement ->
   SmallDrinker'sParadox * ConstructiveIndefiniteDescription).
Proof.
  auto decomp using
    epsilon_imp_constructive_indefinite_description,
    constructive_indefinite_description_and_small_drinker_imp_epsilon,
    epsilon_imp_small_drinker.
Qed.

(**********************************************************************)
(** * Derivability of choice for decidable relations with well-ordered codomain *)

(** Countable codomains, such as [nat], can be equipped with a
    well-order, which implies the existence of a least element on
    inhabited decidable subsets. As a consequence, the relational form of
    the axiom of choice is derivable on [nat] for decidable relations.

    We show instead that functional relation reification and the
    functional form of the axiom of choice are equivalent on decidable
    relation with [nat] as codomain
*)

Require Import Wf_nat.
Require Import Decidable.

Definition FunctionalChoice_on_rel (A B:Type) (R:A->B->Prop) :=
  (forall x:A, exists y : B, R x y) ->
  exists f : A -> B, (forall x:A, R x (f x)).

Lemma classical_denumerable_description_imp_fun_choice :
  forall A:Type,
    FunctionalRelReification_on A nat ->
    forall R:A->nat->Prop,
      (forall x y, decidable (R x y)) -> FunctionalChoice_on_rel R.
Proof.
  intros A Descr.
  red in |- *; intros R Rdec H.
  set (R':= fun x y => R x y /\ forall y', R x y' -> y <= y').
  destruct (Descr R') as (f,Hf).
  intro x.
  apply (dec_inh_nat_subset_has_unique_least_element (R x)).
    apply Rdec.
    apply (H x).
    exists f.
    intros x.
    destruct (Hf x) as (Hfx,_).
    assumption.
Qed.

(**********************************************************************)
(** * Choice on dependent and non dependent function types are equivalent *)

(** ** Choice on dependent and non dependent function types are equivalent *)

Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) :=
  forall R:forall x:A, B x -> Prop,
    (forall x:A, exists y : B x, R x y) ->
    (exists f : (forall x:A, B x), forall x:A, R x (f x)).

Notation DependentFunctionalChoice :=
  (forall A (B:A->Type), DependentFunctionalChoice_on B).

(** The easy part *)

Theorem dep_non_dep_functional_choice :
  DependentFunctionalChoice -> FunctionalChoice.
Proof.
  intros AC_depfun A B R H.
  destruct (AC_depfun A (fun _ => B) R H) as (f,Hf).
  exists f; trivial.
Qed.

(** Deriving choice on product types requires some computation on
    singleton propositional types, so we need computational
    conjunction projections and dependent elimination of conjunction
    and equality *)

Scheme and_indd := Induction for and Sort Prop.
Scheme eq_indd := Induction for eq Sort Prop.

Definition proj1_inf (A B:Prop) (p : A/\B) :=
  let (a,b) := p in a.

Theorem non_dep_dep_functional_choice :
  FunctionalChoice -> DependentFunctionalChoice.
Proof.
  intros AC_fun A B R H.
  pose (B' := { x:A & B x }).
  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)).
  destruct (AC_fun A B' R') as (f,Hf).
  intros x. destruct (H x) as (y,Hy).
  exists (existT (fun x => B x) x y). split; trivial.
  exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_inf (Hf x))).
  intro x; destruct (Hf x) as (Heq,HR) using and_indd.
  destruct (f x); simpl in *.
  destruct Heq using eq_indd; trivial.
Qed.

(** ** Reification of dependent and non dependent functional relation  are equivalent *)

Definition DependentFunctionalRelReification_on (A:Type) (B:A -> Type) :=
  forall (R:forall x:A, B x -> Prop),
    (forall x:A, exists! y : B x, R x y) ->
    (exists f : (forall x:A, B x), forall x:A, R x (f x)).

Notation DependentFunctionalRelReification :=
  (forall A (B:A->Type), DependentFunctionalRelReification_on B).

(** The easy part *)

Theorem dep_non_dep_functional_rel_reification :
  DependentFunctionalRelReification -> FunctionalRelReification.
Proof.
  intros DepFunReify A B R H.
  destruct (DepFunReify A (fun _ => B) R H) as (f,Hf).
  exists f; trivial.
Qed.

(** Deriving choice on product types requires some computation on
    singleton propositional types, so we need computational
    conjunction projections and dependent elimination of conjunction
    and equality *)

Theorem non_dep_dep_functional_rel_reification :
  FunctionalRelReification -> DependentFunctionalRelReification.
Proof.
  intros AC_fun A B R H.
  pose (B' := { x:A & B x }).
  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)).
  destruct (AC_fun A B' R') as (f,Hf).
  intros x. destruct (H x) as (y,(Hy,Huni)).
  exists (existT (fun x => B x) x y). repeat split; trivial.
  intros (x',y') (Heqx',Hy').
  simpl in *.
  destruct Heqx'.
  rewrite (Huni y'); trivial.
  exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_inf (Hf x))).
  intro x; destruct (Hf x) as (Heq,HR) using and_indd.
  destruct (f x); simpl in *.
  destruct Heq using eq_indd; trivial.
Qed.

Corollary dep_iff_non_dep_functional_rel_reification :
  FunctionalRelReification <-> DependentFunctionalRelReification.
Proof.
  auto decomp using
    non_dep_dep_functional_rel_reification,
    dep_non_dep_functional_rel_reification.
Qed.

(**********************************************************************)
(** * Non contradiction of constructive descriptions wrt functional axioms of choice *)

(** ** Non contradiction of indefinite description *)

Lemma relative_non_contradiction_of_indefinite_descr :
  forall C:Prop, (ConstructiveIndefiniteDescription -> C)
  -> (FunctionalChoice -> C).
Proof.
  intros C H AC_fun.
  assert (AC_depfun := non_dep_dep_functional_choice AC_fun).
  pose (A0 := { A:Type & { P:A->Prop & exists x, P x }}).
  pose (B0 := fun x:A0 => projT1 x).
  pose (R0 := fun x:A0 => fun y:B0 x => projT1 (projT2 x) y).
  pose (H0 := fun x:A0 => projT2 (projT2 x)).
  destruct (AC_depfun A0 B0 R0 H0) as (f, Hf).
  apply H.
  intros A P H'.
  exists (f (existT _ A (existT _ P H'))).
  pose (Hf' := Hf (existT _ A (existT _ P H'))).
  assumption.
Qed.

Lemma constructive_indefinite_descr_fun_choice :
  ConstructiveIndefiniteDescription -> FunctionalChoice.
Proof.
  intros IndefDescr A B R H.
  exists (fun x => proj1_sig (IndefDescr B (R x) (H x))).
  intro x.
  apply (proj2_sig (IndefDescr B (R x) (H x))).
Qed.

(** ** Non contradiction of definite description *)

Lemma relative_non_contradiction_of_definite_descr :
  forall C:Prop, (ConstructiveDefiniteDescription -> C)
  -> (FunctionalRelReification -> C).
Proof.
  intros C H FunReify.
  assert (DepFunReify := non_dep_dep_functional_rel_reification FunReify).
  pose (A0 := { A:Type & { P:A->Prop & exists! x, P x }}).
  pose (B0 := fun x:A0 => projT1 x).
  pose (R0 := fun x:A0 => fun y:B0 x => projT1 (projT2 x) y).
  pose (H0 := fun x:A0 => projT2 (projT2 x)).
  destruct (DepFunReify A0 B0 R0 H0) as (f, Hf).
  apply H.
  intros A P H'.
  exists (f (existT _ A (existT _ P H'))).
  pose (Hf' := Hf (existT _ A (existT _ P H'))).
  assumption.
Qed.

Lemma constructive_definite_descr_fun_reification :
  ConstructiveDefiniteDescription -> FunctionalRelReification.
Proof.
  intros DefDescr A B R H.
  exists (fun x => proj1_sig (DefDescr B (R x) (H x))).
  intro x.
  apply (proj2_sig (DefDescr B (R x) (H x))).
Qed.

(** Remark, the following corollaries morally hold:

Definition In_propositional_context (A:Type) := forall C:Prop, (A -> C) -> C.

Corollary constructive_definite_descr_in_prop_context_iff_fun_reification :
   In_propositional_context ConstructiveIndefiniteDescription
   <-> FunctionalChoice.

Corollary constructive_definite_descr_in_prop_context_iff_fun_reification :
   In_propositional_context ConstructiveDefiniteDescription
   <-> FunctionalRelReification.

but expecting [FunctionalChoice] (resp. [FunctionalRelReification]) to
be applied on the same Type universes on both sides of the first
(resp. second) equivalence breaks the stratification of universes.
*)

(**********************************************************************)
(** * Excluded-middle + definite description => computational excluded-middle *)

(** The idea for the following proof comes from [[ChicliPottierSimpson02]] *)

(** Classical logic and axiom of unique choice (i.e. functional
    relation reification), as shown in [[ChicliPottierSimpson02]],
    implies the double-negation of excluded-middle in [Set] (which is
    incompatible with the impredicativity of [Set]).

    We adapt the proof to show that constructive definite description
    transports excluded-middle from [Prop] to [Set].

    [[ChicliPottierSimpson02]] Laurent Chicli, Loïc Pottier, Carlos
    Simpson, Mathematical Quotients and Quotient Types in Coq,
    Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646,
    Springer Verlag.  *)

Require Import Setoid.

Theorem constructive_definite_descr_excluded_middle :
  ConstructiveDefiniteDescription ->
  (forall P:Prop, P \/ ~ P) -> (forall P:Prop, {P} + {~ P}).
Proof.
  intros Descr EM P.
  pose (select := fun b:bool => if b then P else ~P).
  assert { b:bool | select b } as ([|],HP).
  apply Descr.
  rewrite <- unique_existence; split.
  destruct (EM P).
  exists true; trivial.
  exists false; trivial.
  intros [|] [|] H1 H2; simpl in *; reflexivity || contradiction.
  left; trivial.
  right; trivial.
Qed.

Corollary fun_reification_descr_computational_excluded_middle_in_prop_context :
  FunctionalRelReification ->
  (forall P:Prop, P \/ ~ P) ->
  forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C.
Proof.
  intros FunReify EM C; auto decomp using
    constructive_definite_descr_excluded_middle,
    (relative_non_contradiction_of_definite_descr (C:=C)).
Qed.

(**********************************************************************)
(** * Choice => Dependent choice => Countable choice *)

(* The implications below are standard *)

Require Import Arith.

Theorem functional_choice_imp_functional_dependent_choice :
   FunctionalChoice -> FunctionalDependentChoice.
Proof.
  intros FunChoice A R HRfun x0.
  apply FunChoice in HRfun as (g,Rg).
  set (f:=fix f n := match n with 0 => x0 | S n' => g (f n') end).
  exists f; firstorder.
Qed.

Theorem functional_dependent_choice_imp_functional_countable_choice :
   FunctionalDependentChoice -> FunctionalCountableChoice.
Proof.
  intros H A R H0.
  set (R' (p q:nat*A) := fst q = S (fst p) /\ R (fst p) (snd q)).
  destruct (H0 0) as (y0,Hy0).
  destruct H with (R:=R') (x0:=(0,y0)) as (f,(Hf0,HfS)).
    intro x; destruct (H0 (fst x)) as (y,Hy).
    exists (S (fst x),y).
    red. auto.
  assert (Heq:forall n, fst (f n) = n).
    induction n.
      rewrite Hf0; reflexivity.
      specialize HfS with n; destruct HfS as (->,_); congruence.
  exists (fun n => snd (f (S n))).
  intro n'. specialize HfS with n'.
  destruct HfS as (_,HR).
  rewrite Heq in HR.
  assumption.
Qed.


(** * SProbas.v: Definition of the monad for sub-distributions *)
Add Rec LoadPath "." as ALEA.

Require Export Probas.

(* begin hide *)
Set Implicit Arguments.
Open Local Scope U_scope.
Open Local Scope O_scope.
(* end hide *)

(*
Module Proba (Univ:Universe).
Module MP := (Monad Univ).

(* begin hide *)
Import Univ.
Import MP.
Import MP.UP.
(* end hide *)
*)

(** ** Definition of (sub)distribution
Subdistributions are measure functions $\mu$ such that
    - [ mu (1-f) <= 1 - mu f ]
    - [ f <= 1-g -> mu f + mu g <= mu (f+g) ]
    - [ mu f & mu g <= mu (f & g) ]
    - [ mu (f+k) <= mu f + k ]
    - [ mu (k * f) = k * mu (f) ]
    - [ mu (lub f_n) <= lub mu (f_n) ]
*)
Record sdistr (A:Type) : Type :=
  {smu : M A;
   smu_stable_inv : stable_inv smu;
   smu_le_plus : le_plus smu;
   smu_le_esp : le_esp smu;
   smu_le_plus_cte : le_plus_cte smu;
   smu_stable_mult : stable_mult smu;
   smu_continuous : continuous smu}.

Hint Resolve smu_le_plus smu_stable_inv  smu_le_esp smu_stable_mult
smu_continuous.

(** ** Properties of sub-measures *)

Lemma smu_monotonic : forall (A : Type)(m: sdistr A), monotonic (smu m).
intros; apply fmonotonic; auto.
Save.
Hint Resolve smu_monotonic.
Implicit Arguments smu_monotonic [A].

Lemma smu_stable : forall (A : Type)(m: sdistr A), stable (smu m).
intros; apply monotonic_stable; auto.
Save.
Hint Resolve smu_stable.
Implicit Arguments smu_stable [A].

Lemma smu_zero : forall (A : Type)(m: sdistr A), smu m (fzero A) == 0.
intros.
transitivity (smu m (fmult 0 (fzero A))); auto.
transitivity (0 * (smu m (fzero A))); auto.
apply smu_stable_mult; auto.
Save.
Hint Resolve smu_zero.

Lemma smu_stable_mult_right : forall (A : Type)(m:(sdistr A)) (c:U) (f : A -> U),
   smu m (fun x => (f x) * c) == (smu m f) * c.
intros; transitivity (smu m (fun x => c * (f x))).
apply smu_stable; auto.
transitivity (c * smu m f); auto.
exact (smu_stable_mult m c f).
Save.

(*
Lemma smu_one_inv : forall (A : Type)(m:sdistr A),
   smu m (f_one A) == 1 -> forall f, smu m (finv f) == [1-] (smu m f).
intros; apply Ule_antisym.
apply (smu_stable_inv m f).
apply Uplus_le_simpl_left with (smu m f); auto.
setoid_rewrite (Uinv_opp_right (smu m f)).
apply Ule_trans with (smu m (fun x => (f x) + [1-] (f x))).
setoid_rewrite <- H; apply (smu_monotonic m); auto.
apply (smu_le_plus m f (finv f)); auto.
Save.
Hint Resolve smu_one_inv.
*)

Lemma smu_le_minus_left : forall (A : Type)(m:sdistr A) (f g:A -> U),
     smu m (fminus f g) <= smu m f.
intros; auto.
Save.
Hint Resolve smu_le_minus_left.

Lemma smu_le_minus : forall (A:Type) (m:sdistr A)(f g: A -> U),
 g <= f  ->  smu m (fminus f g) <= smu m f - smu m g.
intros.
assert (smu m g <= smu m f).
apply smu_monotonic; auto.
apply Uplus_le_perm_right; auto.
apply Uinv_le_perm_right.
transitivity (smu m (finv g)); auto.
apply (smu_monotonic m); unfold fminus,finv; auto.
apply (smu_stable_inv m).
transitivity (smu m (fplus (fminus f g) g)).
apply (smu_le_plus m).
unfold fplusok,fminus,finv; auto.
apply (smu_monotonic m); unfold fplus,fminus; intros; auto.
Save.
Hint Resolve smu_le_minus.

Lemma smu_cte : forall (A : Type)(m:(sdistr A)) (c:U),
   smu m (fcte A c) == c * smu m (fone A).
intros.
transitivity (smu m (fun x => c * 1)).
apply (smu_stable m); auto.
unfold fone; setoid_rewrite <- (smu_stable_mult m c (fun x => 1)); auto.
Save.
Hint Resolve smu_cte.

Lemma smu_cte_le :   forall (A : Type)(m:(sdistr A)) (c:U),
   smu m (fcte A c) <= c.
intros; transitivity (c * smu m (fone A)); auto.
Save.

Lemma smu_cte_eq : forall (A : Type)(m:(sdistr A)) (c:U),
   smu m (fone A) == 1 -> smu m (fcte A c) == c.
intros; transitivity (c * smu m (fone A)); auto.
Save.

Hint Resolve smu_cte_le smu_cte_eq.

Lemma smu_le_minus_cte : forall (A:Type) (m:sdistr A)(f: A -> U) (k:U),
     smu m f - k  <= smu m (fminus f (fcte A k)).
intros; apply (Ule_total (smu m f) k); auto; intros.
rewrite Uminus_le_zero; auto.
apply Uplus_le_perm_left; auto.
transitivity (smu m (fplus (fminus f (fcte A k)) (fcte A k))).
apply (smu_monotonic m); unfold fplus, fminus,fcte.
intro x; apply (Ule_total (f x) k); auto.
transitivity (smu m (fminus f (fcte A k)) +k); auto.
apply (smu_le_plus_cte m); auto.
Save.

Lemma smu_inv_le_minus :
forall (A:Type) (m:sdistr A)(f: A -> U),  smu m (finv f) <= smu m (fone A) - smu m f.
intros; transitivity (smu m (fminus (fone A) f)).
apply (smu_monotonic m); unfold finv,fminus,fone; intros; auto.
apply smu_le_minus; auto.
Save.

Lemma smu_inv_minus_inv : forall (A:Type) (m:sdistr A)(f: A -> U),
     smu m (finv f) + [1-](smu m (fone A)) <= [1-](smu m f).
intros; apply Uminus_le_perm_right.
apply Uinv_le_compat.
apply (smu_monotonic m); unfold fone; auto.
unfold Uminus; Usimpl.
transitivity (smu m (fone A) - smu m f).
apply smu_inv_le_minus.
unfold Uminus.
apply Uinv_le_compat; auto.
Save.

Definition stable_plus_sdistr : forall A (m:M A),
  stable_plus m -> stable_inv m -> stable_mult m -> continuous m -> sdistr A.
intros; exists m; auto.
intros f g okfg.
rewrite H; auto.
apply le_esp_distr; auto.
intros f k.
rewrite le_plus_distr; repeat Usimpl; auto.
transitivity (m (fmult k (fone A))).
apply (fmonotonic m); unfold fcte,fmult,fone; auto.
rewrite H1.
transitivity (k*1); auto.
Defined.

Definition distr_sdistr : forall A, distr A -> sdistr A.
intros A d; apply (stable_plus_sdistr (m:=mu d)); auto.
Defined.

Definition Sunit A (x:A) : sdistr A := distr_sdistr (Munit x).

Lemma Sunit_unit : forall A (x:A), smu (Sunit x) = unit x.
trivial.
Save.

Lemma Sunit_simpl : forall A (x:A) (f : MF A), smu (Sunit x) f = f x.
trivial.
Save.

Definition Slet : forall A B:Type, (sdistr A) -> (A -> sdistr B) -> sdistr B.
intros A B mA mB.
exists (star (smu mA) (fun x => (smu (mB x)))).
apply star_stable_inv; auto.
apply star_le_plus; auto.
intros a f g Hfg.
transitivity (smu (mB a) (finv g)); auto.
apply smu_stable_inv.
intros f g.
repeat rewrite star_simpl.
rewrite (smu_le_esp mA).
apply (fmonotonic (smu mA)); auto.
intro x; unfold fesp; apply (smu_le_esp (mB x)).
intros f k.
repeat rewrite star_simpl.
rewrite <- (smu_le_plus_cte mA).
apply (fmonotonic (smu mA)); auto.
intro x; unfold fplus,fcte; apply (smu_le_plus_cte (mB x)).
apply star_stable_mult; trivial.
apply star_continuous; trivial.
Defined.

Lemma Slet_star : forall (A B:Type) (m:sdistr A) (M : A -> sdistr B),
      smu (Slet m M) = star (smu m) (fun x => smu (M x)).
trivial.
Save.

Lemma Slet_simpl : forall A B (m:sdistr A) (M : A -> sdistr B) (f:MF B),
                   smu (Slet m M) f = smu m (fun x => smu (M x) f).
trivial.
Save.

(** Non deterministic choice *)

Definition Smin (A:Type)(m1 m2 : sdistr A) : sdistr A.
intros; exists ((Min @2 smu m1) (smu m2)).
intro f; repeat rewrite app2_simpl, Min_simpl.
rewrite Uinv_min_max.
transitivity (smu m1 (finv f)); auto.
rewrite smu_stable_inv; auto.
intros f g Hfg; repeat rewrite app2_simpl, Min_simpl.
transitivity (min (smu m1 f + smu m1 g) (smu m2 f+smu m2 g)); auto.
apply min_le_compat; apply smu_le_plus; auto.
intros f g; repeat rewrite app2_simpl, Min_simpl.
rewrite Uesp_min.
apply min_le_compat; apply smu_le_esp.
intros f k; repeat rewrite app2_simpl, Min_simpl.
rewrite <- min_plus_cte.
apply min_le_compat; apply smu_le_plus_cte.
intros k f; repeat rewrite app2_simpl, Min_simpl.
rewrite (smu_stable_mult m1 k f); rewrite (smu_stable_mult m2 k f); auto.
apply continuous2_app2; auto; apply smu_continuous.
Save.

(** ** Operations on sub-distributions *)

Instance Osdistr (A : Type) : ord (sdistr A) :=
     { Ole := fun f g => smu f <= smu g;
       Oeq := fun f g => smu f == smu g}.
split; auto; intros.
intuition.
intros f g h; transitivity (smu g); auto.
Defined.

Lemma Sunit_compat : forall A (x y : A), x = y -> Sunit x == Sunit y.
intros; subst; auto.
Save.

Lemma Slet_compat : forall (A B : Type) (m1 m2:sdistr A) (M1 M2 : A-> sdistr B),
  m1 == m2 -> M1 == M2 -> Slet m1 M1 == Slet m2 M2.
intros; intro f; repeat rewrite Slet_simpl.
transitivity (smu m2 (fun x : A => smu (M1 x) f)); auto.
apply smu_stable; intro x; auto.
apply (H0 x f).
Save.

Lemma le_sdistr_gen : forall (A:Type) (m1 m2:sdistr A),
  m1 <= m2 -> forall f g,  f <= g -> smu m1 f <= smu m2 g.
intros; transitivity (smu m2 f); auto.
Save.

(** ** Properties of monadic operators *)
Lemma Slet_unit : forall (A B:Type) (x:A) (m:A -> sdistr B), Slet (Sunit x) m == m x.
intros; intro f.
repeat (rewrite Slet_star).
rewrite Sunit_unit; rewrite law1; trivial.
Save.

Lemma M_ext : forall (A:Type) (m:sdistr A), Slet m (fun x => Sunit x) == m.
intros; intros f; rewrite Slet_star.
rewrite law2; trivial.
Save.

Lemma Mcomp : forall (A B C:Type) (m1:(sdistr A)) (m2:A -> sdistr B) (m3:B -> sdistr C),
     Slet (Slet m1 m2) m3 == Slet m1 (fun x:A => (Slet (m2 x) m3)).
intros; intros f; repeat rewrite Slet_star.
rewrite law3; trivial.
Save.

Lemma Slet_le_compat : forall (A B:Type) (m1 m2: sdistr A) (f1 f2 : A -> sdistr B),
  m1 <= m2 -> f1 <= f2 -> Slet m1 f1 <= Slet m2 f2.
intros; intros f; repeat rewrite Slet_star.
apply star_le_compat; auto.
Save.

(** ** A specific subdistribution *)
Definition sdistr_null : forall A : Type, sdistr A.
intro A; exists (mon (cte (MF A) (0:U))); try red; auto.
Defined.

Lemma le_sdistr_null : forall (A:Type) (m : sdistr A), sdistr_null A <= m.
red; intros.
unfold sdistr_null; simpl; auto.
Save.
Hint Resolve le_sdistr_null.

(** ** Least upper bound of increasing sequences of sdistributions *)
Section Lubs.
Variable A : Type.

Definition Smu : sdistr A -m> M A.
exists (smu (A:=A)); auto.
Defined.

Lemma Smu_simpl : forall d f, Smu d f = smu d f.
trivial.
Save.

Variable smuf : nat -m> sdistr A.

Definition smu_lub: sdistr A.
exists (lub (Smu @ smuf)).

red; intros; simpl; apply lub_inv; intros; simpl.
apply (smu_stable_inv (smuf n)).

red; intros; repeat rewrite M_lub_simpl.
rewrite Uplus_lub_eq.
apply lub_le_compat; intro n; simpl; auto.
exact (smu_le_plus (smuf n) H).

red; intros; repeat rewrite M_lub_simpl.
rewrite Uesp_lub_eq.
apply lub_le_compat; intro n; simpl; auto.
exact (smu_le_esp (smuf n) f g).

red; intros; repeat rewrite M_lub_simpl.
rewrite <- lub_eq_plus_cte_right.
apply lub_le_compat; intro n; simpl; auto.
exact (smu_le_plus_cte (smuf n) f k).

red; intros; repeat rewrite M_lub_simpl.
rewrite <- lub_eq_mult.
apply lub_eq_compat; intro n; simpl; auto.
exact (smu_stable_mult (smuf n) k f).

unfold M; apply lub_continuous; intros.
apply (smu_continuous (smuf n)).
Defined.

Lemma smu_lub_simpl : smu smu_lub = lub (Smu @ smuf).
trivial.
Save.

Lemma smu_lub_le : forall n:nat, smuf n <= smu_lub.
intros n f.
rewrite smu_lub_simpl.
exact (le_lub (Smu @ smuf) n f).
Save.

Lemma smu_lub_sup : forall m:sdistr A, (forall n:nat, smuf n <= m) -> smu_lub <= m.
intros m H f; exact (lub_le (Smu @ smuf) (smu m) H f).
Save.

End Lubs.

(** ** Sub-distribution for [flip]
The distribution associated to [flip ()] is
       $f \mapsto \frac{1}{2}f(true)+\frac{1}{2}f(false)$ *)
Definition Sflip : sdistr bool := distr_sdistr Flip.

Lemma Sflip_simpl : smu Sflip = flip.
trivial.
Save.

(** ** Uniform sub-distribution beween 0 and n *)
Require Arith.

(** *** Distribution for [Srandom n]
The sdistribution associated to [Srandom n] is
       $f \mapsto \Sigma_{i=0}^n \frac{f(i)}{n+1}$
       we cannot factorize $\frac{1}{n+1}$ because of possible overflow *)

Definition Srandom (n:nat): sdistr nat:= distr_sdistr (Random n).

Lemma Srandom_simpl : forall n, smu (Srandom n) = random n.
trivial.
Save.


(** * ImpCEvalFun: An Evaluation Function for Imp *)

(** We saw in the [Imp] chapter how a naive approach to defining a
    function representing evaluation for Imp runs into difficulties.
    There, we adopted the solution of changing from a functional to a
    relational definition of evaluation.  In this optional chapter, we
    consider strategies for getting the functional approach to
    work. *)

(* ################################################################# *)
(** * A Broken Evaluator *)

Require Import Coq.omega.Omega.
Require Import Coq.Arith.Arith.
Require Import Imp Maps.

(** Here was our first try at an evaluation function for commands,
    omitting [WHILE]. *)

Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
    | SKIP =>
        st
    | l ::= a1 =>
        st & { l --> (aeval st a1)}
    | c1 ;; c2 =>
        let st' := ceval_step1 st c1 in
        ceval_step1 st' c2
    | IFB b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_step1 st c1
          else ceval_step1 st c2
    | WHILE b1 DO c1 END =>
        st  (* bogus *)
  end.

(** As we remarked in chapter [Imp], in a traditional functional
    programming language like ML or Haskell we could write the WHILE
    case as follows:

    | WHILE b1 DO c1 END => if (beval st b1) then ceval_step1 st (c1;;
        WHILE b1 DO c1 END) else st

    Coq doesn't accept such a definition ([Error: Cannot guess
    decreasing argument of fix]) because the function we want to
    define is not guaranteed to terminate. Indeed, the changed
    [ceval_step1] function applied to the [loop] program from [Imp.v]
    would never terminate. Since Coq is not just a functional
    programming language, but also a consistent logic, any potentially
    non-terminating function needs to be rejected. Here is an
    invalid(!) Coq program showing what would go wrong if Coq allowed
    non-terminating recursive functions:

     Fixpoint loop_false (n : nat) : False := loop_false n.

    That is, propositions like [False] would become
    provable (e.g., [loop_false 0] would be a proof of [False]), which
    would be a disaster for Coq's logical consistency.

    Thus, because it doesn't terminate on all inputs, the full version
    of [ceval_step1] cannot be written in Coq -- at least not without
    one additional trick... *)

(* ################################################################# *)
(** * A Step-Indexed Evaluator *)

(** The trick we need is to pass an _additional_ parameter to the
    evaluation function that tells it how long to run.  Informally, we
    start the evaluator with a certain amount of "gas" in its tank,
    and we allow it to run until either it terminates in the usual way
    _or_ it runs out of gas, at which point we simply stop evaluating
    and say that the final result is the empty memory.  (We could also
    say that the result is the current state at the point where the
    evaluator runs out of gas -- it doesn't really matter because the
    result is going to be wrong in either case!) *)

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => { --> 0 }
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          st & { l --> (aeval st a1) }
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.

(** _Note_: It is tempting to think that the index [i] here is
    counting the "number of steps of evaluation."  But if you look
    closely you'll see that this is not the case: for example, in the
    rule for sequencing, the same [i] is passed to both recursive
    calls.  Understanding the exact way that [i] is treated will be
    important in the proof of [ceval__ceval_step], which is given as
    an exercise below.

    One thing that is not so nice about this evaluator is that we
    can't tell, from its result, whether it stopped because the
    program terminated normally or because it ran out of gas.  Our
    next version returns an [option state] instead of just a [state],
    so that we can distinguish between normal and abnormal
    termination. *)

Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (st & { l --> (aeval st a1) })
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.

(** We can improve the readability of this version by introducing a
    bit of auxiliary notation to hide the plumbing involved in
    repeatedly matching against optional states. *)

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (st & { l --> (aeval st a1)})
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None    => None
  | Some st => Some (st X, st Y, st Z)
  end.

(* Compute
     (test_ceval { --> 0 }
         (X ::= 2;;
          IFB (X <= 1)
            THEN Y ::= 3
            ELSE Z ::= 4
          FI)).
   ====>
      Some (2, 0, 4)   *)

(** **** Exercise: 2 stars, recommended (pup_to_n)  *)
(** Write an Imp program that sums the numbers from [1] to
   [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y].  Make sure
   your solution satisfies the test that follows. *)

Definition pup_to_n : com
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(*

Example pup_to_n_1 :
  test_ceval {X --> 5} pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.
*)
(** [] *)

(** **** Exercise: 2 stars, optional (peven)  *)
(** Write a [While] program that sets [Z] to [0] if [X] is even and
    sets [Z] to [1] otherwise.  Use [ceval_test] to test your
    program. *)

(* FILL IN HERE *)
(** [] *)

(* ################################################################# *)
(** * Relational vs. Step-Indexed Evaluation *)

(** As for arithmetic and boolean expressions, we'd hope that
    the two alternative definitions of evaluation would actually
    amount to the same thing in the end.  This section shows that this
    is the case. *)

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      c / st \\ st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].

  - (* i = 0 -- contradictory *)
    intros c st st' H. inversion H.

  - (* i = S i' *)
    intros c st st' H.
    destruct c;
           simpl in H; inversion H; subst; clear H.
      + (* SKIP *) apply E_Skip.
      + (* ::= *) apply E_Ass. reflexivity.

      + (* ;; *)
        destruct (ceval_step st c1 i') eqn:Heqr1.
        * (* Evaluation of r1 terminates normally *)
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        * (* Otherwise -- contradiction *)
          inversion H1.

      + (* IFB *)
        destruct (beval st b) eqn:Heqr.
        * (* r = true *)
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        * (* r = false *)
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.

      + (* WHILE *) destruct (beval st b) eqn :Heqr.
        * (* r = true *)
         destruct (ceval_step st c i') eqn:Heqr1.
         { (* r1 = Some s *)
           apply E_WhileTrue with s. rewrite Heqr.
           reflexivity.
           apply IHi'. rewrite Heqr1. reflexivity.
           apply IHi'. simpl in H1. assumption. }
         { (* r1 = None *) inversion H1. }
        * (* r = false *)
          inversion H1.
          apply E_WhileFalse.
          rewrite <- Heqr. subst. reflexivity.  Qed.

(** **** Exercise: 4 stars (ceval_step__ceval_inf)  *)
(** Write an informal proof of [ceval_step__ceval], following the
    usual template.  (The template for case analysis on an inductively
    defined value should look the same as for induction, except that
    there is no induction hypothesis.)  Make your proof communicate
    the main ideas to a human reader; do not simply transcribe the
    steps of the formal proof.

(* FILL IN HERE *)
*)
(** [] *)

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  - (* i1 = 0 *)
    simpl in Hceval. inversion Hceval.
  - (* i1 = S i1' *)
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' <= i2') by omega.
    destruct c.
    + (* SKIP *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ::= *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ;; *)
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* st1'o = None *)
        inversion Hceval.

    + (* IFB *)
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval;
        assumption.

    + (* WHILE *)
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* i1'o = None *)
        simpl in Hceval. inversion Hceval.  Qed.

(** **** Exercise: 3 stars, recommended (ceval__ceval_step)  *)
(** Finish the following proof.  You'll need [ceval_step_more] in a
    few places, as well as some basic facts about [<=] and [plus]. *)

Theorem ceval__ceval_step: forall c st st',
      c / st \\ st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem ceval_and_ceval_step_coincide: forall c st st',
      c / st \\ st'
  <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

(* ################################################################# *)
(** * Determinism of Evaluation Again *)

(** Using the fact that the relational and step-indexed definition of
    evaluation are the same, we can give a slicker proof that the
    evaluation _relation_ is deterministic. *)

Theorem ceval_deterministic' : forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega.  Qed.


Require Import ssreflect ssrbool ssrnat ssrfun eqtype fintype.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import JMeq.

(* This file defines cast operations and lemmas useful for doing rewrites *)
(* in dependent types.                                                    *)

Definition cast_ty (T1 T2 : Type) (pf : T1=T2) : T1 -> T2 :=
  eq_rect_r (fun y : Type => y -> T2) id pf.

Lemma cast_ty_erefl T1 (x : T1) : cast_ty (erefl T1) x = x.
Proof. by rewrite/cast_ty. Qed.

Lemma cast_ty_JMeq T1 T2 (pf : T1=T2) (x : T1) : JMeq (cast_ty pf x) x.
Proof. by rewrite <-pf; rewrite -(cast_ty_erefl x). Qed.

Section lift.

Variable A : Type.
Variable lift_ty : A -> Type.

Lemma lift_eq i j (pf : i = j) : lift_ty i = lift_ty j.
Proof. by elim: pf. Defined.

End lift.

Section ind.

Variable T : Type -> Type.
Variables A B : Type.
Variable P : forall A : Type, T A -> Type.

Lemma cast_ind (x : T A) (eq : A=B) (pf : P x) : P (cast_ty (lift_eq T eq) x).
Proof. by rewrite <-eq; rewrite (cast_ty_erefl x). Qed.

Lemma cast_ind' (x : T A) (eq : A=B) (pf : P (cast_ty (lift_eq T eq) x)) : P x.
Proof.
by move: pf; rewrite <-eq; rewrite (cast_ty_erefl x).
Qed.

End ind.

Section cast_f.

Variable N : nat.
Variable T U : 'I_N -> Type.
Variable i j : 'I_N.
Variable f : forall i : 'I_N, T i -> U i.

Lemma cast_f (x : T i) (eq : i=j) :
  f (cast_ty (lift_eq T eq) x) = cast_ty (lift_eq U eq) (f x).
Proof. by rewrite <-eq; rewrite !cast_ty_erefl. Qed.

End cast_f.

Section ind_natdep.

Variable N : nat.
Variable T : 'I_N -> Type.
Variables i j : 'I_N.
Variable P : forall i : 'I_N, T i -> Type.

Lemma cast_indnatdep
  (x : T i) (eq : i=j) (pf : P x) : P (cast_ty (lift_eq T eq) x).
Proof. by rewrite <-eq; rewrite (cast_ty_erefl x). Qed.

Lemma cast_indnatdep'
  (x : T i) (eq : i=j) (pf : P (cast_ty (lift_eq T eq) x)) : P x.
Proof.
by move: pf; rewrite <-eq; rewrite (cast_ty_erefl x).
Qed.

Lemma cast_indnatdep''
  (x : T i) (eq : j = i) (pf : P (cast_ty (lift_eq T (sym_eq eq)) x)) : P x.
Proof.
by move: pf; subst j; rewrite (cast_ty_erefl x).
Qed.

End ind_natdep.

Section ind_natdep2.

Variable N : nat.
Variable T : 'I_N -> Type.
Variable U : 'I_N -> Type.
Variable i j : 'I_N.
Variable P : forall i : 'I_N, T i -> U i -> Type.
Variable x : T i.
Variable y : U j.

Lemma cast_indnatdep2 (eq : j = i) :
  P (cast_ty (lift_eq T (sym_eq eq)) x) y ->
  P x (cast_ty (lift_eq U eq) y).
Proof. destruct eq=> //. Qed.

End ind_natdep2.

Section ind_natdep_general.

Variable N : nat.
Variable T : 'I_N -> Type.
Variable U : 'I_N -> Type.
Variable V : 'I_N -> Type.
Variable i j k : 'I_N.
Variable P : forall i : 'I_N, T i -> U i -> V i -> Type.
Variable x : T i.
Variable y : U j.
Variable z : V k.

Lemma cast_indnatdep_general (eq_ij : i = j) (eq_ik : i = k) :
  P x
    (cast_ty (lift_eq U (sym_eq eq_ij)) y)
    (cast_ty (lift_eq V (sym_eq eq_ik)) z) ->

  P (cast_ty (lift_eq T eq_ik) x)
    (cast_ty (lift_eq U (eq_trans (sym_eq eq_ij) eq_ik)) y)
    z.
Proof. destruct eq_ij; destruct eq_ik=> //. Qed.

End ind_natdep_general.

Section ind_natdep31.

Variable N : nat.
Variable T : 'I_N -> Type.
Variable U : 'I_N -> Type.
Variable V : 'I_N -> Type.
Variable i j : 'I_N.
Variable P : forall i : 'I_N, T i -> U i -> V i -> Type.
Variable x : T i.
Variable y : U i.
Variable z : V j.

Lemma cast_indnatdep31 (eq : i = j) :
  P x y (cast_ty (lift_eq V (sym_eq eq)) z) ->
  P (cast_ty (lift_eq T eq) x) (cast_ty (lift_eq U eq) y) z.
Proof. destruct eq=> //. Qed.

End ind_natdep31.

Section ind_natdep32.

Variable N : nat.
Variable T : 'I_N -> Type.
Variable U : 'I_N -> Type.
Variable V : 'I_N -> Type.
Variable i j : 'I_N.
Variable P : forall i : 'I_N, T i -> U i -> V i -> Type.
Variable x : T i.
Variable y : U i.
Variable z : V j.

Lemma cast_indnatdep32 (eq : j = i) :
  P (cast_ty (lift_eq T (sym_eq eq)) x) (cast_ty (lift_eq U (sym_eq eq)) y) z ->
  P x y (cast_ty (lift_eq V eq) z).
Proof. destruct eq=> //. Qed.

End ind_natdep32.

Section ind_natdep33.

Variable N : nat.
Variable T : 'I_N -> Type.
Variable U : 'I_N -> Type.
Variable V : 'I_N -> Type.
Variable i j : 'I_N.
Variable P : forall i : 'I_N, T i -> U i -> V i -> Type.
Variable x : T i.
Variable y : U j.
Variable z : V i.

Lemma cast_indnatdep33 (eq : i = j) :
  P x (cast_ty (lift_eq U (sym_eq eq)) y) z ->
  P (cast_ty (lift_eq T eq) x) y (cast_ty (lift_eq V eq) z).
Proof. destruct eq=> //. Qed.

Lemma cast_indnatdep33' (eq : j = i) :
  P x (cast_ty (lift_eq U eq) y) z ->
  P (cast_ty (lift_eq T (sym_eq eq)) x) y (cast_ty (lift_eq V (sym_eq eq)) z).
Proof. destruct eq=> //. Qed.

End ind_natdep33.

Notation cast F pf x := (cast_ty (lift_eq F pf) x).

Lemma cast_cast_eq A F (i j : A) (pf : i = j) (x : F i) :
  cast F (sym_eq pf) (cast F pf x)  = x.
Proof.
have EQ: JMeq (cast F (sym_eq pf) (cast F pf x)) x
  by do 2 rewrite cast_ty_JMeq.
by rewrite EQ.
Qed.

Lemma cast_cast_eq' A F (i j : A) (pf1 : j = i) (pf2 : i = j) (x : F i) :
  cast F pf1 (cast F pf2 x)  = x.
Proof.
have EQ: JMeq (cast F pf1 (cast F pf2 x)) x
  by do 2 rewrite cast_ty_JMeq.
by rewrite EQ.
Qed.


Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Psatz.
Import ListNotations.

From PLF Require Import Maps.

Inductive val : Type :=
| val_bool: bool -> val
| val_nat: nat -> val
| val_listnat : list nat -> val
| val_fun: string -> trm -> val
| val_fix: string -> string -> trm -> val
| val_tuple: list val -> val
with trm : Type :=
| trm_val : val -> trm
| trm_var : string -> trm
| trm_tuple: list trm -> trm
| trm_app : trm -> trm -> trm
| trm_let : string -> trm -> trm -> trm
| trm_if : trm -> trm -> trm -> trm
| trm_cons: trm -> trm -> trm
| trm_match_list: trm -> trm -> (string * string * trm) -> trm.

Coercion val_bool : bool >-> val.
Coercion val_nat : nat >-> val.

Fixpoint subst (y:string) (w:val) (t:trm) : trm :=
  let aux t := subst y w t in
  let if_y_eq x t1 t2 := if String.eqb x y then t1 else t2 in
  match t with
  | trm_val v => trm_val (subst_val y w v)
  | trm_var x => if_y_eq x (trm_val w) t
  | trm_app t1 t2 => trm_app (aux t1) (aux t2)
  | trm_let x t1 t2 => trm_let x (aux t1) (if_y_eq x t2 (aux t2))
  | trm_if t0 t1 t2 => trm_if (aux t0) (aux t1) (aux t2)
  | trm_cons t0 t1 => trm_cons (aux t0) (aux t1)
  | trm_match_list t0 t1 (p, q, t2) => trm_match_list (aux t0) (aux t1) (p, q, if_y_eq p t2 (if_y_eq q t2 (aux t2)))
  | trm_tuple ts => trm_tuple (map aux ts)
  end
with subst_val (y:string) (w:val) (t:val) : val :=
  let aux t := subst_val y w t in
  let if_y_eq x t1 t2 := if String.eqb x y then t1 else t2 in
  match t with
  | val_bool _ | val_nat _ | val_listnat _ => t
  | val_fun x t1 => val_fun x (if_y_eq x t1 (subst y w t1))
  | val_fix f x t1 => val_fix f x (if_y_eq f t1 (if_y_eq x t1 (subst y w t1)))
  | val_tuple ts => val_tuple (map aux ts)
  end.

Implicit Types b : bool.
Implicit Types v r : val.
Implicit Types t : trm.
Coercion trm_val : val >-> trm.
Coercion trm_var : string >-> trm.
Coercion trm_app : trm >-> Funclass.

Inductive eval : trm -> val -> Prop :=
| eval_val : forall v, eval (trm_val v) v
| eval_fun : forall x body, eval (trm_val (val_fun x body)) (val_fun x body)
| eval_fix : forall f x body, eval (trm_val (val_fix f x body)) (val_fix f x body)
| eval_tuple_nil : eval (trm_tuple nil) (val_tuple nil)
| eval_tuple_cons : forall t1 (t2: list trm) v1 (v2: list val),
  eval t1 v1 ->
  eval (trm_tuple t2) (val_tuple v2) ->
  eval (trm_tuple (t1::t2)) (val_tuple (v1::v2))
| eval_app_fun : forall f v2 x t1 t2 v,
      eval f (val_fun x t1) ->
      eval t2 v2 ->
      eval (subst x v2 t1) v ->
      eval (trm_app f t2) v
| eval_app_fix : forall fixf v2 f x t1 t2 v,
    eval fixf (val_fix f x t1) ->
    eval t2 v2 ->
    eval (subst x v2 (subst f (val_fix f x t1) t1)) v ->
    eval (trm_app fixf t2) v
| eval_let : forall x t1 t2 v1 r,
    eval t1 v1 ->
    eval (subst x v1 t2) r ->
    eval (trm_let x t1 t2) r
| eval_if : forall b v t1 t2,
    eval (if b then t1 else t2) v ->
    eval (trm_if (val_bool b) t1 t2) v
| eval_cons : forall t1 t2 (v1: nat) (v2: list nat),
    eval t1 (val_nat v1) ->
    eval t2 (val_listnat v2) ->
    eval (trm_cons t1 t2) (val_listnat (v1 :: v2))
| eval_match_list : forall (x1 x2: string) (l: list nat) t1 t2 v,
    eval
      (match l with
       | nil => t1
       | v1 :: v2 =>
           trm_let x1 (val_nat v1) (trm_let x2 (val_listnat v2) t2)
       end) v ->
    eval (trm_match_list (val_listnat l) t1 (x1, x2, t2)) v.

Hint Constructors eval.

Inductive tp: Type :=
| tp_nat: (nat -> Prop) -> tp
| tp_listnat: (list nat -> Prop) -> tp
| tp_arrow: tp -> tp -> tp.

Definition context := partial_map tp.

Inductive has_type_val: context -> val -> tp -> Prop :=
| t_nat: forall m n, has_type_val m (val_nat n) (tp_nat (fun x => x = n))
| t_listnat: forall m l, has_type_val m (val_listnat l) (tp_listnat (fun x => x = l))
| t_fun: forall m x body (in_tp out_tp: tp),
    has_type_trm (m & {x --> Some in_tp}) body out_tp ->
    has_type_val m (val_fun x body) (tp_arrow in_tp out_tp)
| t_fix: forall m f x body (in_tp out_tp: tp),
    has_type_trm (m & {x --> Some in_tp} & {f --> Some (tp_arrow in_tp out_tp)}) body out_tp ->
    has_type_val m (val_fix f x body) (tp_arrow in_tp out_tp)
with has_type_trm: context -> trm -> tp -> Prop :=
| t_val: forall m v tp, has_type_val m v tp -> has_type_trm m (trm_val v) tp
| t_app : forall m f arg in_tp out_tp,
    has_type_trm m arg in_tp ->
    has_type_trm m f (tp_arrow in_tp out_tp) ->
    has_type_trm m (trm_app f arg) out_tp
| t_let : forall m x t1 t2 tp1 tp,
    has_type_trm m t1 tp1 ->
    has_type_trm (m & {x --> Some tp1}) t2 tp ->
    has_type_trm m (trm_let x t1 t2) tp
| t_cons : forall m t1 t2 p1 p2,
    has_type_trm m t1 (tp_nat p1) ->
    has_type_trm m t2 (tp_listnat p2) ->
    has_type_trm m (trm_cons t1 t2)
                 (tp_listnat
                    (fun l => exists x y ,
                         l = x::y /\ p1 x /\ p2 y
                 ))
| t_match_list_nil : forall m (x1 x2: string) t0 t1 t2 tp,
    has_type_trm m t0 (tp_listnat (fun x => x = nil)) ->
    has_type_trm m t1 tp ->
    has_type_trm m (trm_match_list t0 t1 (x1, x2, t2)) tp
| t_match_list_cons : forall m (x1 x2: string) t0 t1 t2 tp p,
    has_type_trm m t0 (tp_listnat p) ->
    has_type_trm
      (m & {x1 --> Some (tp_nat (fun h => exists tt, p (h :: tt))); x2 --> Some (tp_listnat (fun tt => exists h, p (h :: tt )))}) t2 tp ->
    has_type_trm m (trm_match_list t0 t1 (x1, x2, t2)) tp.

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".
Definition S1 : string := "S1".
Definition S2 : string := "S2".
Definition S3 : string := "S3".
Definition H : string := "H".
Definition T : string := "T".
Definition NU : string := "NU".
Definition CONCAT : string := "CONCAT".

Definition concat_program :=
  val_fix CONCAT S1 (
            trm_match_list S1 (val_fun S2 S2)
                           (H, T,
                             trm_val (val_fun S2 (trm_cons H (CONCAT T S2)))
                           )
          ).

Lemma concat_example0 :
  eval (concat_program (val_listnat []) (val_listnat [1;3])) (val_listnat [1;3]).
Proof.
  unfold concat_program.
  eapply eval_app_fun with (x := S2); simpl; eauto.
  - eapply eval_app_fix with (x := S1); simpl; eauto.
    eapply eval_match_list; simpl; eauto.
  - simpl; eauto.
Qed.

Lemma concat_example1 :
  eval (concat_program (val_listnat [2]) (val_listnat [1;3])) (val_listnat [2;1;3]).
Proof.
  unfold concat_program.
  eapply eval_app_fun with (x := S2); simpl; eauto.
  - eapply eval_app_fix with (x := S1); simpl; eauto.
    eapply eval_match_list; simpl; eauto.
    eapply eval_let; simpl; auto.
    eapply eval_let; simpl; auto.
  - simpl.
    eapply eval_cons; simpl; eauto.
    fold concat_program.
    apply concat_example0.
Qed.

Lemma concat_empty : forall s,
    eval (concat_program (val_listnat []) (val_listnat s)) (val_listnat s).
Proof.
  unfold concat_program.
  intros s.
  eapply eval_app_fun with (x := S2); simpl; eauto.
  - eapply eval_app_fix with (x := S1); simpl; eauto.
    eapply eval_match_list; simpl; eauto.
  - simpl; eauto.
Qed.

Definition hd (l : list nat) (x: nat) :=
  match l with
  | nil => false
  | cons h t => Nat.eqb h x
  end.

Fixpoint mem (l : list nat) (x: nat) :=
  match l with
  | nil => false
  | cons h t => (if Nat.eqb h x then true else mem t x)
  end.

Fixpoint order (l : list nat) (u v: nat) :=
  match l with
  | nil => false
  | cons h t =>
      if Nat.eqb u h then mem t v else order t u v
  end.

Lemma mem_then_exists_first (l: list nat) (u: nat) :
  mem l u = true -> exists s1 s2, s1 ++ (u :: s2) = l /\ ~ (mem s1 u = true).
Admitted.

Lemma mem_concat (l1 l2: list nat) (u: nat) :
  (mem l1 u = true \/ mem l2 u = true) -> mem (l1 ++ l2) u = true.
Proof.
  intros H.
  destruct H.
  + induction l1.
    - intros. inversion H0.
    - intros. simpl. simpl in H0. destruct (Nat.eqb a u).
      auto. auto.
  + induction l1.
    - auto.
    - simpl. destruct (Nat.eqb a u); auto.
Qed.

Lemma l1 (nu: list nat) :
  (exists (u v: nat), hd nu u = true /\ mem nu v = true /\ v > u /\ (forall w, mem nu w = true -> (u >= w \/ v = w))) ->
  exists s1 s2,
    (forall (u v: nat), (hd s1 u = true /\ mem s1 v = true) -> u >= v) /\
      (forall (u v: nat), (hd s2 u = true /\ mem s2 v = true) -> u >= v) /\ s1 ++ s2 = nu.
Proof.
  intro H.
  destruct H as (u & v & H0 & H1 & H2 & H).
  apply mem_then_exists_first in H1. destruct H1 as (s1 & s2 & Hconcat & HNmem).
  exists s1, (v :: s2).
  repeat split; auto.
  + intros u' v' (H1' & H2').
    assert (u' = u). { destruct s1. inversion H1'. inversion H1'. subst. inversion H0. apply Nat.eqb_eq in H3. apply Nat.eqb_eq in H4. subst. auto. } subst.
    assert (mem (s1 ++ v :: s2) v' = true). apply mem_concat; auto.
    apply H in H1. destruct H1; subst; auto. exfalso. auto.
  + intros u' v' (H1' & H2').
    assert (u' = v). { subst. inversion H1'.  apply Nat.eqb_eq in H3. auto. } subst.
    assert (mem (s1 ++ v :: s2) v' = true). apply mem_concat; auto.
    apply H in H1. destruct H1; subst; auto. lia.
Qed.

Definition under_pre0 (s1 s2: list nat): Prop :=
  forall u, order s1 u u = false /\ order s2 u u = false /\ ~ (exists (v: nat), mem s1 v = true /\ mem s2 v = true).

Definition under_post0 (nu: list nat): Prop := forall u, order nu u u = false.

Lemma concat_under0 : forall nu,
    under_post0 nu ->
    exists s1 s2,
      under_pre0 s1 s2 /\
        eval (concat_program (val_listnat s1) (val_listnat s2)) (val_listnat nu).
Proof.
  unfold concat_program.
  intros nu HQ.
  exists nil, nu.
  split.
  + intros u. repeat (split; auto). intros H. inversion H. destruct H0. inversion H0.
  + eapply eval_app_fun with (x := S2); simpl; eauto.
    - eapply eval_app_fix with (x := S1); simpl; eauto.
      eapply eval_match_list; simpl; eauto.
    - simpl; auto.
Qed.

Definition under_pre1 (s1 s2: list nat): Prop :=
  forall u, order s1 u u = false /\ order s2 u u = false /\ (exists (v: nat), mem s1 v = true /\ mem s2 v = true).

Definition splitable (nu: list nat): Prop :=
  exists s1 s2, nu = s1 ++ s2 /\ (forall u, order s1 u u = false) /\ (forall u, order s2 u u = false).

Definition under_post1_precise (nu: list nat) : Prop := (exists u, order nu u u = true) /\ splitable nu.

Definition under_post1_appr (nu: list nat): Prop :=
  (exists u, order nu u u = true) /\
    (exists w, forall (u v: nat),
        (order nu u w = true /\ order nu v w = true /\ order nu u v = true -> ~ u = v) /\
          (order nu w u = true /\ order nu w v = true /\ order nu u v = true -> ~ u = v) /\
          (order nu w w = false)
    ).

Lemma unde_post1_appr_valid: forall nu, under_post1_appr nu -> under_post1_precise nu.
Proof.
Admitted.

Lemma duplist_after_split_shared_same_elem: forall nu s1 s2,
    (exists u, order nu u u = true) ->
    (forall u, order s1 u u = false) ->
    (forall u, order s2 u u = false) ->
    nu = s1 ++ s2 ->
    (exists u, mem s1 u = true /\ mem s2 u = true).
Proof. Admitted.

Lemma concat_under1 : forall nu,
    under_post1_precise nu ->
    exists s1 s2,
      under_pre1 s1 s2 /\
        eval (concat_program (val_listnat s1) (val_listnat s2)) (val_listnat nu).
Proof.
  unfold concat_program.
  intros nu HQ.
  destruct HQ as (HQ & (s1 & s2 & Hconcat & Hs1 & Hs2)).
  { exists s1, s2.
    assert (under_pre1 s1 s2).
    { intros u. repeat (split; auto). eapply duplist_after_split_shared_same_elem; auto. destruct HQ as (v & HQ). exists v. rewrite Hconcat in HQ. auto. }
    split; subst; auto.
    induction s1.
    + unfold under_pre1 in H0. destruct (H0 0) as (_ & _ & (v & H & _ )). inversion H.
    + eapply eval_app_fun with (x := S2)
                               (t1 := (trm_cons a
                                                (val_fix CONCAT S1 (trm_match_list S1 (val_fun S2 S2)
                                                                                (H, T, trm_val (val_fun S2 (trm_cons H (CONCAT T S2)))))
                                                       (val_listnat s1) S2))); simpl; eauto.
  - eapply eval_app_fix with (x := S1); simpl; eauto.
    eapply eval_match_list; simpl; eauto.
      eapply eval_let; simpl; auto.
      eapply eval_let; simpl; auto.
  - eapply eval_cons. simpl; eauto.
    assert ((exists dup, order (s1 ++ s2) dup dup = true) \/ (forall dup, order (s1 ++ s2) dup dup = false)). admit.
    assert ((mem (s1 ++ s2) a) = true \/ (mem (s1 ++ s2) a) = false). admit.
    destruct H1, H2.
    { apply IHs1; auto. admit. admit. }
    { admit. }
    { apply concat_under0 in H2.

    { assert ((exists dup, order (s1 ++ s2) dup dup = true) \/ (forall dup, order (s1 ++ s2) dup dup = false)). admit.
      destruct H1.
      + apply IHs1; auto. admit. admit.
      + apply concat_under0 in H1.
    assert ((exists dup, order (s1 ++ s2) dup dup = true) \/ (forall dup, order (s1 ++ s2) dup dup = false)). admit.
    destruct H1.
    { apply IHs1; auto. admit. admit. }
    { assert (under_post0 (s1++s2)). auto.
      apply concat_under0 in H2.

          destruct (mem (s1 ++ s2) a).
    apply IHs1; auto. admit. admit.
    destruct (mem (s1 ++ s2) a).

    fold concat_program.
    apply concat_example0.
      { inversion Hs1.
      induction s1.
    - simpl; auto.

  induction s1.
  { simpl in Hconcat. subst. destruct HQ as (x & HQ). rewrite (Hs2 x) in HQ. inversion HQ. }
  { destruct nu. inversion Hconcat.
    inversion Hconcat; subst.
    exists s1, s2.
    assert (under_pre1 s1 s2).
    { intros u. repeat (split; auto). admit. eapply duplist_after_split_shared_same_elem; auto. destruct HQ as (v & HQ). exists v. rewrite Hconcat in HQ. auto. admit. admit. }
    split; subst; auto.
    destruct s1.
    + unfold under_pre1 in H0. destruct (H0 0) as (_ & _ & (v & H & _ )). inversion H.
    + eapply eval_app_fun with (x := S2)
                               (t1 := (trm_cons a
                                                (val_fix CONCAT S1 (trm_match_list S1 (val_fun S2 S2)
                                                                                (H, T, trm_val (val_fun S2 (trm_cons H (CONCAT T S2)))))
                                                         (val_listnat s1) S2))); simpl; eauto.
    - eapply eval_app_fix with (x := S1); simpl; eauto.
      eapply eval_match_list; simpl; eauto.
      eapply eval_let; simpl; auto.
      eapply eval_let; simpl; auto.
    - simpl. inversion Hconcat; subst.
      eapply eval_cons. simpl; eauto.

  }

  induction nu.
  destruct nu. inversion HQ. inversion H0.
  assert ((exists dup, order nu dup dup = true) \/ (forall dup, order nu dup dup = false)). admit.
  { exists s1, s2.
    assert (under_pre1 s1 s2).
    { intros u. repeat (split; auto). eapply duplist_after_split_shared_same_elem; auto. destruct HQ as (v & HQ). exists v. rewrite Hconcat in HQ. auto. }
    split; subst; auto.
    induction s1.
  + unfold under_pre1 in H1. destruct (H1 0) as (_ & _ & (v & H & _ )). inversion H.
  + eapply eval_app_fun with (x := S2)
                             (t1 := (trm_cons a
                                              (val_fix CONCAT S1 (trm_match_list S1 (val_fun S2 S2)
                                                                                (H, T, trm_val (val_fun S2 (trm_cons H (CONCAT T S2)))))
                                                       (val_listnat s1) S2))); simpl; eauto.
  - eapply eval_app_fix with (x := S1); simpl; eauto.
    eapply eval_match_list; simpl; eauto.
      eapply eval_let; simpl; auto.
      eapply eval_let; simpl; auto.
  - simpl. inversion Hconcat; subst.
    eapply eval_cons. simpl; eauto.
    apply IHs1; auto.
    assert ((exists dup, order (s1 ++ s2) dup dup = true) \/ (forall dup, order (s1 ++ s2) dup dup = false)). admit.
    destruct H1.
    { apply IHs1; auto. admit. admit. }
    { assert (under_post0 (s1++s2)). auto.
      apply concat_under0 in H2.

    fold concat_program.
    apply concat_example0.
      { inversion Hs1.
      induction s1.
    - simpl; auto.
Qed.

Definition type_safe (c: trm) (tp: val -> Prop) := forall v, tp v -> eval c v.

Inductive under_type: Type :=
| ut_spec: forall (P: Prop) (Q: Prop)

Bind Scope lexp_scope with lexp.
Infix ":::" := Cons (at level 50, left associativity) : lexp_scope.
Bind Scope bexp_scope with bexp.
Infix "<" := BLt : bexp_scope.
Infix "=" := BEq : bexp_scope.
Infix "&&" := BAnd : bexp_scope.
Notation "'!' b" := (BNot b) (at level 60) : bexp_scope.

Notation "{ a --> x }" :=
  (update empty a x) (at level 0).
Notation "{ a --> x ; b --> y }" :=
  (update ({ a --> x }) b y) (at level 0).
Notation "{ a --> x ; b --> y ; c --> z }" :=
  (update ({ a --> x ; b --> y }) c z) (at level 0).
Notation "{ a --> x ; b --> y ; c --> z ; d --> t }" :=
  (update ({ a --> x ; b --> y ; c --> z }) d t) (at level 0).
Notation "{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }" :=
  (update ({ a --> x ; b --> y ; c --> z ; d --> t }) e u) (at level 0).
Notation "{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }" :=
  (update ({ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }) f v) (at level 0).

Inductive under_spec (pre: list nat -> list nat -> list nat -> Prop) (post: list nat -> Prop) : Prop :=
  | U_spec : (forall nu, post nu -> exists s1 s2, pre s1 s2 nu) -> under_spec pre post.

Inductive com : Type :=
| CSkip : com
| CAssN : string -> nexp -> com
| CAssL : string -> lexp -> com
| CSeq : com -> com -> com
| CIf : bexp -> com -> com -> com
| CAssApply: string -> com -> string -> string -> com
| CSpec : ((list nat) -> (list nat) -> (list nat) -> Type) -> ((list nat) -> Type) -> com
| CSelf : com
| CFix : com -> com.

Bind Scope com_scope with com.
Notation "'SKIP'" :=
  CSkip : com_scope.
Notation "'SELF'" :=
  CSelf : com_scope.
Notation "x 'N=' a" :=
  (CAssN x a) (at level 60) : com_scope.
Notation "x 'L=' a" :=
  (CAssL x a) (at level 60) : com_scope.
Notation "c1 '<>=' f '<' c2  c3 '>' " :=
  (CAssApply c1 f c2 c3) (at level 80, right associativity) : com_scope.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity) : com_scope.
Notation "'Fix' b '=>=' c " :=
  (CFix b c) (at level 80, right associativity) : com_scope.
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity) : com_scope.

Reserved Notation "c1 '/' st '\\' st'"
         (at level 40, st at level 39).

Definition frame_within_vars (st st': state) vars : Prop := same_within (fst st) (fst st') vars.
Definition frame_beside_vars (st st': state) vars : Prop := same_besides (fst st) (fst st') vars.

Definition has_value_n (st: state) x v := snd st x = v.

Definition has_value_l (st: state)  x v := fst st x = v.

Fixpoint subst_self (self body: com) :=
  match body with
  | CSkip | CAssN _ _ | CAssL _ _ | CSpec _ _ => body
  | CSeq e1 e2 => CSeq (subst_self self e1) (subst_self self e2)
  | CIf b e1 e2 => CIf b (subst_self self e1) (subst_self self e2)
  | CAssApply ret e arg1 arg2 => CAssApply ret (subst_self self e) arg1 arg2
  | CSelf => self
  | CFix body => CFix (subst_self self body)
  end.

Inductive ceval : com -> state -> state -> Prop :=
| E_Skip : forall st, SKIP / st \\ st
| E_Spec : forall pre post s1 s2 nu,
    under_spec pre post ->
    post nu ->
    pre s1 s2 nu ->
    (CSpec pre post) / ({S1 --> s1 ; S2 --> s2}, empty) \\ ({S1 --> s1 ; S2 --> s2 ; NU --> nu}, empty)
| E_AssN  : forall st a1 n x,
    neval st a1 = n ->
    (x N= a1) / st \\ (update_n st x n)
| E_AssL  : forall st a1 n x,
    leval st a1 = n ->
    (x L= a1) / st \\ (update_l st x n)
| E_AssApply :
  forall ret arg1 arg2 s1 s2 nu c cst cst' st,
    c / cst \\ cst' ->
    fst cst S1 = Some s1 ->
    fst cst S2 = Some s2 ->
    fst cst' NU = Some nu ->
    fst st arg1 = Some s1 ->
    fst st arg2 = Some s2 ->
    fst st ret = None ->
    (CAssApply ret c arg1 arg2) / st \\ (update_l st ret (Some nu))
| E_Seq : forall c1 c2 st st' st'',
    c1 / st  \\ st' ->
    c2 / st' \\ st'' ->
    (c1 ;; c2) / st \\ st''
| E_IfTrue : forall st st' b c1 c2,
    beval st b = Some true ->
    c1 / st \\ st' ->
    (IFB b THEN c1 ELSE c2 FI) / st \\ st'
| E_IfFalse : forall st st' b c1 c2,
    beval st b = Some false ->
    c2 / st \\ st' ->
    (IFB b THEN c1 ELSE c2 FI) / st \\ st'
| E_Fix : forall c st st',
    subst_self (CFix c) c / st \\ st' ->
    (CFix c) / st \\ st'

where " c1 '/' st '\\' st'" := (ceval c1 st st').

Definition has_under_spec (pre: list nat -> list nat -> list nat -> Prop) (post: list nat -> Prop) (c: com) :=
  forall nu, post nu ->
        (exists s1 s2 st',
            pre s1 s2 nu /\
              c / ({S1 --> s1 ; S2 --> s2}, empty) \\
                (update_l (update_l (update_l st' S1 (Some s1)) S2 (Some s2)) NU (Some nu))
        ).

Lemma update_l_dup (st: state) (x: string) v:
  fst st x = v -> update_l st x v = st.
Proof. Admitted.

Lemma spec_has_spec (pre: list nat -> list nat -> list nat -> Prop) (post: list nat -> Prop) :
  under_spec pre post ->
  has_under_spec pre post (CSpec pre post).
Proof.
  unfold has_under_spec.
  intros HSpec nu HPost.
  inversion HSpec.
  assert (post nu) as HSpec'; auto.
  apply H0 in HPost.
  destruct HPost as (s1 & s2 & HPre).
  exists s1, s2, ({S1 --> s1 ; S2 --> s2}, empty).
  split; auto.
  assert (update_l (update_l ({S1 --> s1; S2 --> s2}, empty) S1 (Some s1)) S2 (Some s2) =
         ({S1 --> s1 ; S2 --> s2}, empty)).
  repeat (rewrite update_l_dup; auto).
  rewrite H1.
  assert (update_l ({S1 --> s1; S2 --> s2}, empty) NU (Some nu) = ({S1 --> s1; S2 --> s2; NU --> nu}, empty)).
  unfold update_l. simpl. auto.
  apply E_Spec; auto.
Qed.

Definition concat_program :=
  (CFix (IFB Bemp S1
             THEN (NU L= Lid S2)
             ELSE (H N= (Hd (Lid S1));; T L= (Tail (Lid S1));; (CAssApply S3 SELF T S2);; (NU L= Cons (Nid H) (Lid S3)))
         FI)).

Lemma concat_example0 :
  concat_program / ({S1 --> [] ; S2 --> [1;3]}, empty) \\
                 ({S1 --> [] ; S2 --> [1;3]; NU --> [1;3]}, empty).
Proof.
  unfold concat_program.
  intros.
  apply E_Fix. simpl.
  apply E_IfTrue; auto.
  apply E_AssL. simpl. auto.
Qed.

Lemma concat_example1 :
  concat_program / ({S1 --> [2] ; S2 --> [1;3]}, empty) \\
                 ({S1 --> [2] ; S2 --> [1;3]; T --> []; S3 --> [1;3] ; NU --> [2;1;3]}, {H --> 2}).
Proof.
  unfold concat_program.
  intros.
  apply E_Fix. simpl.
  apply E_IfFalse; auto.
  eapply E_Seq. apply E_AssN. simpl. auto.
  eapply E_Seq. apply E_AssL. simpl. auto.
  fold concat_program.
  eapply E_Seq; auto.
  - eapply E_AssApply with (s1 := []) (s2 := [1;3]) (nu := [1;3]); eauto. apply concat_example0.
    auto.
    auto.
    auto.
  - apply E_AssL. simpl. auto.
Qed.

Fixpoint mem (l : list nat) (x: nat) :=
  match l with
  | nil => false
  | cons h t => (if Nat.eqb h x then true else mem t x)
  end.

Fixpoint dup (l : list nat) :=
  match l with
  | nil => false
  | cons h t =>
      if mem t h then true else dup t
  end.

Fixpoint twice (l : list nat) (x: nat) :=
  match l with
  | nil => false
  | cons h t => (if Nat.eqb h x then mem t x else twice t x)
  end.

Fixpoint splitable_aux (l r : list nat) :=
  match r with
  | nil => false
  | cons h t =>
      if mem l h then false
      else
        if dup t then splitable_aux (h::l) t
        else true
  end.

Definition splitable (l: list nat) := splitable_aux nil l.

Lemma splitable_can_be_split (l: list nat) :
  splitable l = true <-> exists l1 l2, l1 ++ l2 = l /\ dup l1 = false /\ dup l2 = false.
Proof. Admitted.

Fixpoint dup3 (l : list nat) :=
  match l with
  | nil => false
  | cons h t =>
      if twice t h then true else dup3 t
  end.

Definition concat_post1 := fun (nu: list nat) => dup nu = false.
Definition concat_pre1 := fun (s1 s2 nu: list nat) =>
                             (dup s1 = false) /\ (dup s2 = false) /\
                               (forall x, ~ (mem s1 x = true /\ mem s2 x = true)).

Definition concat_spec1 : under_spec concat_pre1 concat_post1.
Proof.
  unfold concat_pre1, concat_post1.
  apply U_spec.
  intros nu HPost.
  exists nil, nu. repeat (split; auto).
  intros x. intro H. destruct H as [H _]. inversion H.
Qed.

Lemma concat_program_s1_empty: forall s2,
    concat_program / ({S1 --> nil; S2 --> s2}, empty) \\ ({S1 --> nil; S2 --> s2; NU --> s2}, empty).
Proof.
  intros nu.
  unfold concat_program.
  intros.
  apply E_Fix. simpl.
  apply E_IfTrue; auto.
  apply E_AssL. simpl. auto.
Qed.

Lemma concat_program_has_concat_spec1 :
  has_under_spec concat_pre1 concat_post1 concat_program.
Proof.
  unfold has_under_spec, concat_pre1, concat_post1.
  intros nu HPost.
  exists nil, nu, ({S1 --> nil ; S2 --> nu; NU --> nu}, empty). repeat (split; auto).
  intros x. intro H. destruct H as [H _]. inversion H.
  repeat (rewrite update_l_dup; auto).
  apply concat_program_s1_empty.
Qed.

Definition concat_post2 := fun (nu: list nat) => (dup nu = true) /\ (splitable nu = true).
Definition concat_pre2 := fun (s1 s2 nu: list nat) =>
                             (dup s1 = false) /\ (dup s2 = false) /\
                               (exists x, mem s1 x = true /\ mem s2 x = true).

Lemma list_destruct (l : list nat) : l = nil \/ exists h t, l = h :: t.
Proof. Admitted.

Lemma concat_program_has_concat_spec2 :
  has_under_spec concat_pre2 concat_post2 concat_program.
Proof.
  unfold has_under_spec, concat_pre2, concat_post2.
  intros nu HPost.
  destruct (list_destruct nu); subst.
  + destruct HPost as (Hdup & _). inversion Hdup.
  + destruct H0 as (h & s3 & H); subst.
    destruct HPost as (Hdup & Hsplit).
    rewrite splitable_can_be_split in Hsplit.
    destruct Hsplit as (s1 & s2 & HK & Hs1 & Hs2).
    assert (exists t, s1 = h :: t /\ t ++ s2 = s3). admit.
    destruct H0 as (t & H0 & H1). subst.
    exists (h :: t), s2, ({S1 --> (h :: t) ; S2 --> s2; T --> t; S3 --> (t ++ s2); NU --> (h :: (t ++ s2))}, { H --> h }).
    repeat (split; auto).
    - admit.
    - repeat (rewrite update_l_dup; auto).
      generalize dependent h.
      generalize dependent t.
      induction t.
      {
        intros h.
        unfold concat_program.
        intros.
        apply E_Fix. simpl.
        apply E_IfFalse; auto.
        eapply E_Seq. apply E_AssN. simpl. auto.
        eapply E_Seq. apply E_AssL. simpl. auto.
        eapply E_Seq; auto.
        apply E_AssApply with (s1 := nil) (s2 := s2) (nu := s2)
                              (cst := ({S1 --> nil; S2 --> s2}, empty)) (cst' := ({S1 --> nil; S2 --> s2; NU --> s2}, empty)); auto.
        apply concat_program_s1_empty.
        apply E_AssL. simpl. auto.
        }
      {
        intros h.
        unfold concat_program.
        intros.
        apply E_Fix. simpl.
        apply E_IfFalse; auto.
        eapply E_Seq. apply E_AssN. simpl. auto.
        eapply E_Seq. apply E_AssL. simpl. auto.
        eapply E_Seq; auto.
        apply E_AssApply with (s1 := (a :: t)) (s2 := s2) (nu := (a :: t) ++ s2)
                              (cst := ({S1 --> (a :: t); S2 --> s2}, empty))
                              (cst' := ({S1 --> (a :: t); S2 --> s2; T --> t; S3 --> (t ++ s2); NU --> (a :: t) ++ s2}, {H --> a})); auto.
        apply (IHt a); auto.
        - admit.
        - admit.
        - apply E_AssL. simpl. auto.
      }
Admitted.


Require Import Coq.Wellfounded.Inverse_Image.
Require Import MyTactics.
Require Export Autosubst.Autosubst.
Require Export AutosubstExtra.
Require Export Autosubst_IsRen.

Require Import Arith.
Require Import PeanoNat.
(* Require Export Autosubst_EOS. *)

Require Import Arith.Wf_nat.
Require Export Autosubst_FreeVars.

(* The syntax of the lambda-calculus. *)

Inductive term :=
| Var (x : var)
| Lam (t : {bind term})
| App (t1 t2 : term)
| Let (t1 : term) (t2 : {bind term})
| Match (tc t1: term) (t2 : {bind term})
| VariantNone
| VariantSome (t: term)
.

Instance Ids_term : Ids term. derive. Defined.
Instance Rename_term : Rename term. derive. Defined.
Instance Subst_term : Subst term. derive. Defined.
Instance SubstLemmas_term : SubstLemmas term. derive. Qed.

Instance IdsLemmas_term : IdsLemmas term.
Proof. econstructor. intros. injections. eauto. Qed.

(* If the image of [t] through a substitution is a variable, then [t] must
   itself be a variable. *)

Lemma subst_is_var:
  forall t sigma x,
  t.[sigma] = ids x ->
  exists y,
  t = ids y.
Proof.
  intros ? ? ? Heq. destruct t; compute in Heq; solve [ eauto | congruence ].
Qed.

(* The identity substitution [ids] is injective. *)

Lemma inj_ids:
  forall x y,
  ids x = ids y ->
  x = y.
Proof.
  intros ? ? Heq. compute in Heq. congruence.
Qed.

(* If the composition of two substitutions [sigma1] and [sigma2] is the
   identity substitution, then [sigma1] must be a renaming. *)

Lemma ids_implies_is_ren:
  forall sigma1 sigma2,
  sigma1 >> sigma2 = ids ->
  is_ren sigma1.
Proof.
  intros ? ? Hid.
  eapply prove_is_ren; [ eapply inj_ids | intros x ].
  eapply subst_is_var with (sigma := sigma2) (x := x).
  rewrite <- Hid. reflexivity.
Qed.

Global Hint Resolve ids_implies_is_ren : is_ren obvious.

(* The size of a term. *)

Fixpoint size (t : term) : nat :=
  match t with
  | Var _ => 0
  | Lam t => 1 + size t
  | App t1 t2
  | Let t1 t2 => 1 + size t1 + size t2
  | Match tc t1 t2 =>
    1 + size tc + size t1 + size t2
  | VariantNone => 0
  | VariantSome t => 1 + size t
  end.

(* The size of a term is preserved by renaming. *)

Lemma size_renaming:
  forall t sigma,
  is_ren sigma ->
  size t.[sigma] = size t.
Proof.
  induction t; intros sigma Hsigma; asimpl;
  repeat (match goal with h: forall sigma, _ |- _ => rewrite h by obvious; clear h end);
  try reflexivity.
  (* [Var] *)
  { destruct Hsigma as [ xi ? ]. subst. reflexivity. }
Qed.

(* The [size] function imposes a well-founded ordering on terms. *)

Lemma smaller_wf:
  well_founded (fun t1 t2 => size t1 < size t2).
Proof.
  eauto using wf_inverse_image, lt_wf.
Qed.

(* The tactic [size_induction] facilitates proofs by induction on the
   size of a term. The following lemmas are used in the construction
   of this tactic. *)

Lemma size_induction_intro:
  forall (P : term -> Prop),
  (forall n t, size t < n -> P t) ->
  (forall t, P t).
Proof.
  eauto. (* just instantiate [n] with [size t + 1] *)
Defined.

Lemma size_induction_induction:
  forall (P : term -> Prop),
  (forall n, (forall t, size t < n -> P t) -> (forall t, size t < S n -> P t)) ->
  (forall n t, size t < n -> P t).
Proof.
  intros P IH. induction n; intros.
  { false. eapply Nat.nlt_0_r. eauto. }
  { eauto. }
Defined.

Lemma size_induction:
  forall (P : term -> Prop),
  (forall n, (forall t, size t < n -> P t) -> (forall t, size t < S n -> P t)) ->
  (forall t, P t).
Proof.
  intros P IH.
  eapply size_induction_intro.
  eapply size_induction_induction.
  eauto.
Defined.

Ltac size_induction t :=
  (* We assume the goal is of the form [forall t, P t]. *)
  intro t; pattern t;
  match goal with |- ?P t =>
    simpl; eapply (@size_induction P); clear
  end;
  intros n IH t Htn.
  (* The goal should now be of the form [P t]
     with a hypothesis [IH: (forall t, size t < n -> P t]
     and a hypothesis [Htn: size t < S n]. *)

(* The tactic [size] proves goals of the form [size t < n]. The tactic
   [obvious] is also extended to prove such goals. *)

Global Hint Extern 1 (size ?t.[?sigma] < ?n) =>
  rewrite size_renaming by obvious
  : size obvious.

Global Hint Extern 1 (size ?t < ?n) =>
  simpl in *; lia
  : size obvious.

Ltac size :=
  eauto with size.

(* The following is a direct proof of [smaller_wf]. We do not use any
   preexisting lemmas, and end the proof with [Defined] instead of [Qed],
   so as to make the proof term transparent. Also, we avoid the tactic
   [lia], which produces huge proof terms. This allows Coq to compute
   with functions that are defined by well-founded recursion. *)

Lemma smaller_wf_transparent:
  well_founded (fun t1 t2 => size t1 < size t2).
Proof.
  unfold well_founded. size_induction t.
  constructor; intros u Hu.
  eapply IH. eauto with arith.
Defined.

(* The following lemmas can be useful in situations where the tactic
   [asimpl] performs too much simplification. *)

Lemma subst_var:
  forall x sigma,
  (Var x).[sigma] = sigma x.
Proof.
  autosubst.
Qed.

Lemma subst_lam:
  forall t sigma,
  (Lam t).[sigma] = Lam (t.[up sigma]).
Proof.
  autosubst.
Qed.

Lemma subst_app:
  forall t1 t2 sigma,
  (App t1 t2).[sigma] = App t1.[sigma] t2.[sigma].
Proof.
  autosubst.
Qed.

Lemma subst_let:
  forall t1 t2 sigma,
  (Let t1 t2).[sigma] = Let t1.[sigma] t2.[up sigma].
Proof.
  autosubst.
Qed.

Lemma subst_variant_none:
  forall sigma,
  VariantNone.[sigma] = VariantNone.
Proof.
  autosubst.
Qed.

Lemma subst_variant_some:
  forall t1 sigma,
  (VariantSome t1).[sigma] = VariantSome t1.[sigma].
Proof.
  autosubst.
Qed.

Lemma subst_match:
  forall tb t1 t2 sigma,
  (Match tb t1 t2).[sigma] = Match tb.[sigma] t1.[sigma] t2.[up sigma].
Proof.
  autosubst.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.MinMax.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Append.

Axiom char : Type.
Parameter char_WhyType : WhyType char.
Existing Instance char_WhyType.

(* Why3 assumption *)
Definition word := (list char).

(* Why3 assumption *)
Inductive dist : (list char) -> (list char) -> Z -> Prop :=
  | dist_eps : (dist nil nil 0%Z)
  | dist_add_left : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
      w2 n) -> forall (a:char), (dist (cons a w1) w2 (n + 1%Z)%Z)
  | dist_add_right : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
      w2 n) -> forall (a:char), (dist w1 (cons a w2) (n + 1%Z)%Z)
  | dist_context : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
      w2 n) -> forall (a:char), (dist (cons a w1) (cons a w2) n).

(* Why3 assumption *)
Definition min_dist (w1:(list char)) (w2:(list char)) (n:Z): Prop := (dist w1
  w2 n) /\ forall (m:Z), (dist w1 w2 m) -> (n <= m)%Z.

(* Why3 assumption *)
Fixpoint last_char (a:char) (u:(list char)) {struct u}: char :=
  match u with
  | nil => a
  | (cons c u') => (last_char c u')
  end.

(* Why3 assumption *)
Fixpoint but_last (a:char) (u:(list char)) {struct u}: (list char) :=
  match u with
  | nil => nil
  | (cons c u') => (cons a (but_last c u'))
  end.

Axiom first_last_explicit : forall (u:(list char)) (a:char),
  ((List.app (but_last a u) (cons (last_char a u) nil)) = (cons a u)).

Axiom first_last : forall (a:char) (u:(list char)), exists v:(list char),
  exists b:char, ((List.app v (cons b nil)) = (cons a u)) /\
  ((list.Length.length v) = (list.Length.length u)).

Axiom key_lemma_right : forall (w1:(list char)) (w'2:(list char)) (m:Z)
  (a:char), (dist w1 w'2 m) -> forall (w2:(list char)),
  (w'2 = (cons a w2)) -> exists u1:(list char), exists v1:(list char),
  exists k:Z, (w1 = (List.app u1 v1)) /\ ((dist v1 w2 k) /\
  ((k + (list.Length.length u1))%Z <= (m + 1%Z)%Z)%Z).

Axiom dist_symetry : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
  w2 n) -> (dist w2 w1 n).

Axiom key_lemma_left : forall (w1:(list char)) (w2:(list char)) (m:Z)
  (a:char), (dist (cons a w1) w2 m) -> exists u2:(list char),
  exists v2:(list char), exists k:Z, (w2 = (List.app u2 v2)) /\ ((dist w1 v2
  k) /\ ((k + (list.Length.length u2))%Z <= (m + 1%Z)%Z)%Z).

Axiom dist_concat_left : forall (u:(list char)) (v:(list char))
  (w:(list char)) (n:Z), (dist v w n) -> (dist (List.app u v) w
  ((list.Length.length u) + n)%Z).

Axiom dist_concat_right : forall (u:(list char)) (v:(list char))
  (w:(list char)) (n:Z), (dist v w n) -> (dist v (List.app u w)
  ((list.Length.length u) + n)%Z).

(* Why3 goal *)
Theorem min_dist_equal : forall (w1:(list char)) (w2:(list char)) (a:char)
  (n:Z), (min_dist w1 w2 n) -> (min_dist (cons a w1) (cons a w2) n).
(* Why3 intros w1 w2 a n h1. *)
intros w1 w2 a n.
unfold min_dist.
generalize dist_context; intuition.

inversion H0.

elim (key_lemma_right w1 (cons a w2) n0 a H7 w2);
 [ idtac | reflexivity ].
intros u1 Hex; elim Hex; clear Hex.
intros v1 Hex; elim Hex; clear Hex.
intros k Hex.
 decompose [and] Hex; clear Hex.
generalize (dist_concat_left u1 v1 w2 k H10); intro.
apply Zle_trans with (Length.length u1 + k)%Z.
apply H2.
rewrite H8; assumption.
omega.
elim (key_lemma_left w1 w2 n0 a H7).
intros u2 Hex; elim Hex; clear Hex.
intros v2 Hex; elim Hex; clear Hex.
intros k Hex.
 decompose [and] Hex; clear Hex.
generalize (dist_concat_right u2 w1 v2 k H10); intro.
apply Zle_trans with (Length.length u2 + k)%Z.
apply H2.
rewrite H8; assumption.
omega.
auto.
Qed.