Require Export ZArith.
Require Export List.
Require Export Bool.

Require Export sflib.

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.

Inductive ty: Type :=
| TyUnit: ty
| TyBool: ty
| TyChar: ty
| TyInt: ty
| TyPair: ty -> ty -> ty
| TyList: ty -> ty
| TyArrow: ty -> ty -> ty
.

Hint Constructors ty.

Inductive isComparable: ty -> Prop :=
| IsCompUnit: isComparable TyUnit
| IsCompBool: isComparable TyBool
| IsCompChar: isComparable TyChar
| IsCompInt: isComparable TyInt
| IsCompPair: forall Tfst Tsnd,
    isComparable Tfst ->
    isComparable Tsnd ->
    isComparable (TyPair Tfst Tsnd)
| IsCompList: forall Telem,
    isComparable Telem ->
    isComparable (TyList Telem)
.

Hint Constructors isComparable.

Inductive id: Type :=
| Id: nat -> id
.

Hint Constructors id.

Lemma eq_id_dec: forall (i1 i2: id), {i1 = i2} + {i1 <> i2}.
Proof.
  intros i1 i2.
  destruct i1 as [n1]. destruct i2 as [n2].
  destruct (eq_nat_dec n1 n2).
  auto.
  right. intros contra. inversion contra. auto.
Qed.

Lemma eq_id: forall T i (t0 t1: T),
    (if eq_id_dec i i then t0 else t1) = t0.
Proof.
  intros.
  destruct (eq_id_dec i i).
  - reflexivity.
  - exfalso. eauto.
Qed.

Lemma neq_id : forall T i0 i1 (t0 t1:T),
    i0 <> i1 ->
    (if eq_id_dec i0 i1 then t0 else t1) = t1.
Proof.
  intros.
  destruct (eq_id_dec i0 i1).
  - exfalso. eauto.
  - reflexivity.
Qed.

Inductive tm: Type :=
(* Error/Undefined *)
| TmError: tm

(* Unit *)
| TmUnit: tm

(* Bool *)
| TmTrue: tm
| TmFalse: tm
| TmNeg: tm -> tm
| TmAnd: tm -> tm -> tm
| TmOr: tm -> tm -> tm
| TmIf: tm -> tm -> tm -> tm

(* Char *)
| TmChar: nat -> tm

(* Integer *)
| TmInt: Z -> tm

(* Pair *)
| TmPair: tm -> tm -> tm
| TmFst: tm -> tm
| TmSnd: tm -> tm

(* List *)
| TmNil: tm
| TmCons: tm -> tm -> tm
| TmHead: tm -> tm
| TmTail: tm -> tm

(* Function *)
| TmLam: id -> ty -> tm -> tm
| TmApp: tm -> tm -> tm

(* Equality *)
| TmEq: tm -> tm -> tm

(* Variable *)
| TmVar: id -> tm

(* Local binding *)
| TmLet: id -> tm -> tm -> tm

(* Fixpoint binding *)
| TmFix: tm -> tm
.

Hint Constructors tm.

Inductive val: tm -> Prop :=
| ValError: val TmError

| ValUnit: val TmUnit

| ValTrue: val TmTrue
| ValFalse: val TmFalse

| ValChar: forall c,
    val (TmChar c)

| ValInt: forall z,
    val (TmInt z)

| ValPair: forall tfst tsnd,
    val (TmPair tfst tsnd)

| ValNil: val TmNil
| ValCons: forall thead ttail,
    val (TmCons thead ttail)

| ValLam: forall ipar Tpar tres,
    val (TmLam ipar Tpar tres)
.

Hint Constructors val.

Reserved Notation "'[' x0 '<-' t0 ']' t1" (at level 20).

Fixpoint subst (i: id) (s: tm) (t: tm): tm :=
  match t with
  | TmNeg tneg =>
    TmNeg ([i <- s] tneg)
  | TmAnd tleft tright =>
    TmAnd ([i <- s] tleft) ([i <- s] tright)
  | TmOr tleft tright =>
    TmOr ([i <- s] tleft) ([i <- s] tright)
  | TmIf tcond ttrue tfalse =>
    TmIf ([i <- s] tcond) ([i <- s] ttrue) ([i <- s] tfalse)

  | TmPair tfst tsnd =>
    TmPair ([i <- s] tfst) ([i <- s] tsnd)
  | TmFst tpair =>
    TmFst ([i <- s] tpair)
  | TmSnd tpair =>
    TmSnd ([i <- s] tpair)

  | TmCons thead ttail =>
    TmCons ([i <- s] thead) ([i <- s] ttail)
  | TmHead tlist =>
    TmHead ([i <- s] tlist)
  | TmTail tlist =>
    TmTail ([i <- s] tlist)

  | TmLam ipar Tpar tres =>
    TmLam ipar Tpar (if eq_id_dec i ipar then tres else [i <- s] tres)
  | TmApp tlam tapp =>
    TmApp ([i <- s] tlam) ([i <- s] tapp)

  | TmEq tleft tright =>
    TmEq ([i <- s] tleft) ([i <- s] tright)

  | TmVar ivar =>
    if eq_id_dec i ivar then s else t

  | TmLet ilet tlet tin =>
    TmLet ilet
          ([i <- s] tlet)
          (if eq_id_dec i ilet then tin else [i <- s] tin)

  | TmFix tfix =>
    TmFix ([i <- s] tfix)

  | _ => t
  end

where "'[' x '<-' t0 ']' t1" := (subst x t0 t1)
.

Definition Relation (X: Type): Type := X -> X -> Prop.

Reserved Notation " t0 '==>' t1 " (at level 40).

Inductive smst: Relation tm :=
| SmstNegStep: forall tneg0 tneg1,
    tneg0 ==> tneg1 ->
    TmNeg tneg0 ==> TmNeg tneg1
| SmstNegTrue:
    TmNeg TmTrue ==> TmFalse
| SmstNegFalse:
    TmNeg TmFalse ==> TmTrue
| SmstNegError:
    TmNeg TmError ==> TmError
| SmstAndLeftStep: forall tleft0 tleft1 tright,
    tleft0 ==> tleft1 ->
    TmAnd tleft0 tright ==> TmAnd tleft1 tright
| SmstAndLeftFalse: forall tright,
    TmAnd TmFalse tright ==> TmFalse
| SmstAndLeftError: forall tright,
    TmAnd TmError tright ==> TmError
| SmstAndRightStep: forall tright0 tright1,
    tright0 ==> tright1 ->
    TmAnd TmTrue tright0 ==> TmAnd TmTrue tright1
| SmstAndRightFalse:
    TmAnd TmTrue TmFalse ==> TmFalse
| SmstAndRightError:
    TmAnd TmTrue TmError ==> TmError
| SmstAndTrue:
    TmAnd TmTrue TmTrue ==> TmTrue
| SmstOrLeftStep: forall tleft0 tleft1 tright,
    tleft0 ==> tleft1 ->
    TmOr tleft0 tright ==> TmOr tleft1 tright
| SmstOrLeftTrue: forall tright,
    TmOr TmTrue tright ==> TmTrue
| SmstOrLeftError: forall tright,
    TmOr TmError tright ==> TmError
| SmstOrRightStep: forall tright0 tright1,
    tright0 ==> tright1 ->
    TmOr TmFalse tright0 ==> TmOr TmFalse tright1
| SmstOrRightTrue:
    TmOr TmFalse TmTrue ==> TmTrue
| SmstOrRightError:
    TmOr TmFalse TmError ==> TmError
| SmstOrFalse:
    TmOr TmFalse TmFalse ==> TmFalse
| SmstIfStep: forall tcond0 tcond1 ttrue tfalse,
    tcond0 ==> tcond1 ->
    TmIf tcond0 ttrue tfalse ==> TmIf tcond1 ttrue tfalse
| SmstIfTrue: forall ttrue tfalse,
    TmIf TmTrue ttrue tfalse ==> ttrue
| SmstIfFalse: forall ttrue tfalse,
    TmIf TmFalse ttrue tfalse ==> tfalse
| SmstIfError: forall ttrue tfalse,
    TmIf TmError ttrue tfalse ==> TmError

| SmstFstStep: forall tpair0 tpair1,
    tpair0 ==> tpair1 ->
    TmFst tpair0 ==> TmFst tpair1
| SmstFstPair: forall tfst tsnd,
    TmFst (TmPair tfst tsnd) ==> tfst
| SmstFstError:
    TmFst TmError ==> TmError
| SmstSndStep: forall tpair0 tpair1,
    tpair0 ==> tpair1 ->
    TmSnd tpair0 ==> TmSnd tpair1
| SmstSndPair: forall tfst tsnd,
    TmSnd (TmPair tfst tsnd) ==> tsnd
| SmstSndError:
    TmSnd TmError ==> TmError

| SmstHeadStep: forall tlist0 tlist1,
    tlist0 ==> tlist1 ->
    TmHead tlist0 ==> TmHead tlist1
| SmstHeadNil:
    TmHead TmNil ==> TmError
| SmstHeadCons: forall thead ttail,
    TmHead (TmCons thead ttail) ==> thead
| SmstHeadError:
    TmHead TmError ==> TmError
| SmstTailStep: forall tlist0 tlist1,
    tlist0 ==> tlist1 ->
    TmTail tlist0 ==> TmTail tlist1
| SmstTailNil:
    TmTail TmNil ==> TmError
| SmstTailCons: forall thead ttail,
    TmTail (TmCons thead ttail) ==> ttail
| SmstTailError:
    TmTail TmError ==> TmError

| SmstAppStep: forall tlam0 tlam1 tapp,
    tlam0 ==> tlam1 ->
    TmApp tlam0 tapp ==> TmApp tlam1 tapp
| SmstAppLam: forall ipar Tpar tres tapp,
    TmApp (TmLam ipar Tpar tres) tapp ==> [ipar <- tapp] tres
| SmstAppError: forall tapp,
    TmApp TmError tapp ==> TmError

| SmstEqLeftStep: forall tleft0 tleft1 tright,
    tleft0 ==> tleft1 ->
    TmEq tleft0 tright ==> TmEq tleft1 tright
| SmstEqLeftError: forall tright,
    TmEq TmError tright ==> TmError
| SmstEqRightStep: forall vleft tright0 tright1,
    val vleft ->
    vleft <> TmError ->
    tright0 ==> tright1 ->
    TmEq vleft tright0 ==> TmEq vleft tright1
| SmstEqRightError: forall vleft,
    val vleft ->
    vleft <> TmError ->
    TmEq vleft TmError ==> TmError
| SmstEqUnitTrue:
    TmEq TmUnit TmUnit ==> TmTrue
| SmstEqBoolTrue0:
    TmEq TmTrue TmTrue ==> TmTrue
| SmstEqBoolTrue1:
    TmEq TmFalse TmFalse ==> TmTrue
| SmstEqBoolFalse0:
    TmEq TmTrue TmFalse ==> TmFalse
| SmstEqBoolFalse1:
    TmEq TmFalse TmTrue ==> TmFalse
| SmstEqCharTrue: forall c0 c1,
    c0 = c1 ->
    TmEq (TmChar c0) (TmChar c1) ==> TmTrue
| SmstEqCharFalse: forall c0 c1,
    c0 <> c1 ->
    TmEq (TmChar c0) (TmChar c1) ==> TmFalse
| SmstEqIntTrue: forall z0 z1,
    z0 = z1 ->
    TmEq (TmInt z0) (TmInt z1) ==> TmTrue
| SmstEqIntFalse: forall z0 z1,
    z0 <> z1 ->
    TmEq (TmInt z0) (TmInt z1) ==> TmFalse
| SmstEqPair: forall tfst0 tsnd0 tfst1 tsnd1,
    TmEq (TmPair tfst0 tsnd0) (TmPair tfst1 tsnd1) ==>
    TmAnd (TmEq tfst0 tfst1) (TmEq tsnd0 tsnd1)
| SmstEqListNilTrue:
    TmEq TmNil TmNil ==> TmTrue
| SmstEqListFalse0: forall thead1 ttail1,
    TmEq TmNil (TmCons thead1 ttail1) ==> TmFalse
| SmstEqListFalse1: forall thead0 ttail0,
    TmEq (TmCons thead0 ttail0) TmNil ==> TmFalse
| SmstEqListCons: forall thead0 ttail0 thead1 ttail1,
    TmEq (TmCons thead0 ttail0) (TmCons thead1 ttail1) ==>
    TmAnd (TmEq thead0 thead1) (TmEq ttail0 ttail1)

| SmstLet: forall ilet tlet tin,
    TmLet ilet tlet tin ==> [ilet <- tlet] tin

| SmstFixStep: forall tfix0 tfix1,
    tfix0 ==> tfix1 ->
    TmFix tfix0 ==> TmFix tfix1
| SmstFixLam: forall ilam Tlam tlam,
    TmFix (TmLam ilam Tlam tlam) ==> [ilam <- TmFix (TmLam ilam Tlam tlam)] tlam
| SmstFixError:
    TmFix TmError ==> TmError

where "t0 '==>' t1" := (smst t0 t1)
.

Hint Constructors smst.

Inductive mlt {T: Type} (R: Relation T) : Relation T :=
  | mltRefl  : forall (t: T), mlt R t t
  | mltStep : forall (t0 t1 t2 : T),
                    R t0 t1 ->
                    mlt R t1 t2 ->
                    mlt R t0 t2.

Hint Constructors mlt.

Theorem mltLift: forall (T: Type) (R: Relation T) (t0 t1: T),
    R t0 t1 ->
    mlt R t0 t1.
Proof.
  intros T R t0 t1 smst.
  eauto.
Qed.

Theorem mltTrans: forall (T: Type) (R: Relation T) (t0 t1 t2: T),
    mlt R t0 t1 ->
    mlt R t1 t2 ->
    mlt R t0 t2.
Proof.
  intros T R t0 t1 t2 mlt0 mlt1.
  induction mlt0 as [t0|t0 t1].
  - auto.
  - eauto.
Qed.

Definition idPartialMap (K: Type): Type := id -> option K.

Definition emptyMap {K: Type}: idPartialMap K := fun _ => None.
Definition extend {K: Type} (G: idPartialMap K) (i0: id) (T0: K):
  idPartialMap K :=
  fun i1 => if eq_id_dec i0 i1 then Some T0 else G i1.

Hint Unfold emptyMap.
Hint Unfold extend.

Lemma extend_eq: forall K (G: idPartialMap K) i T,
    (extend G i T) i = Some T.
Proof.
  intros.
  unfold extend. rewrite eq_id. reflexivity.
Qed.

Lemma extend_neq: forall K (G: idPartialMap K) i0 i1 T,
    i0 <> i1 ->
    (extend G i0 T) i1 = G i1.
Proof.
  intros.
  unfold extend. rewrite neq_id; auto.
Qed.

Definition tyCtxt: Type := idPartialMap ty.

Reserved Notation "TC '|-' t ':|' T" (at level 40).

Inductive hasTy: tyCtxt -> tm -> ty -> Prop :=
| HasTyError: forall TC T,
    TC |- TmError :| T

| HasTyUnit: forall TC,
    TC |- TmUnit :| TyUnit

| HasTyTrue: forall TC,
    TC |- TmTrue :| TyBool
| HasTyFalse: forall TC,
    TC |- TmFalse :| TyBool
| HasTyNeg: forall TC tneg,
    TC |- tneg :| TyBool ->
    TC |- TmNeg tneg :| TyBool
| HasTyAnd: forall TC tleft tright,
    TC |- tleft :| TyBool ->
    TC |- tright :| TyBool ->
    TC |- TmAnd tleft tright :| TyBool
| HasTyOr: forall TC tleft tright,
    TC |- tleft :| TyBool ->
    TC |- tright :| TyBool ->
    TC |- TmOr tleft tright :| TyBool
| HasTyIf: forall TC tcond ttrue tfalse Tif,
    TC |- tcond :| TyBool ->
    TC |- ttrue :| Tif ->
    TC |- tfalse :| Tif ->
    TC |- TmIf tcond ttrue tfalse :| Tif

| HasTyChar: forall TC c,
    TC |- TmChar c :| TyChar

| HasTyInt: forall TC z,
    TC |- TmInt z :| TyInt

| HasTyPair: forall TC tfst Tfst tsnd Tsnd,
    TC |- tfst :| Tfst ->
    TC |- tsnd :| Tsnd ->
    TC |- TmPair tfst tsnd :| TyPair Tfst Tsnd
| HasTyFst: forall TC tpair Tfst Tsnd,
    TC |- tpair :| TyPair Tfst Tsnd ->
    TC |- TmFst tpair :| Tfst
| HasTySnd: forall TC tpair Tfst Tsnd,
    TC |- tpair :| TyPair Tfst Tsnd ->
    TC |- TmSnd tpair :| Tsnd

| HasTyNil: forall TC Telem,
    TC |- TmNil :| TyList Telem
| HasTyCons: forall TC thead ttail Telem,
    TC |- thead :| Telem ->
    TC |- ttail :| TyList Telem ->
    TC |- TmCons thead ttail :| TyList Telem
| HasTyHead: forall TC tlist Telem,
    TC |- tlist :| TyList Telem ->
    TC |- TmHead tlist :| Telem
| HasTyTail: forall TC tlist Telem,
    TC |- tlist :| TyList Telem ->
    TC |- TmTail tlist :| TyList Telem

| HasTyLam: forall TC ipar Tpar tres Tres,
    (extend TC ipar Tpar) |- tres :| Tres ->
    TC |- TmLam ipar Tpar tres :| TyArrow Tpar Tres
| HasTyApp: forall TC tlam Tres tapp Tapp,
    TC |- tlam :| TyArrow Tapp Tres ->
    TC |- tapp :| Tapp ->
    TC |- TmApp tlam tapp :| Tres

| HasTyEq: forall TC tleft tright Teq,
    TC |- tleft :| Teq ->
    TC |- tright :| Teq ->
    isComparable Teq ->
    TC |- TmEq tleft tright :| TyBool

| HasTyVar: forall TC i Tvar,
    TC i = Some Tvar ->
    TC |- TmVar i :| Tvar

| HasTyLet: forall TC ilet tlet Tlet tin Tin,
    TC |- tlet :| Tlet ->
    (extend TC ilet Tlet) |- tin :| Tin ->
    TC |- TmLet ilet tlet tin :| Tin
| HasTyFix: forall TC tfix Tfix ,
    TC |- tfix :| TyArrow Tfix Tfix ->
    TC |- TmFix tfix :| Tfix

where "TC '|-' t ':|' T" := (hasTy TC t T)
.

Hint Constructors hasTy.

(* Fixpoint complexness (t: tm): nat := *)
(*   match t with *)
(*   | TmError => 0 *)

(*   | TmUnit => 0 *)

(*   | TmTrue => 0 *)
(*   | TmFalse => 0 *)

(*   | TmChar => 0 *)

(*   | TmInt => 0 *)

(*   | TmPair tfst tsnd => *)
(*     max (complexness tfst) (complexness tsnd) + 1 *)
(*   | TmFst (TmPair tfst tsnd) => *)
(*     complexness tfst *)
(*   | TmFst _ => 0 *)
(*   | TmSnd (TmPair tfst tsnd) => *)
(*     complexness tsnd *)
(*   | TmSnd _ => 0 *)

(*   | TmNil => 0 *)
(*   | TmCons thead ttail => *)
(*     complexness thead + complexness ttail *)
(*   | TmHead (TmCons thead ttail) => *)
(*     complexness thead *)
(*   | TmHead _ => 0 *)
(*   | TmTail (TmCons thead ttail) => *)
(*     complexness ttail *)
(*   | TmTail _ => 0 *)

(*   | TmLam ipar Tpar tres => *)
(*     complexness tres + 1 *)
(*   | TmApp tlam tapp => *)
(*     complexness tlam * complexness tapp *)

(*   | TmVar ivar => 0 *)

(*   | TmEq tleft tright => *)
(*     max (complexness tleft) (complexness tright) + 1 *)
(*   | TmIf *)

(*   | TmLet: id -> tm -> tm -> tm *)
(*   | TmFix: tm -> tm *)

Theorem progress : forall t T,
    emptyMap |- t :| T ->
    val t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T typed.
  remember emptyMap as G.
  generalize dependent HeqG.
  induction typed; intros;
    subst; eauto;
      try (right;
           destruct IHtyped; subst; eauto;
           [inversion typed; subst; try solve by inversion; eauto |
            inversion H; eauto])...

  - (* TmAnd *)
    right.
    destruct IHtyped1; subst...
    + inversion typed1; subst; inversion H...
      destruct IHtyped2; subst...
      * inversion typed2; subst; inversion H0...
      * inversion typed2; subst; inversion H0; eauto;
          inversion H0; exists (TmAnd TmTrue x); constructor; eauto;
            intros contra; inversion contra.
    + inversion H...
  - (* TmOr *)
    right.
    destruct IHtyped1; subst...
    + inversion typed1; subst; inversion H...
      * destruct IHtyped2; subst...
        { inversion typed2; subst; inversion H0... }
        { inversion H0... }
    + inversion H...
  - (* TmIf *)
    right.
    destruct IHtyped1; subst...
    + inversion typed1; subst; inversion H...
    + inversion H...

  - (* TmApp *)
    right.
    destruct IHtyped1; subst...
    + inversion typed1; subst; inversion H...
    + inversion H...

  - (* TmEq *)
    right.
    destruct IHtyped1; subst...
    + destruct IHtyped2; subst...
      * inversion typed1; subst; inversion H0; eauto;
          inversion typed2; subst; inversion H1;
            try (exists TmError; constructor; eauto;
                    intros contra; by inversion contra);
            try (exists TmTrue; constructor; by eauto);
            try (exists TmFalse; constructor; by eauto)...
        { destruct (eq_nat_dec c c0).
          - exists TmTrue; constructor; subst...
          - exists TmFalse; constructor;
              intros contra; inversion contra; subst... }
        { destruct (Z.eq_dec z z0).
          - exists TmTrue; constructor; subst...
          - exists TmFalse; constructor;
              intros contra; inversion contra; subst... }
        { inversion H. }
      * remember tleft as tl.
        inversion typed1; subst; inversion H0; eauto;
          inversion H1; exists (TmEq tleft x); subst; constructor; eauto;
            intros contra; by inversion contra.
    + inversion H0...

  - (* TmVar *)
    inversion H.
Qed.

Hint Immediate progress.

Inductive freeVar: id -> tm -> Prop :=
| FreeVarNeg: forall i tneg,
    freeVar i tneg ->
    freeVar i (TmNeg tneg)
| FreeVarAndLeft: forall i tleft tright,
    freeVar i tleft ->
    freeVar i (TmAnd tleft tright)
| FreeVarAndRight: forall i tleft tright,
    freeVar i tright ->
    freeVar i (TmAnd tleft tright)
| FreeVarOrLeft: forall i tleft tright,
    freeVar i tleft ->
    freeVar i (TmOr tleft tright)
| FreeVarOrRight: forall i tleft tright,
    freeVar i tright ->
    freeVar i (TmOr tleft tright)
| FreeVarIfCond: forall i tcond ttrue tfalse,
    freeVar i tcond ->
    freeVar i (TmIf tcond ttrue tfalse)
| FreeVarIfTrue: forall i tcond ttrue tfalse,
    freeVar i ttrue ->
    freeVar i (TmIf tcond ttrue tfalse)
| FreeVarIfFalse: forall i tcond ttrue tfalse,
    freeVar i tfalse ->
    freeVar i (TmIf tcond ttrue tfalse)

| FreeVarPairFst: forall i tfst tsnd,
    freeVar i tfst ->
    freeVar i (TmPair tfst tsnd)
| FreeVarPairSnd: forall i tfst tsnd,
    freeVar i tsnd ->
    freeVar i (TmPair tfst tsnd)
| FreeVarFst: forall i tpair,
    freeVar i tpair ->
    freeVar i (TmFst tpair)
| FreeVarSnd: forall i tpair,
    freeVar i tpair ->
    freeVar i (TmSnd tpair)

| FreeVarConsHead: forall i thead ttail,
    freeVar i thead ->
    freeVar i (TmCons thead ttail)
| FreeVarConsTail: forall i thead ttail,
    freeVar i ttail ->
    freeVar i (TmCons thead ttail)
| FreeVarHead: forall i tlist,
    freeVar i tlist ->
    freeVar i (TmHead tlist)
| FreeVarTail: forall i tlist,
    freeVar i tlist ->
    freeVar i (TmTail tlist)

| FreeVarLam: forall i ipar Tpar tres,
    i <> ipar ->
    freeVar i tres ->
    freeVar i (TmLam ipar Tpar tres)
| FreeVarAppLam: forall i tlam tapp,
    freeVar i tlam ->
    freeVar i (TmApp tlam tapp)
| FreeVarAppApp: forall i tlam tapp,
    freeVar i tapp ->
    freeVar i (TmApp tlam tapp)

| FreeVarEqLeft: forall i tleft tright,
    freeVar i tleft ->
    freeVar i (TmEq tleft tright)
| FreeVarEqRight: forall i tleft tright,
    freeVar i tright ->
    freeVar i (TmEq tleft tright)

| FreeVarVar: forall i,
    freeVar i (TmVar i)

| FreeVarLetLet: forall i ilet tlet tin,
    freeVar i tlet ->
    freeVar i (TmLet ilet tlet tin)
| FreeVarLetIn: forall i ilet tlet tin,
    i <> ilet ->
    freeVar i tin ->
    freeVar i (TmLet ilet tlet tin)

| FreeVarFix: forall i tfix,
    freeVar i tfix ->
    freeVar i (TmFix tfix)
.

Hint Constructors freeVar.

Lemma context_invariance: forall (TC0 TC1: tyCtxt) t T,
    TC0 |- t :| T ->
    (forall i, freeVar i t -> TC0 i = TC1 i) ->
    TC1 |- t :| T.
Proof with eauto.
  intros TC0 TC1 t T typed eqFreeVar.
  generalize dependent TC1.
  induction typed; intros;
    try (constructor; by eauto)...
  - (* TmLam *)
    constructor.
    apply IHtyped. intros.
    unfold extend.
    destruct (eq_id_dec ipar i)...
  - (* TmApp *)
    econstructor...
  - (* TmBool *)
    econstructor...
  - (* TmVar *)
    constructor. rewrite <- eqFreeVar...
  - (* TmLet *)
    econstructor.
    + apply IHtyped1. intros.
      apply eqFreeVar...
    + apply IHtyped2. intros.
      unfold extend.
      destruct (eq_id_dec ilet i)...
Qed.

Hint Immediate context_invariance.

Lemma free_in_context: forall TC i t T0,
    TC |- t :| T0 ->
    freeVar i t ->
    exists T1, TC i = Some T1.
Proof with eauto.
  intros TC i t T0 typed free.
  induction typed; intros; inversion free; subst...
  - (* TmLam *)
    destruct IHtyped... exists x.
    rewrite <- H. unfold extend.
    rewrite neq_id...
  - (* TmLet *)
    destruct IHtyped2... exists x.
    rewrite <- H. unfold extend.
    rewrite neq_id...
Qed.

Hint Immediate free_in_context.

Lemma substitution_preserves_typing: forall TC i s S t T,
    (extend TC i S) |- t :| T ->
    emptyMap |- s :| S ->
    TC |- ([i <- s] t) :| T.
Proof with eauto.
  intros TC i s S t T typed0 typed1.
  generalize dependent T.
  generalize dependent S.
  generalize dependent s.
  generalize dependent i.
  generalize dependent TC.
  induction t; intros; inversion typed0;
    try (constructor; by eauto);
    try (simpl; econstructor; by eauto); subst; simpl...
  - (* TmLam *)
    constructor.
    destruct (eq_id_dec i0 i).
    + eapply context_invariance...
      intros. subst. unfold extend.
      destruct (eq_id_dec i i1)...
    + eapply IHt...
      eapply context_invariance...
      intros. subst. unfold extend.
      destruct (eq_id_dec i i1)...
      subst. rewrite neq_id...
  - (* TmVar *)
    destruct (eq_id_dec i0 i).
    + subst. rewrite extend_eq in H1.
      inversion H1; subst. clear H1.
      eapply context_invariance... intros.
      destruct (free_in_context _ _ _ T typed1 H).
      inversion H0.
    + econstructor.
      rewrite <- H1. unfold extend.
      rewrite neq_id...
  - (* TmLet *)
    destruct (eq_id_dec i0 i).
    + econstructor...
      eapply context_invariance...
      intros. subst. unfold extend.
      destruct (eq_id_dec i i1)...
    + econstructor...
      eapply IHt2...
      eapply context_invariance...
      intros. subst. unfold extend.
      destruct (eq_id_dec i i1); destruct (eq_id_dec i0 i1); subst...
      exfalso...
Qed.

Hint Immediate substitution_preserves_typing.

Theorem preservation: forall t0 t1 T,
    emptyMap |- t0 :| T ->
    t0 ==> t1 ->
    emptyMap |- t1 :| T.
Proof with eauto.
  intros t0 t1 T typed step.
  remember emptyMap as TC. generalize dependent HeqTC.
  generalize dependent t1.
  induction typed; intros; subst;
    try (inversion step; subst;
         inversion typed; by eauto);
    try (inversion step; subst; by eauto)...
  - (* TmApp *)
    inversion step; subst...
    eapply substitution_preserves_typing...
    inversion typed1...
  - (* TmEq *)
    inversion step; subst; try (econstructor; by eauto)...
    + inversion typed1; subst;
        inversion typed2; subst;
          inversion H; subst.
      econstructor; econstructor...
    + inversion typed1; subst;
        inversion typed2; subst;
          inversion H; subst.
      econstructor; econstructor...
  - (* TmFix *)
    inversion step; subst...
    eapply substitution_preserves_typing...
    inversion typed; subst...
Qed.

Hint Immediate preservation.

Definition nmlfm {T: Type} (R: Relation T) (t0: T): Prop :=
  ~ exists t1, R t0 t1.

Hint Unfold nmlfm.

Notation stnmlfm := (nmlfm smst).

Notation mltst := (mlt smst).
Notation "t0 '==>*' t1" := (mltst t0 t1) (at level 40).

Theorem soundness: forall t0 t1 T,
    emptyMap |- t0 :| T ->
    t0 ==>* t1 ->
    ~ stnmlfm t1 \/ val t1.
Proof with eauto.
  intros t0 t1 T typed mltstep.
  induction mltstep...
  - apply progress in typed.
    destruct typed...
Qed.

Hint Immediate soundness.


(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
From mathcomp Require Import all_ssreflect.
From mathcomp Require boolp.
Require Import monae_lib.
From HB Require Import structures.
Require Import hierarchy monad_lib fail_lib.
From infotheo Require Import ssrZ.
Require Import ZArith.

(******************************************************************************)
(*                Definitions and lemmas about the array monad                *)
(*                                                                            *)
(*           aswap i j == swap the cells at addresses i and j; this is a      *)
(*                        computation of type (M unit)                        *)
(*       writeList i s == write the list s at address i; this is a            *)
(*                        computation of type (M unit)                        *)
(*          writeL i s := writeList i s >> Ret (size s)                       *)
(*    write2L i (s, t) := writeList i (s ++ t) >> Ret (size s, size t)        *)
(* write3L i (s, t, u) := writeList i (s ++ t ++ u) >>                        *)
(*                        Ret (size s, size t, size u)                        *)
(*        readList i n == read the list of values of size n starting at       *)
(*                        address i; it is a computation of type (M (seq E))  *)
(*                        where E is the type of stored elements              *)
(*                                                                            *)
(******************************************************************************)

Local Open Scope monae_scope.
Local Open Scope zarith_ext_scope.

Section marray.
Context {d : unit} {E : porderType d} {M : arrayMonad E Z_eqType}.
Implicit Type i j : Z.

Definition aswap i j : M unit :=
  aget i >>= (fun x => aget j >>= (fun y => aput i y >> aput j x)).

Lemma aswapxx i : aswap i i = skip.
Proof.
rewrite /aswap agetget.
under eq_bind do rewrite aputput.
by rewrite agetputskip.
Qed.

Fixpoint writeList i (s : seq E) : M unit :=
  if s isn't x :: xs then Ret tt else aput i x >> writeList (i + 1) xs.

Lemma writeList1 i (x : E) : writeList i [:: x] = aput i x.
Proof. by rewrite /writeList bindmskip. Qed.

Lemma writeList_cons i (x : E) (xs : seq E) :
  writeList i (x :: xs) = aput i x >> writeList (i + 1) xs.
Proof. by []. Qed.

Lemma aput_writeListC i j (x : E) (xs : seq E) : (i < j)%Z ->
  aput i x >> writeList j xs = writeList j xs >> aput i x.
Proof.
elim: xs i j => [|h tl ih] i j ij.
  by rewrite bindretf bindmskip.
rewrite /= -bindA aputC; last by left; apply/eqP/ltZ_eqF.
rewrite !bindA; bind_ext => -[].
by rewrite ih// ltZadd1; apply/ltZW.
Qed.

Lemma writeListC i j (ys zs : seq E) : (i + (size ys)%:Z <= j)%Z ->
  writeList i ys >> writeList j zs = writeList j zs >> writeList i ys.
Proof.
elim: ys zs i j => [|h t ih] zs i j hyp; first by rewrite bindretf bindmskip.
rewrite /= aput_writeListC; last by rewrite ltZadd1; exact: leZZ.
rewrite bindA aput_writeListC; last exact/ltZ_leZ_trans/hyp/ltZ_addr/leZZ.
rewrite /= natZS -add1Z addZA in hyp.
by rewrite -!bindA ih.
Qed.

Lemma aput_writeListCR i j (x : E) (xs : seq E) : (j + (size xs)%:Z <= i)%Z ->
  aput i x >> writeList j xs = writeList j xs >> aput i x.
Proof. by move=> ?; rewrite -writeList1 -writeListC. Qed.

Lemma writeList_cat i (s1 s2 : seq E) :
  writeList i (s1 ++ s2) = writeList i s1 >> writeList (i + (size s1)%:Z) s2.
Proof.
elim: s1 i => [|h t ih] i /=; first by rewrite bindretf addZ0.
by rewrite ih bindA -addZA add1Z natZS.
Qed.

Lemma writeList_rcons i (x : E) (xs : seq E) :
  writeList i (rcons xs x) = writeList i xs >> aput (i + (size xs)%:Z)%Z x.
Proof. by rewrite -cats1 writeList_cat /= -bindA bindmskip. Qed.

Definition writeL i (s : seq E) := writeList i s >> Ret (size s).

Definition write2L i '(s, t) := writeList i (s ++ t) >> Ret (size s, size t).

Lemma write2LE i a b D (f : nat * nat -> M D) :
  write2L i (a, b) >>= f = writeList i (a ++ b) >> f (size a, size b).
Proof. by rewrite /write2L bindA bindretf. Qed.

Definition write3L i '(s, t, u) :=
  writeList i (s ++ t ++ u) >> Ret (size s, size t, size u).

Lemma write3LE i x D (f : nat * nat * nat -> M D) :
  write3L i x >>= f = let '(s, t, u) := x in
    writeList i (s ++ t ++ u) >> f (size s, size t, size u).
Proof. by move: x => -[[x y] z]; rewrite /write3L bindA bindretf. Qed.

Lemma write_read i x : aput i x >> aget i = aput i x >> Ret x :> M _.
Proof. by rewrite -[RHS]aputget bindmret. Qed.

Lemma write_readC i j x : i != j ->
  aput i x >> aget j = aget j >>= (fun v => aput i x >> Ret v) :> M _.
Proof. by move => ?; rewrite -aputgetC // bindmret. Qed.

(* see postulate introduce-read in IQsort.agda *)
Lemma writeListRet i x (s : seq E) :
  writeList i (x :: s) >> Ret x = writeList i (x :: s) >> aget i.
Proof.
elim/last_ind: s x i => [|h t ih] /= x i.
  by rewrite bindmskip write_read.
rewrite writeList_rcons 2![in RHS]bindA.
rewrite write_readC; last first.
  apply/eqP/gtZ_eqF; rewrite addZC; apply/ltZ_addl; first exact/leZ0n.
  exact/ltZadd1/leZZ.
rewrite -2![RHS]bindA -ih [RHS]bindA.
rewrite !bindA; bind_ext => _.
by under [in RHS]eq_bind do rewrite bindretf.
Qed.

Lemma writeList_aswap i x h (t : seq E) :
  writeList i (rcons (h :: t) x) =
  writeList i (rcons (x :: t) h) >> aswap i (i + (size (rcons t h))%:Z).
Proof.
rewrite /aswap -!bindA writeList_rcons /=.
rewrite aput_writeListC; last by apply/ltZ_addr => //; exact: leZZ.
rewrite bindA.
rewrite aput_writeListC; last by apply/ltZ_addr => //; exact: leZZ.
rewrite writeList_rcons !bindA; bind_ext => -[].
under [RHS] eq_bind do rewrite -bindA.
rewrite aputget -bindA size_rcons -addZA natZS -add1Z.
under [RHS] eq_bind do rewrite -!bindA.
rewrite aputgetC; last first.
  apply/eqP/ltZ_eqF; rewrite addZA addZC; apply/ltZ_addl; first exact/leZ0n.
  by apply/ltZ_addr => //; exact: leZZ.
rewrite -!bindA aputget aputput aputC; last by right.
by rewrite bindA aputput.
Qed.

Lemma aput_writeList_rcons i x h (t : seq E) :
  aput i x >> writeList (i + 1) (rcons t h) =
  aput i h >>
      ((writeList (i + 1) t >> aput (i + 1 + (size t)%:Z)%Z x) >>
        aswap i (i + (size t).+1%:Z)).
Proof.
rewrite /aswap -!bindA writeList_rcons -bindA.
rewrite aput_writeListC; last by rewrite ltZadd1; exact: leZZ.
rewrite aput_writeListC; last by rewrite ltZadd1; exact: leZZ.
rewrite !bindA; bind_ext => -[].
under [RHS] eq_bind do rewrite -bindA.
rewrite aputgetC; last first.
  apply/eqP/gtZ_eqF; rewrite addZC; apply/ltZ_addl; first exact: leZ0n.
  by apply/ltZ_addr => //; exact: leZZ.
rewrite -bindA -addZA natZS -add1Z aputget.
under [RHS] eq_bind do rewrite -!bindA.
rewrite aputget aputC; last by right.
by rewrite -!bindA aputput bindA aputput.
Qed.

Lemma writeList_ret_aget i x (s : seq E) (f : E -> M (nat * nat)%type):
  writeList i (x :: s) >> Ret x >> f x =
  writeList i (x :: s) >> aget i >>= f.
Proof.
rewrite writeListRet 2!bindA /=.
rewrite aput_writeListC; last by apply/ltZ_addr => //; exact: leZZ.
rewrite 2!bindA.
under [LHS] eq_bind do rewrite -bindA aputget.
by under [RHS] eq_bind do rewrite -bindA aputget.
Qed.

Fixpoint readList i (n : nat) : M (seq E) :=
  if n isn't k.+1 then Ret [::] else liftM2 cons (aget i) (readList (i + 1) k).

End marray.

Section refin_writeList_aswap.
Variable (d : unit) (E : orderType d) (M : plusArrayMonad E Z_eqType).

(* eqn 13 in mu2020flops, postulate introduce-swap in IQSort.agda *)
Lemma refin_writeList_cons_aswap (i : Z) x (s : seq E) :
  writeList i (x :: s) >> aswap (M := M) i (i + (size s)%:Z)
  `<=`
  qperm s >>= (fun s' => writeList i (rcons s' x)).
Proof.
elim/last_ind: s => [|t h ih] /=.
  rewrite qperm_nil bindmskip bindretf addZ0 aswapxx /= bindmskip.
  exact: refin_refl.
rewrite bindA.
apply: (refin_trans _ (refin_bindr _ (qperm_refin_cons _ _ _))).
by rewrite bindretf -bindA -writeList_aswap; exact: refin_refl.
Qed.

(* eqn 11 in mu2020flops, introduce-swap in IPartl.agda *)
Lemma refin_writeList_rcons_aswap (i : Z) x (s : seq E) :
  writeList i (rcons s x) >> aswap (M := M) i (i + (size s)%:Z)
  `<=`
  qperm s >>= (fun s' => writeList (M := M) i (x :: s')).
Proof.
case: s => [|h t] /=.
  rewrite qperm_nil bindmskip bindretf addZ0 aswapxx bindmskip.
  exact: refin_refl.
rewrite bindA writeList_rcons -aput_writeList_rcons.
apply: (refin_trans _ (refin_bindr _ (qperm_refin_rcons _ _ _))).
by rewrite bindretf; exact: refin_refl.
Qed.

(* bottom of the page 11, used in the proof of lemma 10 *)
Lemma refin_writeList_rcons_cat_aswap (i : Z) x (ys zs : seq E) :
  writeList i (rcons (ys ++ zs) x) >>
    aswap (M := M) (i + (size ys)%:Z) (i + (size (ys ++ zs))%:Z)
  `<=`
  qperm zs >>= (fun zs' => writeList i (ys ++ x :: zs')).
Proof.
under [in X in _ `<=` X]eq_bind do rewrite writeList_cat.
have -> : commute (qperm zs) (writeList i ys) _.
  by move=> *; exact/commute_plus/nondetPlus_sub_qperm.
rewrite rcons_cat writeList_cat bindA; apply: refin_bindl => -[].
by rewrite size_cat intRD addZA; exact: refin_writeList_rcons_aswap.
Qed.

End refin_writeList_aswap.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Parameter ident : Type.

Axiom ident_eq_dec : forall (i1:ident) (i2:ident), (i1 = i2) \/ ~ (i1 = i2).

Parameter mk_ident: Z -> ident.

Axiom mk_ident_inj : forall (i:Z) (j:Z), ((mk_ident i) = (mk_ident j)) ->
  (i = j).

Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator .

Inductive expr  :=
  | Econst : Z -> expr
  | Evar : ident -> expr
  | Ebin : expr -> operator -> expr -> expr .

Inductive stmt  :=
  | Sskip : stmt
  | Sassign : ident -> expr -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : expr -> stmt -> stmt -> stmt
  | Swhile : expr -> stmt -> stmt .

Axiom check_skip : forall (s:stmt), (s = Sskip) \/ ~ (s = Sskip).

Parameter map : forall (a:Type) (b:Type), Type.

Parameter get: forall (a:Type) (b:Type), (map a b) -> a -> b.

Implicit Arguments get.

Parameter set: forall (a:Type) (b:Type), (map a b) -> a -> b -> (map a b).

Implicit Arguments set.

Axiom Select_eq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) -> ((get (set m a1 b1)
  a2) = b1).

Axiom Select_neq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1)
  a2) = (get m a2)).

Parameter const: forall (b:Type) (a:Type), b -> (map a b).

Set Contextual Implicit.
Implicit Arguments const.
Unset Contextual Implicit.

Axiom Const : forall (b:Type) (a:Type), forall (b1:b) (a1:a), ((get (const(
  b1):(map a b)) a1) = b1).

Definition state  := (map ident Z).

Definition eval_bin(x:Z) (op:operator) (y:Z): Z :=
  match op with
  | Oplus => (x + y)%Z
  | Ominus => (x - y)%Z
  | Omult => (x * y)%Z
  end.

Set Implicit Arguments.
Fixpoint eval_expr(s:(map ident Z)) (e:expr) {struct e}: Z :=
  match e with
  | (Econst n) => n
  | (Evar x) => (get s x)
  | (Ebin e1 op e2) => (eval_bin (eval_expr s e1) op (eval_expr s e2))
  end.
Unset Implicit Arguments.

Inductive one_step : (map ident Z) -> stmt -> (map ident Z)
  -> stmt -> Prop :=
  | one_step_assign : forall (s:(map ident Z)) (x:ident) (e:expr),
      (one_step s (Sassign x e) (set s x (eval_expr s e)) Sskip)
  | one_step_seq : forall (s:(map ident Z)) (sqt:(map ident Z)) (i1:stmt)
      (i1qt:stmt) (i2:stmt), (one_step s i1 sqt i1qt) -> (one_step s (Sseq i1
      i2) sqt (Sseq i1qt i2))
  | one_step_seq_skip : forall (s:(map ident Z)) (i:stmt), (one_step s
      (Sseq Sskip i) s i)
  | one_step_if_true : forall (s:(map ident Z)) (e:expr) (i1:stmt) (i2:stmt),
      (~ ((eval_expr s e) = 0%Z)) -> (one_step s (Sif e i1 i2) s i1)
  | one_step_if_false : forall (s:(map ident Z)) (e:expr) (i1:stmt)
      (i2:stmt), ((eval_expr s e) = 0%Z) -> (one_step s (Sif e i1 i2) s i2)
  | one_step_while_true : forall (s:(map ident Z)) (e:expr) (i:stmt),
      (~ ((eval_expr s e) = 0%Z)) -> (one_step s (Swhile e i) s (Sseq i
      (Swhile e i)))
  | one_step_while_false : forall (s:(map ident Z)) (e:expr) (i:stmt),
      ((eval_expr s e) = 0%Z) -> (one_step s (Swhile e i) s Sskip).

Axiom progress : forall (s:(map ident Z)) (i:stmt), (~ (i = Sskip)) ->
  exists sqt:(map ident Z), exists iqt:stmt, (one_step s i sqt iqt).

Inductive many_steps : (map ident Z) -> stmt -> (map ident Z) -> stmt
  -> Z -> Prop :=
  | many_steps_refl : forall (s:(map ident Z)) (i:stmt), (many_steps s i s i
      0%Z)
  | many_steps_trans : forall (s1:(map ident Z)) (s2:(map ident Z)) (s3:(map
      ident Z)) (i1:stmt) (i2:stmt) (i3:stmt) (n:Z), (one_step s1 i1 s2
      i2) -> ((many_steps s2 i2 s3 i3 n) -> (many_steps s1 i1 s3 i3
      (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (s1:(map ident Z)) (s2:(map ident Z)) (i1:stmt)
  (i2:stmt) (n:Z), (many_steps s1 i1 s2 i2 n) -> (0%Z <= n)%Z.

Axiom many_steps_seq : forall (s1:(map ident Z)) (s3:(map ident Z)) (i1:stmt)
  (i2:stmt) (n:Z), (many_steps s1 (Sseq i1 i2) s3 Sskip n) -> exists s2:(map
  ident Z), exists n1:Z, exists n2:Z, (many_steps s1 i1 s2 Sskip n1) /\
  ((many_steps s2 i2 s3 Sskip n2) /\ (n = ((1%Z + n1)%Z + n2)%Z)).

Inductive fmla  :=
  | Fterm : expr -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla .

Set Implicit Arguments.
Fixpoint eval_fmla(s:(map ident Z)) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => ~ ((eval_expr s e) = 0%Z)
  | (Fand f1 f2) => (eval_fmla s f1) /\ (eval_fmla s f2)
  | (Fnot f1) => ~ (eval_fmla s f1)
  | (Fimplies f1 f2) => (eval_fmla s f1) -> (eval_fmla s f2)
  end.
Unset Implicit Arguments.

Parameter subst_expr: expr -> ident -> expr -> expr.

Axiom subst_expr_def : forall (e:expr) (x:ident) (t:expr),
  match e with
  | (Econst _) => ((subst_expr e x t) = e)
  | (Evar y) => ((x = y) -> ((subst_expr e x t) = t)) /\ ((~ (x = y)) ->
      ((subst_expr e x t) = e))
  | (Ebin e1 op e2) => ((subst_expr e x t) = (Ebin (subst_expr e1 x t) op
      (subst_expr e2 x t)))
  end.

Axiom eval_subst_expr : forall (s:(map ident Z)) (e:expr) (x:ident) (t:expr),
  ((eval_expr s (subst_expr e x t)) = (eval_expr (set s x (eval_expr s t))
  e)).

Set Implicit Arguments.
Fixpoint subst(f:fmla) (x:ident) (t:expr) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_expr e x t))
  | (Fand f1 f2) => (Fand (subst f1 x t) (subst f2 x t))
  | (Fnot f1) => (Fnot (subst f1 x t))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x t) (subst f2 x t))
  end.
Unset Implicit Arguments.

Axiom eval_subst : forall (s:(map ident Z)) (f:fmla) (x:ident) (t:expr),
  (eval_fmla s (subst f x t)) <-> (eval_fmla (set s x (eval_expr s t)) f).

Definition valid_fmla(p:fmla): Prop := forall (s:(map ident Z)), (eval_fmla s
  p).

Definition valid_triple(p:fmla) (i:stmt) (q:fmla): Prop := forall (s:(map
  ident Z)), (eval_fmla s p) -> forall (sqt:(map ident Z)) (n:Z),
  (many_steps s i sqt Sskip n) -> (eval_fmla sqt q).

Axiom skip_rule : forall (q:fmla), (valid_triple q Sskip q).

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem assign_rule : forall (q:fmla) (x:ident) (e:expr),
  (valid_triple (subst q x e) (Sassign x e) q).
(* YOU MAY EDIT THE PROOF BELOW *)
intros q x e.
unfold valid_triple.
intros s Pre s' n Hred.
inversion Hred; subst.
inversion H; subst.
inversion H0; subst.
(* normal case *)
clear H Hred H0.
rewrite <- eval_subst; auto.

(* absurd case *)
inversion H1.
Qed.
(* DO NOT EDIT BELOW *)


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

(* typedparam.v
   Parametricity theorem
*)

Set Automatic Coercions Import.
Require Import seq.
Require Import typeddensem.
Require Import relations.
Require Import Program.Equality.

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

Section TypesRSem.

Variables T T' : monadType.
Variable TRacc : TRelAccType T T'.

Parameter RSem_Base :
  forall (o : baseType), Rel (semBase o T) (semBase o T').
Parameter admissible_RSem_Base :
  forall (o : baseType), admissibleR (@RSem_Base o).

Fixpoint TRSemTy (ty : Ty) : Rel (SemTy T ty) (SemTy T' ty) :=
  match ty with
    | Base o => @RSem_Base o
    | ty1 --> ty2 =>
        (@TRSemTy ty1) =R=>
        (TRel TRacc (X:=SemTy T ty2) (X':=SemTy T' ty2) (@TRSemTy ty2))
    | ty1 ** ty2 => (@TRSemTy ty1) *R* (@TRSemTy ty2)
  end.

Lemma admissibleTRSemTy : forall ty, admissibleR (@TRSemTy ty).
elim => [o | ty1 Hty1 ty2 Hty2 | ty1 Hty1 ty2 Hty2].
- by apply: admissible_RSem_Base.
- rewrite /=. apply: admissibleArrR. by apply: (@Adm _ _ TRacc).
- rewrite /=. by apply: admissibleProdR.
Qed.

End TypesRSem.

Implicit Arguments TRSemTy [T T'].

Lemma parametricity
        T T' (TRacc : TRelAccType T T')
        env (eta : SemEnv T env) (eta' : SemEnv T' env) :
    (forall ty (c : Const ty),
      TRSemTy TRacc _ (SemConst T c) (SemConst T' c)) ->
    (forall ty (v : Var env ty),
      TRSemTy TRacc _ (SemVar T v eta) (SemVar T' v eta')) ->
    forall ty (e : Exp env ty),
      TRel TRacc (X:=SemTy T ty) (X':=SemTy T' ty)
        (TRSemTy TRacc _)
        (SemExp T e eta)
        (SemExp T' e eta').
Proof.
move => Hconst Hvar.
dependent induction e.

(* TCONST *)
- rewrite /=. by apply: (proj1 (Acc TRacc)).

(* TVAR *)
- rewrite /=. by apply: (proj1 (Acc TRacc)).

(* TPROD *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => x x' Hxx' /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => y y' Hyy' /=.
  by apply: (proj1 (Acc TRacc)).

(* TFST *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  intros x x' Hxx' => /=.
  apply: (proj1 (Acc TRacc)).
  by apply: (proj1 (ProdR_elim Hxx')).

(* TSND *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  intros x x' Hxx' => /=.
  apply: (proj1 (Acc TRacc)).
  by apply: (proj2 (ProdR_elim Hxx')).

(* TABS *)
- move => /=.
  apply: (proj1 (Acc TRacc)).
  intros x x' Hxx' => /=.
  apply: IHe => // ty v.
  by dependent destruction v => //=.

(* TAPP *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => f f' Hff' => /=.
  by apply: (proj2 (Acc TRacc)); auto.

(* TLET *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => f f' Hff' => /=.
  apply: IHe2 => //.
  move => ty v.
  by  dependent destruction v => //=.

(* TFIX *)
- move => /=.
  apply: (proj1 (Acc TRacc)).
  have Hadm : admissibleR (TRSemTy TRacc ty1 =R=> TRel TRacc (TRSemTy TRacc ty2)).
    apply: admissibleArrR. apply: (@Adm _ _ TRacc). by apply: admissibleTRSemTy.
  apply: (fixpR_ind Hadm).
  + move => x x' Hxx' /=. by apply: (Str TRacc).
  + move => f f' Hff' x x' Hxx' /=.
    apply: IHe => //.
    move => ty v.
    dependent destruction v => //=.
    by dependent destruction v => //=.
Qed.

Corollary ParametricityTheorem
            T T' (TRacc : TRelAccType T T')
            (eta : SemEnv T [::]) (eta' : SemEnv T' [::]) :
    (forall ty (c : Const ty),
      TRSemTy TRacc _ (SemConst T c) (SemConst T' c)) ->
    forall ty (e : CExp ty),
      TRel TRacc (X:=SemTy T ty) (X':=SemTy T' ty)
           (TRSemTy TRacc _)
           (SemExp T e eta)
           (SemExp T' e eta').
Proof.
move => Hconst ty e.
apply: parametricity => //.
move => {ty e Hconst} ty v.
by dependent destruction v.
Qed.


Require Import BoolEquality.
Require Import BaseDef.
Require Import MSets.
Require Import Reals.
Require Import Fourier.
Require Import CCMisc.
Require Import le_lift.

Set Implicit Arguments.
Unset Strict Implicit.

Open Scope R_scope.

(* *********************************************************************** *)
(*                           1.Some auxiliary lemmas                       *)
(* *********************************************************************** *)

Lemma R_dist_le : forall x y l,
 0 <= x <= l ->
 0 <= y <= l ->
 R_dist x y <= l.
Proof.
 intros x y l (H1x, H2x) (H1y, H2y).
 unfold R_dist, Rabs.
 destruct (Rcase_abs (x - y)); fourier.
Qed.

Lemma prod_dec:  forall (A B : Type),
  (forall (a1 a2:A), {a1 = a2} + {~ a1 = a2}) ->
  (forall (b1 b2:B), {b1 = b2} + {~ b1 = b2}) ->
  forall (ab1 ab2: A*B), { ab1 = ab2} + {~ ab1 = ab2}.
Proof.
 intros A B HA HB (a1,b1) (a2,b2).
 destruct (HA a1 a2).
   destruct (HB b1 b2).
     subst; left; trivial.
     right; intros H; inversion H; tauto.
   right; intros H; inversion H; tauto.
Qed.

Lemma NoDupA_NoDup: forall (A:Type) (l:list A),
  NoDupA eq l -> NoDup l.
Proof.
 intros; induction l.
   trivial.
   inversion H; subst.
   constructor.
   intro H'; apply (H2 (In_InA eq_equivalence H')).
   auto.
Qed.

Lemma InA_In: forall (A:Type) (a:A) (l:list A),
  InA eq a l <-> List.In a l.
Proof.
 split; intros.
   induction l.
     rewrite InA_nil in H; elim H.
     inversion H; subst; [ apply in_eq |
       apply (in_cons _ _ _ (IHl H1)) ].
   apply (In_InA eq_equivalence H).
Qed.

Lemma Permutation_PermutP: forall (A:Type) (l1 l2:list A),
  Permutation l1 l2 -> PermutP eq l1 l2.
Proof.
 intros.
 induction H.
   constructor.
   apply PermutP_cons; trivial.
   apply permP_swap with (x:=y) (l:=x::l) (l1':=x::List.nil)
       (x':=y) (l2':=l); [ trivial | ].
   apply (PermutP_cons _ _ (eq_refl _)), PermutP_refl; intros; trivial.
   apply PermutP_trans with l'; trivial.
Qed.

Lemma fold_right_Perm: forall (A:Type) (a:A) (f: A -> A -> A),
  (forall x y z, f x (f y z) = f y (f x z)) ->
  forall (l1 l2: list A),
    PermutP (@eq _) l1 l2 ->
    fold_right f a l1 = fold_right f a l2.
Proof.
 intros A a f Hf.
 induction 1.
   trivial.
   subst; simpl; clear H0.
   rewrite IHPermutP.
   clear IHPermutP; induction l1'.
     trivial.
     change (f x' (f a0 (fold_right f a (l1' ++ l2'))) =
       f a0 (fold_right f a (l1' ++ x' :: l2'))).
     rewrite <-IHl1'; trivial.
Qed.

(* *********************************************************************** *)
(*                   2.[Discretize] for a finite domain.                   *)
(* *********************************************************************** *)

Section Finite_Discretize.

 Variable A B:Type.

 Variable s: A -> B -> R.

 Variable Out : list B.
 Hypothesis Out_spec:
  {b:B | List.In b Out /\ forall a, s a b > 0} + {Out = @List.nil B}.

 Hypothesis s_pos: forall a b, 0 <= s a b .

 Variable dummy:B.

 (* For each [a in A], pick an element [b in Out] with
    probability proportional to [s a b] *)
 Definition finite_discr: A -> Distr (B).
  intro a.
  destruct Out_spec as [ (b,(H1b,H2b)) | HOut ].
    refine (@finite_distr _ Out (fun b => s a b) (s_pos a) b H1b (H2b a)).
    exact (Munit dummy).
 Defined.

 Lemma finite_discr_is_Discrete: forall a,
   is_Discrete (finite_discr a).
 Proof.
  intros a; unfold finite_discr.
  destruct Out_spec as [ (b,(H1b,H2b)) | HOut ].
    apply finite_distr_discrete.
    apply is_Discrete_Munit.
 Qed.

 Lemma finite_discr_lossless: forall a,
   mu (finite_discr a) (fun _ => 1)%U == 1%U.
 Proof.
  intros; unfold finite_discr.
  destruct Out_spec as [ (b,(H1b,H2b)) | HOut ].
    apply finite_distr_lossless.
    trivial.
 Qed.

 Variable eqU: B -> B -O-> U.
 Hypothesis eqU_spec: forall b:B, cover (eq b) (eqU b).

 Hypothesis Hdec: forall (b:B), {List.In b Out} + {~ List.In b Out}.
 Hypothesis Out_NoDup: NoDup Out.

 Section Assym_Distance.

  Variables a a':A.
  Variables M M':R.
  Hypothesis HM:  forall b, List.In b Out -> s a b  <= M  * s a' b.
  Hypothesis HM': forall b, List.In b Out -> s a' b <= M' * s a  b.
  Hypothesis HM_pos:  0 <= M.
  Hypothesis HM'_pos: 0 <= M'.

  Lemma finite_discr_assym_dist:
   let d1 := finite_discr a in
   let d2 := finite_discr a' in
   let lam := M * M' in
   1 <= lam ->
   forall (b:B), (mu d1 (eqU b) <= lam ** mu d2 (eqU b))%tord.
  Proof.
   intros d1 d2 lam Hlam b.
   unfold d1, d2, finite_discr.
   destruct Out_spec as [ (b',(H1b',H2b')) | HOut ].
   (* case [Out] not empty *)
   destruct (Hdec b) as [Hb | Hb].
     (* case [ b in Out ] *)
     rewrite 2 finite_distr_in; trivial.
     unfold multRU; repeat case_Rle; trivial; [ | elim n;
       apply Rmult_le_pos; [ apply Rmult_le_pos; trivial | apply iR_ge_0 ] ].
     assert (Haux: forall x, 0 < y Out (fun b0 : B => s x b0)) by
       (intro x; refine (y_gt_0 _ _ (s_pos x) _ H1b' (H2b' x))).
     unfold c; rewrite retract_R.
     Focus 2.
     split; [ apply Rdiv_pos; trivial | ].
     apply Rdiv_le_1; trivial.
     unfold y; generalize Out b Hb; clear -s_pos.
     induction Out; intros.
       elim (in_nil Hb).
       simpl; destruct (in_inv Hb).
         subst; apply Rle_plus_l.
         clear -s_pos; induction l; simpl;
           [ trivial | rewrite <-s_pos, <-IHl; fourier ].
         rewrite (IHl _ H); apply (Rle_plus_r _ (s_pos _ _)).
     apply iU_le_morphism; unfold lam.
     generalize (Haux a) (Haux a');
     set (y1:= y Out (fun b0 : B => s a b0));
     set (y2:= y Out (fun b0 : B => s a' b0));
     clear -s_pos HM HM' HM_pos HM'_pos Hb; intros Hy1 Hy2.
     transitivity (M * (s a' b / y1)).
     replace (M * (s a' b / y1)) with ((M * s a' b) / y1) by
       (field; intro; fourier); apply Rdiv_le_compat; auto.
     rewrite Rmult_assoc; apply Rmult_le_compat_l; trivial.
     replace (M' * (s a' b / y2)) with (s a' b * (M' / y2)) by
       (field; intro; fourier); apply Rmult_le_compat_l; trivial.
     apply Rmult_le_reg_r with y2; [trivial | rewrite (Rdiv_mult _ Hy2) ].
     apply Rmult_le_reg_r with y1; [trivial | ];
     replace (/ y1 * y2 * y1) with y2  by (field; intro; fourier).
     unfold y2, y1, y.
     rewrite <-fold_right_Rplus_mult.
     apply fold_right_Rplus_monotonic; auto.
     (* case [b not_in Out] *)
     rewrite 2 finite_distr_notin; trivial.
   (* case [Out] empty *)
   simpl; rewrite <-(multRU_1_l (eqU b dummy)) at 1;
     apply multRU_le_compat; trivial; fourier.
  Qed.

 End Assym_Distance.

 Section Symm_Distance.

  Variables a a':A.
  Variables M:R.
  Hypothesis HM1: forall b, List.In b Out -> s a  b <= M * s a' b.
  Hypothesis HM2: forall b, List.In b Out -> s a' b <= M * s a  b.
  Hypothesis HM_pos:  0 <= M.

  Lemma finite_discr_symm_dist:
   let d1 := finite_discr a in
   let d2 := finite_discr a' in
   let lam := M * M in
   (1 <= M) ->
   le_dist d1 d2 lam D0.
  Proof.
   intros.
   assert (d1_discr: is_Discrete d1) by apply finite_discr_is_Discrete.
   assert (d2_discr: is_Discrete d2) by apply finite_discr_is_Discrete.
   set (p:=parity_split (D_points d1_discr) (D_points d2_discr)).
   refine (le_dist_discr_serie_intro _ eqU_spec _
     (disc_eqpoint_l d1_discr d2_discr) (disc_eqpoint_r d1_discr d2_discr) _ _ _).
     rewrite <-(Rmult_1_r 1); apply Rmult_le_compat; trivial; fourier.
   apply serie_zero; intro k.
   split; trivial; apply Uminus_le_zero.
   apply (cover_elim (cover_not_first_repr _ _  eqU_spec p) k);
     [auto | | ]; intros [H4 H5].
     rewrite (coeff_first_repr _ eqU_spec (disc_eqpoint_l d1_discr d2_discr) _ H5),
       (coeff_first_repr _ eqU_spec (disc_eqpoint_r d1_discr d2_discr) _ H5); fold p.
     apply finite_discr_assym_dist; trivial.
     rewrite <-(Rmult_1_r 1); apply Rmult_le_compat; trivial; fourier.
     fold p; rewrite (coeff_not_first_repr _ _ _ _ H5); trivial.
   apply serie_zero; intro k.
   split; trivial; apply Uminus_le_zero.
   apply (cover_elim (cover_not_first_repr _ _  eqU_spec p) k);
     [auto | | ]; intros [H4 H5].
     rewrite (coeff_first_repr _ eqU_spec (disc_eqpoint_l d1_discr d2_discr) _ H5),
       (coeff_first_repr _ eqU_spec (disc_eqpoint_r d1_discr d2_discr) _ H5); fold p.
     apply finite_discr_assym_dist; trivial.
     rewrite <-(Rmult_1_r 1); apply Rmult_le_compat; trivial; fourier.
     fold p; rewrite (coeff_not_first_repr _ _ _ _ H5); trivial.
  Qed.

 End Symm_Distance.

End Finite_Discretize.

(* Exponential distribution over a finite carrier set,
   antimonotonic wrt the scoring function -ie the higher
   the score function, the less likely- *)
Section Finite_Exp_Antimonot.

 Variable A B:Type.

 Variable eps : R.
 Hypothesis eps_pos : 0 <= eps.

 Variable f: A -> B -> R.

 Let s := fun a b => exp (- eps * f a b).

 Variable Out : list B.
 Hypothesis Out_spec:
  {b:B | List.In b Out} + {Out = @List.nil B}.

 Let s_pos: forall a b, 0 <= s a b.
 Proof.
  intros; unfold s; left; apply exp_pos.
 Qed.

 Variable dummy:B.

 Definition exp_antimon: A -> Distr (B).
  intro a.
  refine (@finite_discr _ _ s Out _ s_pos dummy a).
  destruct Out_spec as [ (b,Hb) | HOut ].
    left; exists b; split; [ trivial | intros; apply exp_pos ].
    right; subst; trivial.
 Defined.

 Lemma exp_antimon_is_Discr: forall a,
   is_Discrete (exp_antimon a).
 Proof.
  intro a; apply (finite_discr_is_Discrete _ _ dummy).
 Qed.

 Lemma exp_antimon_lossless:  forall a,
   mu (exp_antimon a) (fun _ => 1%U) == 1%U.
 Proof.
  intros; apply finite_discr_lossless.
 Qed.

 Variable eqU: B -> B -O-> U.
 Hypothesis eqU_spec: forall b:B, cover (eq b) (eqU b).

 Hypothesis Hdec: forall (b:B), {List.In b Out} + {~ List.In b Out}.
 Hypothesis Out_NoDup: NoDup Out.

 Variables a a':A.
 Variables M:R.
 Hypothesis HM: forall b, List.In b Out -> R_dist (f a b) (f a' b) <= M.
 Hypothesis M_pos: 0 <= M.

 Lemma exp_antimon_dist:
  let d1 := exp_antimon a in
  let d2 := exp_antimon a' in
  let lam := exp (2 * eps * M) in
  le_dist d1 d2 lam D0.
 Proof.
  intros.
  apply le_dist_weaken_lam with (exp (eps * M) * exp (eps * M)).
    split; [ left; apply Rmult_lt_0_compat; apply exp_pos |
      unfold lam; rewrite Rmult_assoc, double, exp_plus; trivial ].
  refine (@finite_discr_symm_dist _ _ s Out _ s_pos dummy _ eqU_spec
    Hdec Out_NoDup _ _ _ _ _ _ _).
    intros b Hb; unfold s.
    rewrite <-exp_plus; apply exp_monotonic.
    replace (eps * M + - eps * f a' b) with (eps * (M - f a' b)) by ring.
    replace (- eps * f a b) with (eps * (- f a b)) by ring.
    refine (Rmult_le_compat_l _ _ _ eps_pos _); apply Rplus_le_perm_right.
    rewrite Rplus_comm, <-(HM Hb), R_dist_sym; apply Rle_abs.
    intros b Hb; unfold s.
    rewrite <-exp_plus; apply exp_monotonic.
    replace (eps * M + - eps * f a b) with (eps * (M - f a b)) by ring.
    replace (- eps * f a' b) with (eps * (- f a' b)) by ring.
    refine (Rmult_le_compat_l _ _ _ eps_pos _); apply Rplus_le_perm_right.
    rewrite Rplus_comm, <-(HM Hb); apply Rle_abs.
    left; apply exp_pos.
    rewrite <-exp_0 at 1; apply exp_monotonic; apply Rmult_le_pos; trivial.
 Qed.

End Finite_Exp_Antimonot.

(* *********************************************************************** *)
(*         3.Two exponential distributions over a quasimetric space        *)
(* *********************************************************************** *)

(* Finite set equipped with a quasi-metric
   --ie we do not require symmetry-- *)
Module Type FiniteQuasiMetricSpace.

 Declare Module E : UsualDecidableType.
 Declare Module Set_of_E : WSetsOn E.

 (* QuasiMetric specification *)
 Parameter Delta : E.t -> E.t -> R.
 Hypothesis Delta_pos: forall (x1 x2:E.t), 0 <= Delta x1 x2.
 Hypothesis Delta_triang: forall (x1 x2 x3:E.t),
   Delta x1 x3  <= Delta x1 x2 + Delta x2 x3.
 Hypothesis Delta_eq: forall (x:E.t), Delta x x = 0.

 (* Diameter of the QuasiMetric *)
 Parameter Diameter : R.
 Hypothesis Diam_spec: forall (x1 x2:E.t),
   Delta x1 x2 <= Diameter.

 (* Distance between a point [x] and a set of points [F] *)
 Definition DeltaSet (x:E.t) (F:Set_of_E.t) :=
   Set_of_E.fold (fun p r => Rmin r (Delta p x)) F Diameter.

 Lemma DeltaSet_Bound: forall d F,
   0 <= DeltaSet d F <= Diameter.
 Proof.
  intros.
  unfold DeltaSet; rewrite Set_of_E.fold_spec; unfold Basics.flip.
  rewrite <-fold_left_rev_right.
  induction (rev (Set_of_E.elements F)).
    simpl; split.
    rewrite <-(Delta_eq d); apply Diam_spec.
    trivial.
    destruct IHl; simpl; split.
      apply Rmin_glb; [trivial | apply Delta_pos].
      rewrite Rmin_r; apply Diam_spec.
 Qed.

 Parameter compl: Set_of_E.t -> Set_of_E.t.
 Hypothesis compl_spec : forall (p:E.t) (X:Set_of_E.t),
   Set_of_E.In p (compl X) <-> ~  Set_of_E.In p X.

 Parameter Set_of_E_eqb:  Set_of_E.t -> Set_of_E.t -> bool.
 Hypothesis Set_of_E_eqb_spec: forall X1 X2,
   if  Set_of_E_eqb X1 X2 then X1 = X2 else X1 <> X2.

End FiniteQuasiMetricSpace.

(* Extension of a quasimetric with a notion of
   distance from a set wrt another, and definition
   of two distributions on top of this notion *)
Module QMetricExtension (M: FiniteQuasiMetricSpace).

 Export M.

 (* Distance of [D] wrt [F] *)
 Definition cost (F D: Set_of_E.t) :=
   fold_right Rplus 0 (map (fun p => DeltaSet p F) (Set_of_E.elements D)).

 (* Sets adjacency *)
 Definition adj_sets (X Y:Set_of_E.t) :=
   exists Z, exists x, exists y,
   X = (Set_of_E.add x Z) /\ Y = (Set_of_E.add y Z)
   /\ ~ Set_of_E.mem x Z /\  ~ Set_of_E.mem y Z.

 (* Sensitivity of the [cost] function *)
 Lemma cost_sensitivity: forall (F D1 D2: Set_of_E.t),
   adj_sets D1 D2 ->
   R_dist (cost F D1) (cost F D2) <= Diameter.
 Proof.
   intros F D1 D2 (D,(d1,(d2,(?,(?,(H1,H2)))))); subst; unfold cost.
   match goal with
   |- R_dist (fold_right Rplus 0 ?l1') (fold_right Rplus 0 ?l2') <= _ =>
     rewrite fold_right_Perm with (l1:=l1')
       (l2:=map (fun p : E.t => DeltaSet p F) (d1 :: Set_of_E.elements D)); [
     rewrite fold_right_Perm with (l1:=l2')
       (l2:=map (fun p : E.t => DeltaSet p F) (d2 :: Set_of_E.elements D)) | | ]
   end.
   simpl; rewrite R_dist_plus, R_dist_eq, Rplus_0_r.
   apply R_dist_le; apply DeltaSet_Bound.
   intros; ring.
   apply PermutP_map, PermutP_sym, PermutP_map.
   apply PermutP_weaken with eq; [ intros; subst; trivial | ].
   apply Permutation_PermutP, NoDup_Permutation.
     apply NoDup_cons.
       unfold is_true in H2; rewrite Set_of_E.mem_spec, <-Set_of_E.elements_spec1 in H2;
       intro H; apply H2; apply (In_InA E.eq_equiv H).
       apply (NoDupA_NoDup (Set_of_E.elements_spec2w _)).
     apply (NoDupA_NoDup (Set_of_E.elements_spec2w _)).
     intros; rewrite <- 2 InA_In.
     rewrite InA_cons, (Set_of_E.elements_spec1 D x),
       <-Set_of_E.add_spec, Set_of_E.elements_spec1; apply iff_refl.
   intros; ring.
   apply PermutP_map, PermutP_sym, PermutP_map.
   apply PermutP_weaken with eq; [ intros; subst; trivial | ].
   apply Permutation_PermutP, NoDup_Permutation.
     apply NoDup_cons.
       unfold is_true in H1; rewrite Set_of_E.mem_spec, <-Set_of_E.elements_spec1 in H1;
       intro H; apply H1; apply (In_InA E.eq_equiv H).
       apply (NoDupA_NoDup (Set_of_E.elements_spec2w _)).
     apply (NoDupA_NoDup (Set_of_E.elements_spec2w _)).
     intros; rewrite <- 2 InA_In.
     rewrite InA_cons, (Set_of_E.elements_spec1 D x),
       <-Set_of_E.add_spec, Set_of_E.elements_spec1; apply iff_refl.
 Qed.

 (* Specification of WSetOn seems incomplete *)
 Hypothesis Empty_elements: forall X,
   Set_of_E.Empty X -> Set_of_E.elements X = List.nil.

 Hypothesis is_empty_dec: forall (X:Set_of_E.t),
   {x:E.t | Set_of_E.In x X} + {Set_of_E.Empty X}.

 Parameter dummy: E.t.

 (* Pick an element [(x1,x2) in X1 x X2] with probability
    proportional to [exp (-eps * cost (F - {x1} + {x2}, D))] *)
 Definition pick_points (F D X1 X2: Set_of_E.t) (eps:R): Distr (E.t * E.t).
  intros.
  set (f := fun D' x => cost (Set_of_E.add (snd x) (Set_of_E.remove (fst x) F)) D').
  set (Out := list_prod (Set_of_E.elements X1) (Set_of_E.elements X2)).
  refine (@exp_antimon Set_of_E.t (E.t * E.t) eps f Out _ (dummy,dummy) D).
  unfold Out.
  destruct (is_empty_dec X1) as [ (x1,HX1) | HX1 ];
    [ | right; rewrite (Empty_elements HX1); simpl; trivial ].
  destruct (is_empty_dec X2) as [ (x2,HX2) | HX2 ];
    [ | right; rewrite (Empty_elements HX2) ;
      induction (Set_of_E.elements X1); simpl; trivial ].
  left; exists (x1,x2); rewrite in_prod_iff;
    rewrite <-Set_of_E.elements_spec1, InA_In in *; split; trivial.
 Defined.

 Parameter eqU: E.t -> E.t -O-> U.
 Hypothesis eqU_spec: forall a:E.t, cover (eq a) (eqU a).

 Lemma pick_points_distance: forall (F D1 D2 X1 X2: Set_of_E.t) (eps:R),
   0 <= eps ->
   adj_sets D1 D2 ->
   let d1 := pick_points F D1 X1 X2 eps in
   let d2 := pick_points F D2 X1 X2 eps in
   let lam := exp (2 * eps * Diameter) in
   le_dist d1 d2 lam D0.
 Proof.
  intros.
  refine (@exp_antimon_dist _ _ _  H _ _ _ (dummy,dummy) _
    (cover_eq_prod _ _ eqU_spec eqU_spec) _ _ _ _ _ _ _).
    intro; apply (in_dec (prod_dec E.eq_dec E.eq_dec)).
    apply NoDup_list_prod; apply NoDupA_NoDup;
      apply Set_of_E.elements_spec2w.
    intros; apply (cost_sensitivity _ H0).
    rewrite <-(Diam_spec dummy dummy), <-Delta_pos; trivial.
 Qed.

 (* Pick an index [i in [0...N-1]] with probability
    proportional to [exp (-exp * cost (F i, D))] *)
 Definition pick_index (D:Set_of_E.t) (F:nat -> Set_of_E.t) (N:nat) (eps:R): Distr (nat).
  intros.
  set (f:= fun D' i => cost (F i) D').
  set (Out := seq 0 N).
  refine (@exp_antimon (@Set_of_E.t) nat eps f Out _ 0%nat D).
  unfold Out; destruct (zerop N); [ right; subst; trivial |
    left; exists 0%nat; apply le_In_seq; split; omega ].
 Defined.

 Lemma pick_index_distance: forall (D1 D2:Set_of_E.t) (F:nat -> Set_of_E.t)
   (N:nat) (eps:R),
   0 <= eps ->
   adj_sets D1 D2 ->
   let d1 := pick_index D1 F N eps in
   let d2 := pick_index D2 F N eps in
   let lam := exp (2 * eps * Diameter) in
   le_dist d1 d2 lam D0.
 Proof.
  intros.
  refine (@exp_antimon_dist _ _ _  H _ _ _ (0%nat) _
    (fun b =>  cover_dec (eq_nat_dec b)) _ _ _ _ _ _ _).
    intro b; case_eq (leb N b); intro Heq.
      apply leb_complete in Heq; right; intro H'; apply In_seq_le in H'; omega.
      apply leb_complete_conv in Heq; left; apply le_In_seq; split; omega.
    apply NoDup_seq.
    intros; apply (cost_sensitivity _ H0).
    rewrite <-(Diam_spec dummy dummy), <-Delta_pos; trivial.
 Qed.

End QMetricExtension.


Require Import Decidable.

Require Import Predicate DemonicComposition DemonicJoin Specification Statement LeastFixpoint Predicative.

Open Scope stmt_scope.

Definition old_pred { T V : Type } := @pred T V.

Fixpoint  pred_seq { T U V: Type } (C : @Stmt T U) (spec : U >> V)
: T >> V :=
  match C in (@Stmt _ UU) return (forall (spec : UU >> V), T >> V) with
  | Void => fun spec s s' => False
  | Assignment effect => fun spec (s : T) (s' : V) => spec (effect s) s'
  | Seq cb ca => fun spec => pred_seq cb (pred_seq ca spec)
  | If p ct cf => fun spec s s' => (p s /\ pred_seq ct spec s s') \/ (~ p s /\ pred_seq cf spec s s')
  | While p cw => fun spec => (while p (pred_seq cw (fun s s' => s = s'))) ⊟ spec
  | Spec call_spec => fun spec => call_spec ⊟ spec
  | WWhen p Then cw End => fun spec s s' => (p s /\ pred_seq cw spec s s')
  | c1 ⫾ c2 => fun spec => (pred_seq c1 spec) ⊔ (pred_seq c2 spec)
  end spec.

Fixpoint pred_opt { T V : Type } (C : @Stmt T V) : T >> V :=
  match C with
  | Void => fun s s' => False
  | Assignment effect => fun s s' => effect s = s'
  | Seq c1 c2 => pred_seq c1 (pred_opt c2)
  | If p ct cf => fun s s' => (p s /\ pred_opt ct s s') \/ (~ p s /\ pred_opt cf s s')
  | While p c => while p (pred_opt c)
  | Spec spec => spec
  | WWhen p Then cw End => fun s s' => (p s /\ pred_opt cw s s')
  | c1 ⫾ c2 => (pred_opt c1) ⊔ (pred_opt c2)
  end.

Lemma pred_opt_pred_seq : forall { T U : Type } (c1 : @Stmt T U) V (c2 : @Stmt U V) s s',
    pred_seq c1 (pred_opt c2) s s' <-> ((pred_opt c1) ⊟ (pred_opt c2)) s s'.
Proof.
  intros T U c1.
  induction c1 as [ | T U effect | T U1 U2 cc1 IHcc1 cc2 IHcc2 | T U p ct IHct cf IHcf | T p cw IHcw | T call_spec | | ]; simpl.
 { intros c2 s s'; split; intros HH.
    { contradiction. }
    { destruct HH as [[sx [HH _]] _ ]; auto. }
  }
  { intros V c2 s s';  split; intros HH.
    { split.
      { exists (effect s); auto. }
      { intros sx HH1; subst sx; eauto. }
    }
    { destruct HH as [[sx [HHeql HHpred]] HH]; rewrite HHeql; exact HHpred. }
  }
  { intros V c2 s s'.
    rewrite (DemonicComposition.left_extensionality _ _ _ (IHcc1 _ _)).
    rewrite (IHcc1 _ (Statement.Seq cc2 c2)); simpl.
    rewrite (DemonicComposition.right_extensionality _ _ _ (IHcc2 _ _)).
    split; intros HH; apply DemonicComposition.assoc; auto.
  }
  { intros V c2 s s'; rewrite (IHcf _ _), (IHct _ _).
    split.
    { intros [ [HH1 [[sx [HH2 HH3]] HH4]] | [HH1 [[sx [HH2 HH3]] HH4]] ].
      { split; firstorder. }
      { split.
        { exists sx; split; auto. }
        { firstorder. }
      }
    }
    { intros [[sx [[[HH1 HH2] | [HH1 HH2]] HH3]] HH4].
      { left; split; auto; split; firstorder. }
      { right; split; auto; split; firstorder. }
    }
  }
  { intros V c2 s s'; apply DemonicComposition.left_extensionality.
    intros r r'. apply while_extensionality.
    { reflexivity. }
    { clear s s' r r'; intros.
      rewrite (IHcw _ (Spec (fun s s' => s = s'))); simpl.
      rewrite DemonicComposition.right_identity_neutrality.
      reflexivity.
    }
  }
  { reflexivity. }
  { intros; rewrite IHc1; simpl.
    firstorder.
  }
  { intros.
    rewrite DemonicComposition.ldistr_join.
    apply DemonicJoin.ext; auto.
  }
Qed.

Theorem pred_opt_IFF_old_pred : forall { T V : Type } (c : @Stmt T V) s s', old_pred c s s' <-> pred_opt c s s'.
Proof.
  induction c as [ | T U effect | T U1 U2 c1 IHc1 c2 IHc2 | T U p ct IHct cf IHcf | T p cw IHcw | T call_spec | | ]
  ; simpl; try reflexivity.
  { intros s s'; split; intros HHpred.
    { destruct HHpred as [[sx [HHpred1 HHpred2]] HHpred3].
      apply pred_opt_pred_seq; split.
      { exists sx; split; firstorder. }
      { intros sy HH1.
        rewrite <- (IHc1 _) in HH1.
        destruct (HHpred3 _ HH1) as (sy',HH2).
        exists sy'; apply IHc2; auto.
      }
    }
    { apply pred_opt_pred_seq in HHpred.
      apply (DemonicComposition.extensionality _ _ _ _ IHc1 IHc2); auto.
    }
  }
  { intros s s'; rewrite IHct,IHcf; reflexivity. }
  { apply while_extensionality; auto; reflexivity. }
  { intros; rewrite IHc; firstorder. }
  { intros; apply DemonicJoin.ext; auto. }
Qed.

Definition old_while { T : Type } := @Predicative.while T.

Definition while { T : Type } (C : @Predicate T) P := lfp (fun X s s' => (C s /\ pred_seq P X s s') \/ (~ C s /\ s = s')).

Theorem old_while_while : forall { T : Type } (C : @Predicate T) P s s', old_while C (pred_opt P) s s' <-> while C P s s'.
Proof.
  intros S C P s s'.
  unfold old_while,while,while_functional.
  apply lfp_extensionality.
  clear s s'; intros X s s'.
  rewrite (pred_opt_pred_seq _ _ (Spec X)).
  simpl.
  reflexivity.
Qed.

Fixpoint pred { T V : Type } (C : @Stmt T V) : Specification :=
  match C with
  | Void => fun s s' => False
  | Assignment effect => fun s s' => effect s = s'
  | Seq c1 c2 => pred_seq c1 (pred_opt c2)
  | If p ct cf => fun s s' => (p s /\ pred_opt ct s s') \/ (~ p s /\ pred_opt cf s s')
  | While p c => while p c
  | Spec spec => spec
  | WWhen p Then cw End => fun s s' => (p s /\ pred_opt cw s s')
  | c1 ⫾ c2 => (pred_opt c1) ⊔ (pred_opt c2)
  end.

Lemma pred_pred_opt : forall { T V : Type } (C : @Stmt T V), forall s s', pred C s s' <-> pred_opt C s s'.
Proof.
  intros T V C s s'.
  destruct C; simpl in *; try reflexivity.
  rewrite old_while_while.
  reflexivity.
Qed.

Theorem pred_old_pred : forall { T V : Type } (C : @Stmt T V), forall s s', pred C s s' <-> old_pred C s s'.
  intros T V C s s'.
  apply (iff_trans (pred_pred_opt C s s')).
  apply iff_sym.
  apply pred_opt_IFF_old_pred.
Qed.

Theorem while_end : forall (T V : Type) (C : @Predicate T) P s s', while C P s s' -> ~ C s'.
Proof.
  intros T V C P s s'.
  rewrite <- old_while_while.
  apply Predicative.while_end.
Qed.

Theorem while_destruct : forall { T : Type } (C : @Predicate T) P s s',
    while C P s s' -> (C s /\ (pred_seq P (while C P)) s s') \/ (~ C s /\ s = s').
Proof.
  intros T C P s s'.
  rewrite <- old_while_while.
  rewrite (pred_opt_pred_seq P _ (Statement.Spec (while C P))); simpl.
  rewrite (DemonicComposition.extensionality (pred_opt P) (pred_opt P) (while C P) (old_while C (pred_opt P))); try reflexivity.
  { apply Predicative.while_destruct. }
  { clear s s'.
    intros s s'; rewrite old_while_while; reflexivity.
  }
Qed.

Theorem while_construct : forall { T : Type } (C : @Predicate T) P s s',
    (C s /\ (pred_seq P (while C P)) s s') \/ (~ C s /\ s = s') -> while C P s s'.
Proof.
  intros T C P s s'.
  rewrite <- old_while_while.
  rewrite (pred_opt_pred_seq P _ (Statement.Spec (while C P))); simpl.
  rewrite (DemonicComposition.extensionality (pred_opt P) (pred_opt P) (while C P) (old_while C (pred_opt P))); try reflexivity.
  { apply Predicative.while_construct. }
  { clear s s'.
    intros s s'; rewrite old_while_while; reflexivity.
  }
Qed.

Theorem while_fix : forall { T : Type } (C : @Predicate T) P s s', while C P s s' <-> (C s /\ (pred_seq P (while C P)) s s') \/ (~ C s /\ s = s').
Proof.
  intros T C P s s'.
  rewrite <- old_while_while.
  rewrite (pred_opt_pred_seq P _ (Statement.Spec (while C P))); simpl.
  rewrite (DemonicComposition.extensionality (pred_opt P) (pred_opt P) (while C P) (old_while C (pred_opt P))); try reflexivity.
  { apply Predicative.while_fix. }
  { clear s s'.
    intros s s'; rewrite old_while_while; reflexivity.
  }
Qed.

Theorem while_ind : forall { T : Type } (C : @Predicate T) P X s s',
    while C P s s' -> (forall s s', ((C s /\ (pred_seq P X) s s') \/ (~ C s /\ s = s')) -> X s s') -> X s s'.
Proof.
  intros T C P X s s' HHwhile HH.
  eapply (f_lfp _ _ _ _ _ HHwhile).
  Unshelve.
  auto.
Qed.

Theorem ex_while_ind : forall { T : Type } (C : @Predicate T) P (X : Predicate) s,
    (exists s', while C P s s') -> (forall s, ((C s /\ (forall sx, (pred P s sx -> X sx)) \/ (~ C s)) -> X s)) -> X s.
Proof.
  intros T C P X s (s',HHwhile).
  pattern s,s'; apply HHwhile.
  intros.
  apply H0.
  destruct H.
  { destruct H. left; split; auto.
    rewrite (pred_opt_pred_seq
               P _ (Statement.Spec (fun s _ : T => (forall s1 : T, C s1 /\ (forall sx : T, pred P s1 sx -> X sx) \/ ~ C s1 -> X s1) -> X s))) in H1.
    destruct H1.
    intros.
    rewrite pred_pred_opt in H3.
    destruct (H2 _ H3).
    apply H4.
    auto.
  }
  { right; firstorder. }
Qed.

Theorem while_well_founded : forall { T : Type } (p : @Predicate T) C,
    well_founded (fun s s' => p s' /\ (pred C) s' s /\ (exists r, (while p C) s' r)).
Proof.
  intros T p C.
  constructor.
  intros y [HHp [HHpred HHwhile]].
  generalize y HHp HHpred; clear y HHp HHpred.
  pattern a; apply (ex_while_ind _ _ _ _ HHwhile).
  intros.
  destruct H; try contradiction.
  destruct H.
  constructor; intros.
  destruct H1.
  destruct H2.
  apply (H0 y); auto.
Qed.

Lemma wfd_prefix_while : forall { T : Type } (C : @Predicate T) P (K : Specification),
    well_founded (fun s s' => C s' /\ pred P s' s)
    -> (forall s s', K s s' -> ((C s /\ pred_seq P K s s') \/ (~ C s /\ s = s')))
    -> forall s s', K s s' -> while C P s s'.
Proof.
  intros T C P K HHwfd HHT1 s.
  pattern s; apply (well_founded_ind HHwfd).
  intros sx HH s' HHT.
  pose proof (HHT1 _ _ HHT).
  rewrite (pred_opt_pred_seq _ _ (Statement.Spec K)) in H.
  destruct H as [(HHc,((sy,(HH11,HH12)),HH13)) | HH2]; simpl in *.
  { apply while_construct; left; split; auto.
    rewrite (pred_opt_pred_seq _ _ (Statement.Spec (while C P))).
    split; simpl; auto.
    { exists sy; split; auto.
      apply HH; auto; split; auto.
      apply pred_pred_opt; auto.
    }
    { intros sz HHp2.
      pose proof (HH13 _ HHp2) as (sz',HHT2).
      exists sz'.
      apply HH; auto; split; auto.
      apply pred_pred_opt; auto.
    }
  }
  { apply while_construct; right; auto. }
Qed.

Theorem wfd_fix_while : forall { T : Type } (C : @Predicate T) P (K : Specification),
    well_founded (fun s s' => C s' /\ pred P s' s)
    -> (forall s s', K s s' <-> ((C s /\ pred_seq P K s s') \/ (~ C s /\ s = s')))
    -> forall s s', while C P s s' <-> K s s'.
Proof.
  intros T C P K HHwfd HHT s s'.
  split.
  { intros HHwhile.
    apply (while_ind _ _ _ _ _ HHwhile).
    apply HHT.
  }
  { apply wfd_prefix_while; auto.
    apply HHT.
  }
Qed.

Theorem while_extensionality :
  forall { T : Type } (C1 : @Predicate T) P1 C2 P2,
    (forall s, C1 s <-> C2 s) -> (forall s s', pred P1 s s' <-> pred P2 s s') -> forall s s', while C1 P1 s s' <-> while C2 P2 s s'.
Proof.
  intros T C1 P1 C2 P2 HHequiv1 HHequiv2 s s'.
  assert ( forall s s' : T, pred_opt P1 s s' <-> pred_opt P2 s s') as HHequiv2'.
  { clear HHequiv1 s s'.
    intros s s'.
    repeat rewrite <- pred_pred_opt.
    auto.
  }
  clear HHequiv2.
  unfold while.
  apply lfp_extensionality.
  clear s s'.
  unfold while_functional.
  intros X s s'.
  rewrite HHequiv1.
  repeat rewrite (pred_opt_pred_seq _ _ (Statement.Spec X)).
  rewrite (DemonicComposition.left_extensionality _ _ _ HHequiv2').
  reflexivity.
Qed.

Definition old_refines { T V : Type } := @refines T V.

Definition refines { T V : Type } (S1 S2 : @Stmt T V) :=
  forall s, (exists s', pred S2 s s') -> (forall s', pred S1 s s' -> pred S2 s s') /\ (exists s', pred S1 s s').

Lemma refines_old_refines : forall T V (C1 C2 : @Stmt T V), old_refines C1 C2 <-> refines C1 C2.
Proof.
  unfold old_refines, refines.
  intros S C1 C2.
  split; intros HHrefines.
  { intros s (t',HHc2).
    apply pred_old_pred in HHc2.
    destruct (HHrefines _ (ex_intro _ _ HHc2)) as (HHc1c2,(u',HHc1)).
    split.
    { intros s'; repeat rewrite pred_old_pred; apply HHc1c2. }
    { exists u'; rewrite pred_old_pred; exact HHc1. }
  }
  { intros s (t',HHc2).
    apply pred_old_pred in HHc2.
    destruct (HHrefines _ (ex_intro _ _ HHc2)) as (HHc1c2,(u',HHc1)).
    split.
    { intros s'; repeat rewrite <- pred_old_pred; apply HHc1c2. }
    { exists u'; rewrite <- pred_old_pred; exact HHc1. }
  }
Qed.

Notation "C1 ⊑ C2" := (refines C1 C2) (at level 60, format "C1  ⊑  C2").

Theorem if_extensionality :
  forall { T : Type } (C1 : @Predicate T) (P1 : @Stmt T T) C2 (P2 : @Stmt T T),
    (forall s, C1 s <-> C2 s) -> (forall s s', pred P1 s s' <-> pred P2 s s') -> forall s s', pred (IIf C1 Then P1 End) s s' <-> pred (IIf C2 Then P2 End) s s'.

Proof.
  intros T C1 P1 C2 P2 HHequiv1 HHequiv2 s s'.
  simpl. repeat rewrite <- pred_pred_opt.
  rewrite HHequiv1,HHequiv2.
  reflexivity.
Qed.

Theorem wfd_while_iff_if : forall { T : Type } (C : @Predicate T) P,
    well_founded (fun s s' => C s' /\ pred P s' s /\ C s)
    -> (⟨fun s s' => C s /\ pred P s s'⟩;⟨fun s s' => C s /\ pred P s s' \/ ~ C s /\ s = s'⟩) ⊑ ⟨fun s s' => C s /\ pred P s s'⟩
    -> forall s s', while C P s s' <-> pred (IIf C Then P End) s s' /\ ~ C s'.
Proof.
  intros T C P HHwfd HHrefines s s'.
  rewrite <- old_while_while.
  rewrite <- (Predicative.while_extensionality C (pred P) C (pred_opt P)); try reflexivity.
  { rewrite <- (if_extensionality C ⟨pred P⟩ C ); try reflexivity.
    apply Predicative.wfd_while_iff_if; auto.
  }
  { apply pred_pred_opt. }
Qed.

Theorem wfd_while_iff_if' : forall { T : Type } (C : @Predicate T) P,
    well_founded (fun s s' => C s' /\ pred P s' s /\ C s)
    -> (forall s s', C s /\ pred P s s' ->
               (forall sx, (C s' /\ pred P s' sx \/ ~ C s' /\ s' = sx) -> pred P s sx)
               /\ (C s' /\ (exists sx, pred P s' sx) \/ ~ C s'))
    -> forall s s', while C P s s' <-> pred (IIf C Then P End) s s' /\ ~ C s'.
Proof.
  intros T C P HHwfd HHrefines s s'.
  rewrite <- old_while_while.
  rewrite <- (Predicative.while_extensionality C (pred P) C (pred_opt P)); try reflexivity.
  { rewrite <- (if_extensionality C ⟨pred P⟩ C ); try reflexivity.
    apply Predicative.wfd_while_iff_if'; simpl; auto; apply HHrefines.
  }
  { apply pred_pred_opt. }
Qed.

Theorem wfd_while_refines_if : forall { T : Type } (C : @Predicate T) P,
    well_founded (fun s s' => C s' /\ pred P s' s /\ C s)
    -> (⟨fun s s' => C s /\ pred P s s'⟩;⟨fun s s' => C s /\ pred P s s' \/ ~ C s /\ s = s'⟩) ⊑ ⟨fun s s' => C s /\ pred P s s'⟩
    -> WWhile C Do P Done ⊑ IIf C Then ⟨fun s s' => pred P s s' /\ ~ C s'⟩ End.
Proof.
  intros * HHwfd HHrefines.
  unfold refines; simpl.
  intros * (s'',HHtrm).
  split.
  { intros s'.
    rewrite (wfd_while_iff_if _ _ HHwfd HHrefines).
    simpl.
    rewrite <- pred_pred_opt.
    clear.
    firstorder.
  }
  { exists s''.
    rewrite (wfd_while_iff_if _ _ HHwfd HHrefines).
    simpl.
    rewrite <- pred_pred_opt.
    destruct HHtrm.
    { firstorder. }
    { destruct H; subst s''; firstorder. }
  }
Qed.

Theorem wfd_while_refines_if' : forall { T : Type } (C : @Predicate T) P,
    well_founded (fun s s' => C s' /\ pred P s' s /\ C s)
    -> (forall s s', C s /\ pred P s s' ->
               (forall sx, (C s' /\ pred P s' sx \/ ~ C s' /\ s' = sx) -> pred P s sx)
               /\ (C s' /\ (exists sx, pred P s' sx) \/ ~ C s'))
    -> WWhile C Do P Done ⊑ IIf C Then ⟨fun s s' => pred P s s' /\ ~ C s'⟩ End.
Proof.
  intros * HHwfd HHrefines.
  unfold refines; simpl.
  intros * (s'',HHtrm).
  split.
  { intros s'.
    rewrite (wfd_while_iff_if' _ _ HHwfd HHrefines).
    simpl.
    rewrite <- pred_pred_opt.
    clear.
    firstorder.
  }
  { exists s''.
    rewrite (wfd_while_iff_if' _ _ HHwfd HHrefines).
    simpl.
    rewrite <- pred_pred_opt.
    destruct HHtrm.
    { firstorder. }
    { destruct H; subst s''; firstorder. }
  }
Qed.

Theorem if_refines_wfd_while : forall { T : Type } (C : @Predicate T) P,
    well_founded (fun s s' => C s' /\ pred P s' s /\ C s)
    -> (⟨fun s s' => C s /\ pred P s s'⟩;⟨fun s s' => C s /\ pred P s s' \/ ~ C s /\ s = s'⟩) ⊑ ⟨fun s s' => C s /\ pred P s s'⟩
    -> IIf C Then ⟨fun s s' => pred P s s' /\ ~ C s'⟩ End ⊑ WWhile C Do P Done.
Proof.
  intros * HHwfd HHrefines.
  unfold refines; simpl.
  intros * (s'',HHtrm).
  split.
  { intros s'.
    rewrite (wfd_while_iff_if _ _ HHwfd HHrefines).
    simpl.
    rewrite <- pred_pred_opt.
    intros [HHpred | HHskip].
    { firstorder. }
    { destruct HHskip; subst s'.
      clear - H.
      firstorder.
    }
  }
  { exists s''.
    rewrite (wfd_while_iff_if _ _ HHwfd HHrefines) in HHtrm.
    simpl in HHtrm.
    rewrite <- pred_pred_opt in HHtrm.
    destruct HHtrm as ([ HHtrm | (HHc,HHeq) ], HHc').
    { firstorder. }
    { subst s''; firstorder. }
  }
Qed.

Require Import Wfd.

Theorem while_rule_sound_and_complete : forall { T : Type } (C : @Predicate T) P R,
    WWhile C Do P Done ⊑ R
    <-> exists K, P ⊑ K
           /\ well_founded (fun s s' => C s' /\ pred K s' s /\ C s)
           /\ (⟨fun s s' => C s /\ pred K s s'⟩;⟨fun s s' => C s /\ pred K s s' \/ ~ C s /\ s = s'⟩) ⊑ ⟨fun s s' => C s /\ pred K s s'⟩
           /\ IIf C Then ⟨fun s s' => pred K s s' /\ ~ C s'⟩ End ⊑ R.
Proof.
  intros *.
  repeat setoid_rewrite <- refines_old_refines.
  split; intros.
  { apply while_rule_sound_and_complete in H.
    unfold old_refines in *; simpl.
    destruct H as (K,(H1,(H2,(H3,H4)))).
    exists K.
    split.
    { auto. }
    { split.
      { apply (Wfd.by_inclusion _ _ _ H2).
        setoid_rewrite pred_old_pred; unfold old_pred; simpl.
        auto.
      }
      { unfold Predicative.refines in *; simpl in *.
        unfold DemonicComposition.fn in *.
        repeat setoid_rewrite (pred_old_pred K); unfold old_pred.
        auto.
      }
    }
  }
  { apply while_rule_sound_and_complete.
    unfold old_refines in *; simpl.
    destruct H as (K,(H1,(H2,H3))).
    exists K.
    split; auto.
    { split.
      { apply (Wfd.by_inclusion _ _ _ H2).
        setoid_rewrite pred_old_pred; unfold old_pred; simpl.
        auto.
      }
      { unfold Predicative.refines in *; simpl in *.
        unfold DemonicComposition.fn in *.
        repeat setoid_rewrite (pred_old_pred K) in H3; unfold old_pred.
        auto.
      }
    }
  }
Qed.

Theorem refines_reflexive : forall (T V : Type)  (P : @Stmt T V), refines P P.
Proof.
  intros T V P.
  rewrite <- refines_old_refines.
  apply refines_reflexive.
Qed.

Theorem refines_trans : forall (T V : Type)  (P Q R : @Stmt T V), refines P Q -> refines Q R -> refines P R.
Proof.
  intros T V P Q R.
  repeat rewrite <- refines_old_refines.
  apply refines_trans.
Qed.

Theorem Seq_left_monotonic_refines :
  forall (T U V : Type) (P1 P2 : @Stmt T U) (Q : @Stmt U V), refines P1 P2 -> refines (Seq P1 Q) (Seq P2 Q).
Proof.
  intros T U V P1 P2 Q.
  repeat rewrite <- refines_old_refines.
  apply Seq_left_monotonic_refines.
Qed.

Theorem Seq_right_monotonic_refines :
  forall (T U V : Type) (P : @Stmt T U) (Q1 Q2 : @Stmt U V), refines Q1 Q2 -> refines (Seq P Q1) (Seq P Q2).
Proof.
  intros T U V P Q1 Q2.
  repeat rewrite <- refines_old_refines.
  apply Seq_right_monotonic_refines.
Qed.

Theorem Seq_monotonic_refines :
  forall (T U V : Type) (P1 : @Stmt T U) (P2 : @Stmt U V) (Q1 : @Stmt T U) (Q2 : @Stmt U V),
    refines P1 Q1
    -> refines P2 Q2
    -> refines (Seq P1 P2) (Seq Q1 Q2).
Proof.
  intros T U V P1 P2 Q1 Q2.
  repeat rewrite <- refines_old_refines.
  apply Seq_monotonic_refines.
Qed.

Theorem If_monotonic_refines :
  forall (T V : Type) C (Pt Qt Pf Qf : @Stmt T V),
    refines Pt Qt
    -> refines Pf Qf
    -> refines (If C Pt Pf) (If C Qt Qf).
Proof.
  intros T V C Pt Pf Qt Qf.
  repeat rewrite <- refines_old_refines.
  apply If_monotonic_refines.
Qed.

Theorem When_monotonic_refines :
  forall (T V : Type) C (P Q : @Stmt T V),
    refines P Q
    -> refines (WWhen C Then P End) (WWhen C Then Q End).
Proof.
  intros T V C P Q.
  repeat rewrite <- refines_old_refines.
  apply When_monotonic_refines.
Qed.

Theorem Choice_left_monotonic_refines :
  forall (T V : Type) (P1 P2 : @Stmt T V) (Q : @Stmt T V), refines P1 P2 -> refines (P1 ⫾ Q) (P2 ⫾ Q).
Proof.
  intros *; repeat rewrite <- refines_old_refines.
  apply Choice_left_monotonic_refines.
Qed.

Theorem Choice_right_monotonic_refines :
  forall (T V : Type) (P : @Stmt T V) (Q1 Q2 : @Stmt T V), refines Q1 Q2 -> refines (P ⫾ Q1) (P ⫾ Q2).
Proof.
  intros *; repeat rewrite <- refines_old_refines.
  apply Choice_right_monotonic_refines.
Qed.

Theorem Choice_monotonic_refines :
  forall (T V : Type) (P1 Q1 : @Stmt T V) (P2 Q2 : @Stmt T V),
    refines P1 Q1
    -> refines P2 Q2
    -> refines (P1 ⫾ P2) (Q1 ⫾ Q2).
Proof.
  intros *; repeat rewrite <- refines_old_refines.
  apply Choice_monotonic_refines.
Qed.

Theorem While_monotonic_refines :
  forall (T : Type) C (P Q : @Stmt T T),
    refines P Q
    -> refines (While C P) (While C Q).
Proof.
  intros T C P Q.
  repeat rewrite <- refines_old_refines.
  apply While_monotonic_refines.
Qed.

Theorem refines_extensionality_left : forall T V (P1 P2 Q : @Stmt T V), (forall s s', (pred P1) s s' <-> (pred P2) s s') -> refines P1 Q <-> refines P2 Q.
Proof.
  intros T V P1 P2 Q HHequiv.
  unfold refines; split.
  { intros HHsnd s HHq.
    split.
    { intros s''; rewrite <- HHequiv; apply (HHsnd _ HHq). }
    { destruct (HHsnd _ HHq) as (_,(s',HHp1)); exists s'; rewrite <- HHequiv; exact HHp1. }
  }
  { intros HHsnd s HHq.
    split.
    { intros s''; rewrite HHequiv; apply (HHsnd _ HHq). }
    { destruct (HHsnd _ HHq) as (_,(s',HHp2)); exists s'; rewrite HHequiv; exact HHp2. }
  }
Qed.

Theorem refines_extensionality_right : forall T V (P Q1 Q2 : @Stmt T V), (forall s s', (pred Q1) s s' <-> (pred Q2) s s') -> refines P Q1 <-> refines P Q2.
Proof.
  intros T V P Q1 Q2 HHequiv.
  unfold refines; split.
  { intros HHsnd s HHq.
    split.
    { intros s''; rewrite <- HHequiv; apply HHsnd.
      setoid_rewrite HHequiv; auto.
    }
    { apply HHsnd.
      setoid_rewrite HHequiv; auto.
    }
  }
  { intros HHsnd s HHq.
    split.
    { intros s''; rewrite HHequiv; apply HHsnd.
      setoid_rewrite <- HHequiv; auto.
    }
    { apply HHsnd; setoid_rewrite <- HHequiv; exact HHq. }
  }
Qed.

Theorem refines_extensionality : forall T V (P1 P2 Q1 Q2 : @Stmt T V),
    (forall s s', (pred P1) s s' <-> (pred P2) s s')
    -> (forall s s', (pred Q1) s s' <-> (pred Q2) s s')
    -> refines P1 Q1 <-> refines P2 Q2.
Proof.
  intros.
  assert (refines P1 Q1 <-> refines P1 Q2).
  { apply refines_extensionality_right; auto. }
  rewrite H1.
  apply refines_extensionality_left; auto.
Qed.

Close Scope stmt_scope.


Require Import Bauer.
Require Import List.
Require Import MSets Arith.
Require Import Coq.omega.Omega.
Require Import synth.

Import ListNotations.

(* We can make a set out of an ordered type *)

Definition instance := Graph.
Definition solution := S.t.

Definition metric := nat.
Definition eval := S.cardinal.
Definition better (m1 m2 : metric) := negb (m1 <? m2).

Definition verifier (I : instance) (S : solution) :=
S.For_all (fun v1 => S.For_all (fun v2 => ~ is_some (I v1 v2)) S) S.

Definition checker (I : instance) (S : solution) :=
S.for_all (fun v1 => S.for_all (fun v2 => negb (is_someb (E I v1 v2))) S) S.

Definition gen_space := fun I => all_subset (V I).

Definition max_Is_brute_force := synthesize instance solution metric checker eval better gen_space.

Compute S.elements (match max_Is_brute_force (K 10) with | None => S.empty | Some s => s end).

Definition algorithm f := forall (I : instance) (Sol Cand : solution),
  (f I = Some Sol -> verifier I Sol /\ ((verifier I Cand) -> better Sol Cand))
/\
  (f I = None -> ~exists Cand', verifier I Cand').

Check SF.for_all_1.
Print Proper.

Lemma vc_reflect : forall I Sol, reflect (verifier I Sol) (checker I Sol).
Proof.
intros.
apply iff_reflect. split.
- intros. unfold verifier in H. unfold checker.
Admitted.

Search reflect.

Lemma list_max_aux : forall {X : Type} f l (d : X),  In (list_max f (d::l) d) (d::l).
Proof.
intros. induction l.
- simpl. left. destruct (f d d). reflexivity. reflexivity.
- simpl. inversion IHl. destruct (f d d) eqn:h.
  + destruct (f d a) eqn:e.
    * right. left. simpl in H. rewrite h in H.
Qed.

Lemma list_max_aux2 : forall {X : Type} f l (d a m : X), f d a = true -> list_max f l a = m ->
list_max f l d = m.
Proof.
induction l.
- intros. simpl. simpl in H0. rewrite <- H0.
Qed.

Check equivalence.

Search (Set -> Prop).

Definition f_refl {X : Type} f := forall x : X, f x x = true.
Definition f_trans {X : Type} f := forall x y z : X, f x y = true -> f y z = true -> f x z = true.

Definition f_preorder {X : Type} (f : X -> X -> bool) := (f_refl f) /\ (f_trans f).

Lemma list_max_In : forall {X : Type} f l (d : X),
In (list_max f l d) (d::l).
Proof.
intros. generalize dependent d. induction l.
- simpl. left. reflexivity.
- intros. simpl. destruct (f d a) eqn:e.
  + simpl in IHl. pose (IHl a). inversion o.
    * right. left. exact H.
    * right. right. exact H.
  + simpl in IHl. pose (IHl d). inversion o.
    * left. exact H.
    * right. right. exact H.
Qed.

Lemma list_max_max : forall {X : Type} f l (d a : X), In a (d::l) ->
f a (list_max f l d) = true.
Proof.
Admitted.

Lemma all_subset_In : forall (I : instance) (S : solution), verifier I S -> In S (all_subset I).
Proof.
Admitted.

Check Nat.ltb_lt.

Theorem correct : algorithm brute_force.
Proof.
unfold algorithm.
split.
- intros. split.
  + unfold brute_force in H.
    destruct (map (fun iset : S.t => (metric iset, iset))
           (filter (checker I)
              (all_subset I))) eqn:e.
    * inversion H.
    * inversion H. assert (forall rs, In rs
    (map (fun iset : S.t => (metric iset, iset))
      (filter (checker I )
         (all_subset I))) -> verifier I (snd rs)).
    { intros. apply in_map_iff in H0. inversion H0. inversion H2. inversion H3.
      apply filter_In in H4. inversion H4. destruct (vc_reflect I x).
      - simpl. exact v.
      - inversion H7.
    }
    pose (list_max
          (fun e1 e2 : nat * S.t =>
           let (s1, _) := e1 in let (s2, _) := e2 in s1 <? s2) l p).
    apply (H0 p0). rewrite e. apply list_max_In.
  + unfold brute_force in H.
     destruct (map (fun iset : S.t => (metric iset, iset))
           (filter (checker I)
              (all_subset I))) eqn:e.
    * inversion H.
    * inversion H. unfold better. intros. remember (list_max
          (fun e1 e2 : nat * S.t =>
           let (s1, _) := e1 in let (s2, _) := e2 in s1 <? s2) l p) as m.
      assert (In (metric Cand, Cand) (p::l)).
      { pose (all_subset_In I Cand H0). Check iff. pose (filter_In (checker I) Cand (all_subset I)).
        inversion i0. destruct (vc_reflect I Cand).
        + assert (In Cand (all_subset I) /\ true = true). { split. exact i. reflexivity. }
          apply H3 in H4. pose (in_map_iff (fun iset : S.t => (metric iset, iset)) (filter (checker I) (all_subset I)) (metric Cand, Cand)).
          inversion i1. rewrite e in H6. apply H6. exists Cand. split.
          - reflexivity.
          - exact H4.
        + exfalso. unfold not in n. apply n. apply H0. }
      pose (list_max_max (fun e1 e2 : nat * S.t =>
          let (s1, _) := e1 in let (s2, _) := e2 in s1 <? s2) l p (metric Cand, Cand)).
      apply e0 in H2. rewrite <- Heqm in H2.
      destruct m. apply Nat.ltb_lt in H2.
      assert (n = metric t). { pose (list_max_In  (fun e1 e2 : nat * S.t =>
          let (s1, _) := e1 in let (s2, _) := e2 in s1 <? s2) l p). rewrite <- Heqm in i.
      pose (in_map_iff (fun iset : S.t => (metric iset, iset)) (filter (checker I) (all_subset I)) (n,t)). inversion i0.
      rewrite e in H3. apply H3 in i. inversion i. inversion H5. inversion H6. reflexivity. }
      simpl. rewrite <- H3. unfold ge. omega.
- admit.
Qed.


Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.theory.rationals
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe UnivalenceImpliesFunext
               TruncType UnivalenceAxiom Types.Sigma
               FunextVarieties.

Require Import HoTTClasses.sierpinsky partiality dedekind.

Require Import Rlow Cpo.

(** * Open Subspaces of a hset A *)

(** The continuous maps from A to
the Sierpinski space Sier forms a classifying topos for the opens
subsets of A. In Synthetic topology, continuous maps are the
definissible ones. *)

Definition OS (A : hSet) := A -> Sier.

Global Instance OS_isset {A} : IsHSet (OS A).
Proof.
apply _.
Qed.

(** Order relation on OS *)
Global Instance Osle {A} : Le (OS A) :=
           fun O1 O2 => forall x, SierLe (O1 x) (O2 x).

(** Osle is a partial order *)
Global Instance Osle_ord {A} : PartialOrder (@Osle A).
Proof.
split.
+ apply _.
+ intros x y.
  apply _.
+ split.
  - hnf.
    intros x s; reflexivity.
  - hnf.
    intros x y z Hxy Hyz s.
    transitivity (y s); auto.
+ hnf.
  intros x y H1 H2.
  apply path_forall.
  intros s.
  apply (antisymmetry le).
  apply H1.
  apply H2.
Defined.

(** Join of open subsets *)
Global Instance OS_join {A} : Join (OS A) :=
              fun U V => fun x => SierJoin (U x) (V x).

(** Meet of open subsets *)
Global Instance OS_meet {A} : Meet (OS A) :=
              fun U V => fun x => SierMeet (U x) (V x).

(** Empty space *)
Global Instance OS_empty {A} : Zero (OS A) := fun x : A => ⊥.

(** The entire space itself *)
Global Instance OS_full {A} : One (OS A) := fun x : A => ⊤.

(** OS A is has a cpo *)
Global Instance OS_cpo {A} : cpo (OS A).
Proof.
exists (OS_empty) (fun f : (nat -> OS A) => (fun x =>
                 CountableSup (fun n => f n x))).
+ intros f n a.
  apply (countable_sup_ub (fun n => f n a)).
+ intros f x H.
  assert (HL : forall n a, SierLe (f n a) (x a)).
  apply H.
  intros a.
  apply (countable_sup_least_ub (fun n => f n a)); trivial.
  intros n.
  apply HL.
+ intros x s; unfold OS_empty; simpl.
  apply bot_least.
Defined.

(** Notations *)
Notation "U ⋂ V" := (OS_meet U V) (at level 80).
Notation "U ∪ V" := (OS_join U V) (at level 80).
Notation "∅" := (OS_empty).
Notation "U ⊆ V" := (Osle U V) (at level 90).

(** Lattice properties of the order *)
Lemma os_lattice_order  {A} : LatticeOrder (@Osle A).
Proof.
split.
+ split.
  - apply Osle_ord.
  - intros x y s.
    apply SierMeet_is_meet.
  - intros x y s.
    apply SierMeet_is_meet.
  - intros x y z H1 H2 s.
    apply SierMeet_is_meet.
    apply H1. apply H2.
+ split.
  - apply Osle_ord.
  - intros x y s.
    apply SierJoin_is_join.
  - intros x y s.
    apply SierJoin_is_join.
  - intros x y z H1 H2 s.
    apply SierJoin_is_join.
    apply H1. apply H2.
Defined.

(** Semigroup structure of OS A with sg_op = join (OS A) :
     - associative sg_op
     - OS A is a hSet *)
Global Instance os_semi_group {A} : SemiGroup (OS A).
Proof.
split.
+ apply _.
+ hnf; intros x y z.
  apply path_forall.
  intros s.
  apply (antisymmetry le);
  apply SierJoin_is_join.
  transitivity ((x & y) s);
  apply SierJoin_is_join.
  apply SierJoin_is_join.
  transitivity ((x & y) s);
  apply SierJoin_is_join.
  apply SierJoin_is_join.
  apply SierJoin_is_join.
  apply SierJoin_is_join.
  transitivity ((y & z) s);
  apply SierJoin_is_join.
  transitivity ((y & z) s);
  apply SierJoin_is_join.
Defined.

(** Lattice structure on OS *)
Global Instance os_jslattice {A} : JoinSemiLattice (OS A).
Proof.
split.
+ split.
  - apply os_semi_group.
  - red. intros x y.
    apply path_forall; intro s.
    apply (antisymmetry le);
    apply SierJoin_is_join.
    apply SierJoin_is_join.
    apply SierJoin_is_join.
    apply SierJoin_is_join.
    apply SierJoin_is_join.
+ intros x.
  apply path_forall; intro s.
  apply (antisymmetry le);
  apply SierJoin_is_join; reflexivity.
Defined.

Global Instance os_mslattice {A}: MeetSemiLattice (OS A).
Proof.
split.
+ split.
  - split.
    apply _.
    hnf; intros x y z.
    apply path_forall.
    intros s.
    apply (antisymmetry le).
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    transitivity ((y ⋂  z) s).
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    transitivity ((y ⋂ z) s).
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    transitivity ((x ⋂ y) s).
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    transitivity ((x ⋂ y) s).
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
  - red. intros x y.
    apply path_forall; intro s.
    apply (antisymmetry le);
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
+ intros x.
  apply path_forall; intro s.
  apply (antisymmetry le);
  apply SierMeet_is_meet; reflexivity.
Defined.

Global Instance os_lattice {A} : Lattice (OS A).
Proof.
split.
  - apply os_jslattice.
  - apply os_mslattice.
  - red. intros x y.
    apply path_forall; intro s.
    apply (antisymmetry le);
    apply SierJoin_is_join.
    reflexivity.
    apply SierMeet_is_meet.
  - red. intros x y.
    apply path_forall; intro s.
    apply (antisymmetry le);
    apply SierMeet_is_meet.
    reflexivity.
    apply SierJoin_is_join.
Defined.

Global Instance os_dlattice {A}: DistributiveLattice (OS A).
Proof.
split.
+ exact os_lattice.
+ repeat red. intros a b c;
  apply path_forall ; intro s.
  generalize Sier_distributive_lattice.
  intros (_,HG).
  unfold LeftDistribute, LeftHeteroDistribute in *.
  specialize (HG (a s) (b s) (c s)).
  transitivity ((a s ⊔ b s) ⊓ (a s ⊔ c s)).
  apply HG.
  reflexivity.
Defined.


(*********************)
(*********************)
(****             ****)
(****   Objects   ****)
(****             ****)
(*********************)
(*********************)

Require Import Coq.Classes.Morphisms.
Require Import Main.CategoryTheory.Arrow.
Require Import Main.CategoryTheory.Category.
Require Import Main.Tactics.

#[local] Set Universe Polymorphism.

Definition isomorphic {C} (x y : object C) :=
  exists (f : arrow x y), isomorphism f.

Definition uniqueUpToIsomorphism {C} (P : object C -> Prop) :=
  forall x y, P x -> P y -> isomorphic x y.

Theorem isomorphicRefl C (x : object C) : isomorphic x x.
Proof.
  unfold isomorphic.
  unfold isomorphism.
  unfold inverse.
  eSearch.
Qed.

#[export] Hint Resolve isomorphicRefl : main.

Theorem isomorphicTrans C (x y z : object C) :
  isomorphic x y -> isomorphic y z -> isomorphic x z.
Proof.
  unfold isomorphic.
  unfold isomorphism.
  unfold inverse.
  clean.
  exists (compose x0 x2).
  exists (compose x3 x1).
  split.
  - rewrite cAssoc.
    rewrite <- (cAssoc x3).
    rewrite H.
    search.
  - rewrite cAssoc.
    rewrite <- (cAssoc x0).
    rewrite H1.
    search.
Qed.

(*
  We deliberately avoid adding a resolve hint for `isomorphicTrans` because
  doing so could lead to nonterminating searches.
*)

Theorem isomorphicSymm C (x y : object C) : isomorphic x y <-> isomorphic y x.
Proof.
  unfold isomorphic.
  unfold isomorphism.
  unfold inverse.
  eSearch.
Qed.

(*
  We deliberately avoid adding a resolve hint for `isomorphicSymm` because
  doing so could lead to nonterminating searches.
*)

Theorem opIsomorphic C x y :
  @isomorphic C x y <-> @isomorphic (oppositeCategory C) y x.
Proof.
  unfold isomorphic.
  split; clean; exists x0; [
    rewrite <- opIsomorphism | rewrite opIsomorphism
  ]; search.
Qed.

#[export] Hint Resolve opIsomorphic : main.


Require cem cbn expr db relations.
Require Import Unicode.Utf8 List NaryFunctions.
Require Import expr_db util CpdtTactics.
Require Import Basics.

Definition fresh (e : list nat) (h : cem.heap):= maximum (e ++ domain h).

(* Takes the closure from a configuration and converts it into the flattened
configuration, so its free variables are pointing directly to the correct
location*)
Definition closure_to_expr (c : cem.configuration) : option expr.tm
  := match c with | cem.conf h (cem.close t e') => let fix cte t e' e :=
    match t with
    | db.lam b => let f := fresh e h in
      match cte b e' (f :: e) with
      | Some b' => Some (expr.abs f b')
      | None => None
      end
    | db.var v => match nth_error e v with
      | Some l => Some (expr.var l)
      | None => match cem.clu v e' h with
        | Some (l', _) => Some (expr.var l')
        | None => None
        end
      end
    | db.app m n => match cte m e' e with
      | Some m' => match cte n e' e with
        | Some n' => Some (expr.app m' n')
        | None => None
        end
      | None => None
      end
    end
    in cte t e' nil
  end.

(*
Definition flatten (c: {c | cem.well_formed c}) : cbn.configuration := match c with
  | exist (cem.conf h c) p => cbn.st (map (fmap (closure_to_expr ∘ cem.conf h ∘ cem.clclose) h))
                         (closure_to_expr nil h c)
  end.

(* TODO : Proper relation *)
Inductive cem_cbn_rel : relation cem.configuration cbn.configuration :=
  | cc_rel : ∀ c1 c2, cem_cbn_rel c1 c2.

Lemma cem_cbn_bisim : strong_bisim cem.configuration cbn.configuration
                                   cem.step          cbn.step
                                   cem_cbn_rel.
Admitted.
Qed.

(*Well formed configurations can be collapsed into a closed deBruijn term*)
Theorem well_formed_cbn_closed_db : ∃ c, cbn.well_formed c ↔ ∃ e, db.closed e.
intros. destruct c. induction (expr.fvs t). destruct H.
induction h. destruct H. crush. assert (expr.closed t).
unfold expr.closed. apply util.subset_nil2. assumption. apply dbf. split with
(x:=t). assumption. destruct a. crush.

(* Relation idea: replace deBruijn variable with lookup location, which makes
them equal *)

Inductive state_rel : relation cem.configuration cbn.configuration :=
  | init : forall t e,
           deBruijn t e ->
           state_rel (cem.st nil (cem.close e 0)) (cbn.st nil t)
  | step : forall a b a' b',
           state_rel a b ->
           cem.step a a' ->
           cbn.step b b' ->
           state_rel a' b'.

Lemma ex1 : state_rel (cem.abs (0)

Fixpoint subst_cbn_config' vs e : expr.tm := match vs with
  | nil => e
  | (x,m)::hs => subst_cbn_config' hs (cbn.subst x m e)
  end.

Definition subst_cbn_config (st : cbn.configuration) : db.expr := match st with
  | cbn.st hs e => deBruijn (subst_cbn_config' hs e)
  end.

Theorem cem_cbn_bisim : bisim state_rel cem.step cbn.step.
unfold bisim.
intros. split.
  intros. induction H. destruct H. inversion H0. symmetry in H.
  apply app_cons_not_nil in H. inversion H.  apply ex_intro with (cbn.st nil
  (expr.abs v b)). assert (cbn.step (cbn.st nil (expr.abs v b)) (cbn.st nil
  (expr.abs v b))).  apply cbn.Abs. split. assumption.
    apply init. with (cem.st nil (cem.close (db.lam b') 0))
                    (cbn.st nil (expr.abs v b)).
                  *)