Require Import Bedrock.Heaps Bedrock.Memory.
Require Import Bedrock.PropX Bedrock.PropXTac.
Require Import Bedrock.SepTheoryX.
Require Bedrock.IL.
Require Bedrock.PropXRel.

Require Import Coq.Classes.RelationClasses.

Set Implicit Arguments.
Set Strict Implicit.

Module Make (H' : Heap) <:
  SepTheoryX with Module H := H'
             with Definition settings := IL.settings.
  Module H := H'.
  Module HT := HeapTheory H.

  Section env.
    Variable pcType : Type.
    Variable stateType : Type.
    Definition settings := IL.settings.

    Definition hprop (sos : list Type) := settings -> HT.smem -> propX pcType stateType sos.

    Variable cs : codeSpec pcType stateType.

    Definition satisfies (p : hprop nil) (s : settings) (sm : HT.smem) : Prop :=
      interp cs (p s sm).

    Definition himp (gl gr : hprop nil) : Prop :=
      forall s m, interp cs (gl s m ---> gr s m).
    Definition heq (gl gr : hprop nil) : Prop :=
      himp gl gr /\ himp gr gl.

    Global Instance Refl_himp : Reflexive himp.
    Proof.
      red; unfold himp; intros.
      eapply Imply_I; eauto.
    Qed.
    Global Instance Trans_himp : Transitive himp.
    Proof.
      red; unfold himp; firstorder.
      eapply Imply_I. eapply Imply_E. eapply valid_weaken. eapply H0. firstorder.
      eapply Imply_E. eapply valid_weaken. eapply H. firstorder. eauto.
    Qed.

    Global Instance Refl_heq : Reflexive heq.
    Proof.
      red; unfold heq; auto; split; reflexivity.
    Qed.
    Global Instance Sym_heq : Symmetric heq.
    Proof.
      red; unfold heq; firstorder.
    Qed.
    Global Instance Trans_heq : Transitive heq.
    Proof.
      red; unfold heq. intuition; etransitivity; eassumption.
    Qed.

    Theorem heq_himp : forall a b, heq a b -> himp a b.
    Proof.
      unfold heq; firstorder.
    Qed.

(*
    Theorem himp_heq : forall a b, himp a b -> himp b a -> heq a b.
    Proof.
      unfold heq; firstorder.
    Qed.
*)

    Theorem heq_defn : forall a b, (himp a b /\ himp b a) <-> heq a b.
    Proof.
      unfold heq; intuition.
    Qed.

    (* Definitions *)
    Definition inj sos (p : propX pcType stateType sos) : hprop sos :=
      fun _ m => PropX.And p (PropX.Inj (HT.semp m)).

    Definition emp {sos} : hprop sos := inj (PropX.Inj True).

    Definition star sos (l r : hprop sos) : hprop sos :=
      fun s m => PropX.Exists (fun ml : HT.smem => PropX.Exists (fun mr : HT.smem =>
        PropX.And (PropX.Inj (HT.split m ml mr)) (And (l s ml) (r s mr)))).

    Definition ex sos (T : Type) (p : T -> hprop sos) : hprop sos :=
      fun s h => PropX.Exists (fun t => p t s h).

    Definition hptsto sos (p : H.addr) (v : B) : hprop sos :=
      fun s h =>
        PropX.Inj (HT.smem_get p h = Some v /\ forall p', p' <> p -> HT.smem_get p' h = None).

    (* satisfies lemmas *)
    Theorem satisfies_himp : forall P Q stn,
      himp P Q ->
      (forall m, satisfies P stn m ->
       satisfies Q stn m).
    Proof.
      unfold himp, satisfies. intros. propxFo.
      eapply Imply_E; eauto.
    Qed.

    Theorem satisfies_star : forall P Q stn m,
      satisfies (star P Q) stn m <->
      exists ml, exists mr,
        HT.split m ml mr /\
        satisfies P stn ml /\ satisfies Q stn mr.
    Proof.
      unfold satisfies. intros. propxFo. eauto 10.
      exists x; exists x0. intuition propxFo.
    Qed.

    Theorem satisfies_pure : forall p stn m,
      satisfies (inj p) stn m ->
      interp cs p /\ HT.semp m.
    Proof.
      unfold satisfies, inj; simpl; intros; propxFo.
    Qed.

    Theorem satisfies_ex : forall T p stn m,
      satisfies (@ex _ T p) stn m ->
      exists x : T, satisfies (p x) stn m.
    Proof.
      unfold satisfies, ex; simpl; intros; propxFo; eauto.
    Qed.

    (** Lemmas **)
(*
    Ltac doIt :=
      unfold himp, heq; simpl; intros;
        repeat match goal with
(*                 | [ h : HT.smem , H : forall x : HT.smem , _ |- _ ] => specialize (H h) *)
                 | [ H : _ -> _ |- _ ] => apply H; clear H
                 | [ H : forall x, _ -> _ , H' : _ |- _ ] => apply H in H'
                 | [ H : ?X -> _ , H' : ?X |- _ ] => apply H in H'; clear H
               end; propxFo;
        repeat match goal with
                 | [ |- exists x, _ ] => eexists
                 | [ |- _ /\ _ ] => split
                 | [ |- simplify _ _ _ ] => eassumption || apply simplify_fwd
                 | [ H : interp ?X (?Y _) |- interp ?X (?Y _) ] => eapply H
               end.

      unfold himp, heq; simpl; intros;
        repeat match goal with
(*                 | [ h : HT.smem , H : forall x : HT.smem , _ |- _ ] => specialize (H h) *)
                 | [ H : _ -> _ |- _ ] => apply H; clear H
                 | [ H : forall x, _ -> _ , H' : _ |- _ ] => apply H in H'
                 | [ H : ?X -> _ , H' : ?X |- _ ] => apply H in H'; clear H
               end; propxFo;
        repeat match goal with
                 | [ |- exists x, _ ] => eexists
                 | [ |- _ /\ _ ] => split
                 | [ |- simplify _ _ _ ] => eassumption || apply simplify_fwd
                 | [ H : interp ?X (?Y _) |- interp ?X (?Y _) ] => eapply H
               end.
*)

    Import PropXRel.

    Hint Immediate HT.split_comm : heaps.
    Hint Resolve HT.split_assoc HT.disjoint_split_join HT.split_split_disjoint : heaps.

    Lemma himp_star_comm : forall P Q, himp (star P Q) (star Q P).
    Proof.
      unfold star, himp, interp; intros; propxIntuition; eauto with heaps.
    Qed.

(*
    Theorem himp_star_comm_p : forall P Q R, himp (star P Q) R -> himp (star Q P) R.
    Proof.
      unfold star; doIt. eauto with heaps.
    Qed.
    Theorem himp_star_comm_c : forall P Q R, himp R (star P Q) -> himp R (star Q P).
    Proof.
      unfold star; doIt. eauto with heaps.
    Qed.
*)

    Theorem heq_star_comm : forall P Q, heq (star P Q) (star Q P).
    Proof.
      intros. unfold heq. generalize himp_star_comm. intuition.
    Qed.

    Theorem himp_star_assoc : forall P Q R,
      himp (star (star P Q) R) (star P (star Q R)).
    Proof.
      unfold star, himp, interp; intros; propxIntuition.
      eapply HT.split_comm. eapply HT.split_assoc. eapply HT.split_comm. eassumption. eapply HT.split_comm. eassumption.
      eapply HT.disjoint_split_join. eapply HT.disjoint_comm. eauto with heaps.
    Qed.
(*
    Theorem himp_star_assoc_c : forall P Q R S,
      himp S (star P (star Q R)) -> himp S (star (star P Q) R).
    Proof.
      doIt. eapply HT.split_assoc. eassumption. eassumption.
      eapply HT.split_comm. eapply HT.disjoint_split_join. eapply HT.disjoint_comm. eauto with heaps.
    Qed.
*)

    Theorem heq_star_assoc : forall P Q R,
      heq (star (star P Q) R) (star P (star Q R)).
    Proof.
      split. eapply himp_star_assoc.

      unfold star, himp, interp; intros; propxIntuition.

      eapply HT.split_assoc. eassumption. eassumption.
      eapply HT.split_comm. eapply HT.disjoint_split_join.
      eapply HT.disjoint_comm.
      eapply HT.split_split_disjoint. 2: eassumption. eauto with heaps.
    Qed.

    Theorem himp_star_frame : forall P Q R S,
      himp P Q -> himp R S -> himp (star P R) (star Q S).
    Proof.
      unfold himp, star, interp; intros; propxIntuition.
      Focus 2.
      eapply Imply_E. eapply valid_weaken. eapply H. firstorder. econstructor; firstorder.
      Focus 2.
      eapply Imply_E. eapply valid_weaken. eapply H0. firstorder. econstructor; firstorder.
      eauto.
    Qed.

    Theorem heq_star_frame : forall P Q R S, heq P Q -> heq R S -> heq (star P R) (star Q S).
    Proof.
      unfold heq; generalize himp_star_frame. intuition.
    Qed.

    Theorem himp_star_pure_p : forall P Q F,
      himp (star (inj F) P) Q -> (interp cs F -> himp P Q).
    Proof.
      unfold himp, star, inj; intros.
      specialize (H s m).
      unfold interp in *. propxIntuition.
      eapply Imply_E. eapply valid_weaken. eapply H. firstorder.
      eapply Exists_I. instantiate (1 := HT.smem_emp).
      eapply Exists_I. instantiate (1 := m). propxIntuition.
      eapply HT.split_a_semp_a.
      eapply valid_weaken. eassumption. firstorder. eapply HT.semp_smem_emp.
    Qed.

    Theorem himp_star_pure_c : forall P Q (F : Prop),
      (F -> himp P Q) -> himp (star (inj (PropX.Inj F)) P) Q.
    Proof.
      unfold himp, star, inj, interp; intros. propxIntuition.
      specialize (H H1). eapply PropX.Imply_E. eapply valid_weaken. eauto. firstorder.
      apply HT.split_semp in H0; auto. subst.
      constructor. firstorder.
    Qed.

    Theorem himp_star_pure_cc : forall P Q (p : Prop),
      p ->
      himp P Q ->
      himp P (star (inj (PropX.Inj p)) Q).
    Proof.
      unfold himp, star, inj, interp; intros. propxIntuition; eauto using HT.semp_smem_emp, HT.split_a_semp_a.
      eapply Imply_E. eapply valid_weaken; eauto. firstorder.
      econstructor. firstorder.
    Qed.

    Theorem himp_subst_p : forall P Q R S,
      himp P S -> himp (star S Q) R ->
      himp (star P Q) R.
    Proof.
      unfold himp, star, interp; intros; propxIntuition.
      specialize (H s x). specialize (H0 s m).
      eapply Imply_E. eapply valid_weaken. eapply H0. firstorder.
      propxIntuition. eauto. eapply Imply_E. eapply valid_weaken.
      eauto. firstorder. econstructor; firstorder.
    Qed.

    Theorem himp_subst_c : forall P Q R S,
      himp S Q -> himp P (star S R) ->
      himp P (star Q R).
    Proof.
      unfold himp, star, interp; intros.
      eapply Imply_I. eapply valid_extend.
      eapply Imply_E. eapply valid_weaken.
      specialize (H0 s m). eassumption. firstorder. eauto.
      propxIntuition; eauto.
      eapply Imply_E. eapply valid_weaken. eapply H. firstorder.
      econstructor; firstorder.
    Qed.

    Theorem heq_subst : forall P Q R S,
      heq P S -> heq (star S Q) R ->
      heq (star P Q) R.
    Proof.
      unfold heq. intros. intuition; generalize himp_subst_p; generalize himp_subst_c; eauto.
    Qed.

    Theorem himp_star_emp_p : forall P Q, himp P Q -> himp (star emp P) Q.
    Proof.
      unfold emp, inj, star, himp, interp; intuition; propxIntuition.
      eapply Imply_E. eapply valid_weaken; [ eapply H | firstorder ].
      eapply HT.split_semp in H0; eauto; subst. propxIntuition.
    Qed.

    Theorem himp_star_emp_p' : forall P Q, himp (star emp P) Q -> himp P Q.
    Proof.
      unfold emp, inj, star, himp, interp; intuition; propxIntuition.
      eapply Imply_E. eapply valid_weaken; [ eapply H | firstorder ].
      propxIntuition. eapply HT.split_a_semp_a. auto. eapply HT.semp_smem_emp.
    Qed.

    Theorem himp_star_emp_c : forall P Q, himp P Q -> himp P (star emp Q).
    Proof.
      unfold emp, inj, star, himp, interp; intuition; propxIntuition.
      eapply HT.split_a_semp_a. auto. eapply HT.semp_smem_emp.
      eapply Imply_E. eapply valid_weaken; [ eapply H | firstorder ].
      propxIntuition.
    Qed.

    Theorem himp_star_emp_c' : forall P Q, himp P (star emp Q) -> himp P Q.
    Proof.
      unfold emp, inj, star, himp, interp; intuition; propxIntuition.
      eapply valid_extend. eapply Imply_E. eapply valid_weaken. eapply (H s m). firstorder.
      econstructor; firstorder.
      propxIntuition.
      eapply HT.split_semp in H0; eauto; subst. propxIntuition.
    Qed.

    Theorem heq_star_emp_l : forall P, heq (star emp P) P.
      intros. unfold heq in *; intuition.
      eapply himp_star_emp_p. reflexivity.
      eapply himp_star_emp_c. reflexivity.
    Qed.

    Theorem heq_star_emp_r : forall P, heq (star P emp) P.
    Proof.
      intros. unfold heq, himp, star, emp, inj, interp in *; intuition.
      propxIntuition. eapply HT.split_comm in H. eapply HT.split_semp in H; eauto; subst. propxIntuition.

      propxIntuition.
      eapply HT.split_comm. eapply HT.split_a_semp_a. auto. eapply HT.semp_smem_emp.
    Qed.

(*
    Theorem heq_star_emp' : forall P Q, heq (star emp P) Q -> heq P Q.

      intros. unfold heq in *; intuition.
      eapply himp_star_emp_p' in H0. auto.
      eapply himp_star_emp_c' in H1. auto.
    Qed.
*)

    Theorem himp_star_cancel : forall P Q R, himp Q R -> himp (star P Q) (star P R).

      intros. eapply himp_star_frame. reflexivity. auto.
    Qed.

    Theorem heq_star_cancel : forall P Q R, heq Q R -> heq (star P Q) (star P R).

      intros. eapply heq_star_frame. reflexivity. auto.
    Qed.

    Theorem himp_ex_p : forall T (P : T -> _) Q,
      (forall v, himp (P v) Q) -> himp (ex P) Q.

      intros. unfold himp, ex in *; simpl in *; intros. unfold interp in *. propxIntuition.
      eapply Imply_E. eapply valid_weaken; eauto. firstorder. econstructor; firstorder.
    Qed.

    Theorem himp_ex_c : forall T (P : T -> _) Q,
      (exists v, himp Q (P v)) -> himp Q (ex P).
    Proof.
      intros. unfold himp, ex in *; simpl in *; intros. unfold interp in *.
      destruct H. propxIntuition. instantiate (1 := x).
      eapply Imply_E. eapply valid_weaken; eauto. firstorder. eauto.
    Qed.

    Hint Resolve simplify_fwd : heaps.

    Theorem heq_ex : forall T (P Q : T -> _),
      (forall v, heq (P v) (Q v)) ->
      heq (ex P) (ex Q).
    Proof.
      unfold heq, himp, ex, interp; intros; intuition; propxIntuition;
       match goal with
         | [ H : forall v : ?T, _, x : ?T |- _ ] => specialize (H x)
       end; intuition.
      eapply Imply_E. eapply valid_weaken; eauto. firstorder. eauto.
      eapply Imply_E. eapply valid_weaken; eauto. firstorder. eauto.
    Qed.

    Theorem himp_ex : forall T (P Q : T -> _),
      (forall v, himp (P v) (Q v)) ->
      himp (ex P) (ex Q).
    Proof.
      unfold himp, ex, interp; intuition; propxIntuition;
        match goal with
          | [ H : forall v : ?T, _, x : ?T |- _ ] => specialize (H x)
        end.
      eapply Imply_E. eapply valid_weaken; eauto. firstorder. eauto.
    Qed.

    Theorem heq_ex_star : forall T (P : T -> _) Q,
      heq (star (ex P) Q) (ex (fun x => star (P x) Q)).
    Proof.
      unfold heq, himp, star, ex, interp; intuition; propxIntuition; eauto.
    Qed.

    Theorem himp_ex_star : forall T (P : T -> _) Q,
      himp (star (ex P) Q) (ex (fun x => star (P x) Q)).
    Proof.
      unfold himp, star, ex, interp; intuition; propxIntuition; eauto.
    Qed.

    Lemma himp'_ex : forall T (P : T -> _) Q,
      (forall x, himp (P x) Q) ->
      himp (ex P) Q.
    Proof.
      clear. intros. unfold himp, ex, interp in *. intuition. propxIntuition.
      eapply Imply_E. eapply valid_weaken; eauto. firstorder. eauto.
    Qed.
  End env.
End Make.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import omega.Omega.
From PLF Require Import Hoare.
From PLF Require Import Imp.

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

Definition reduce_to_zero' : com :=
(WHILE ~(X = 0) DO
X ::= X - 1
END)%imp.

Theorem reduce_to_zero_correct' :
{{fun st => True}}
reduce_to_zero'
{{fun st => st X = 0}}.
Proof. hammer_hook "Hoare2" "Hoare2.reduce_to_zero_correct'".
unfold reduce_to_zero'.

eapply hoare_consequence_post.
apply hoare_while.
-

eapply hoare_consequence_pre. apply hoare_asgn.

intros st [HT Hbp]. unfold assn_sub. constructor.
-
intros st [Inv GuardFalse].
unfold bassn in GuardFalse. simpl in GuardFalse.
rewrite not_true_iff_false in GuardFalse.
rewrite negb_false_iff in GuardFalse.
apply eqb_eq in GuardFalse.
apply GuardFalse. Qed.

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

Fixpoint parity x :=
match x with
| 0 => 0
| 1 => 1
| S (S x') => parity x'
end.

Lemma parity_ge_2 : forall x,
2 <= x ->
parity (x - 2) = parity x.
Proof. hammer_hook "Hoare2" "Hoare2.parity_ge_2".
induction x; intro. reflexivity.
destruct x. inversion H. inversion H1.
simpl. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma parity_lt_2 : forall x,
~ 2 <= x ->
parity (x) = x.
Proof. hammer_hook "Hoare2" "Hoare2.parity_lt_2".
intros. induction x. reflexivity. destruct x. reflexivity.
exfalso. apply H. omega.
Qed.

Theorem parity_correct : forall m,
{{ fun st => st X = m }}
WHILE 2 <= X DO
X ::= X - 2
END
{{ fun st => st X = parity m }}.
Proof. hammer_hook "Hoare2" "Hoare2.parity_correct".
Admitted.

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

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

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

Definition is_wp P c Q :=
{{P}} c {{Q}} /\
forall P', {{P'}} c {{Q}} -> (P' ->> P).

Theorem is_wp_example :
is_wp (fun st => st Y <= 4)
(X ::= Y + 1) (fun st => st X <= 5).
Proof. hammer_hook "Hoare2" "Hoare2.is_wp_example".
Admitted.

Theorem hoare_asgn_weakest : forall Q X a,
is_wp (Q [X |-> a]) (X ::= a) Q.
Proof. hammer_hook "Hoare2" "Hoare2.hoare_asgn_weakest".
Admitted.

Module Himp2.
Import Himp.

Lemma hoare_havoc_weakest : forall (P Q : Assertion) (X : string),
{{ P }} HAVOC X {{ Q }} ->
P ->> havoc_pre X Q.
Proof. hammer_hook "Hoare2" "Hoare2.Himp2.hoare_havoc_weakest".
Admitted.
End Himp2.

Inductive dcom : Type :=
| DCSkip :  Assertion -> dcom
| DCSeq : dcom -> dcom -> dcom
| DCAsgn : string -> aexp ->  Assertion -> dcom
| DCIf : bexp ->  Assertion -> dcom ->  Assertion -> dcom
-> Assertion-> dcom
| DCWhile : bexp -> Assertion -> dcom -> Assertion -> dcom
| DCPre : Assertion -> dcom -> dcom
| DCPost : dcom -> Assertion -> dcom.

Inductive decorated : Type :=
| Decorated : Assertion -> dcom -> decorated.

Delimit Scope default with default.

Notation "'SKIP' {{ P }}"
:= (DCSkip P)
(at level 10) : dcom_scope.
Notation "l '::=' a {{ P }}"
:= (DCAsgn l a P)
(at level 60, a at next level) : dcom_scope.
Notation "'WHILE' b 'DO' {{ Pbody }} d 'END' {{ Ppost }}"
:= (DCWhile b Pbody d Ppost)
(at level 80, right associativity) : dcom_scope.
Notation "'TEST' b 'THEN' {{ P }} d 'ELSE' {{ P' }} d' 'FI' {{ Q }}"
:= (DCIf b P d P' d' Q)
(at level 80, right associativity)  : dcom_scope.
Notation "'->>' {{ P }} d"
:= (DCPre P d)
(at level 90, right associativity)  : dcom_scope.
Notation "d '->>' {{ P }}"
:= (DCPost d P)
(at level 80, right associativity)  : dcom_scope.
Notation " d ;; d' "
:= (DCSeq d d')
(at level 80, right associativity)  : dcom_scope.
Notation "{{ P }} d"
:= (Decorated P d)
(at level 90)  : dcom_scope.

Delimit Scope dcom_scope with dcom.
Open Scope dcom_scope.

Example dec0 :=
SKIP {{ fun st => True }}.
Example dec1 :=
WHILE true DO {{ fun st => True }} SKIP {{ fun st => True }} END
{{ fun st => True }}.
Set Printing All.

Example dec_while : decorated :=
{{ fun st => True }}
WHILE ~(X = 0)
DO
{{ fun st => True /\ st X <> 0}}
X ::= X - 1
{{ fun _ => True }}
END
{{ fun st => True /\ st X = 0}} ->>
{{ fun st => st X = 0 }}.

Fixpoint extract (d : dcom) : com :=
match d with
| DCSkip _           => SKIP
| DCSeq d1 d2        => (extract d1 ;; extract d2)
| DCAsgn X a _       => X ::= a
| DCIf b _ d1 _ d2 _ => TEST b THEN extract d1 ELSE extract d2 FI
| DCWhile b _ d _    => WHILE b DO extract d END
| DCPre _ d          => extract d
| DCPost d _         => extract d
end.

Definition extract_dec (dec : decorated) : com :=
match dec with
| Decorated P d => extract d
end.

Fixpoint post (d : dcom) : Assertion :=
match d with
| DCSkip P                => P
| DCSeq d1 d2             => post d2
| DCAsgn X a Q            => Q
| DCIf  _ _ d1 _ d2 Q     => Q
| DCWhile b Pbody c Ppost => Ppost
| DCPre _ d               => post d
| DCPost c Q              => Q
end.

Definition pre_dec (dec : decorated) : Assertion :=
match dec with
| Decorated P d => P
end.

Definition post_dec (dec : decorated) : Assertion :=
match dec with
| Decorated P d => post d
end.

Definition dec_correct (dec : decorated) :=
{{pre_dec dec}} (extract_dec dec) {{post_dec dec}}.

Fixpoint verification_conditions (P : Assertion) (d : dcom) : Prop :=
match d with
| DCSkip Q =>
(P ->> Q)
| DCSeq d1 d2 =>
verification_conditions P d1
/\ verification_conditions (post d1) d2
| DCAsgn X a Q =>
(P ->> Q [X |-> a])
| DCIf b P1 d1 P2 d2 Q =>
((fun st => P st /\ bassn b st) ->> P1)
/\ ((fun st => P st /\ ~ (bassn b st)) ->> P2)
/\ (post d1 ->> Q) /\ (post d2 ->> Q)
/\ verification_conditions P1 d1
/\ verification_conditions P2 d2
| DCWhile b Pbody d Ppost =>

(P ->> post d)
/\ ((fun st => post d st /\ bassn b st) ->> Pbody)
/\ ((fun st => post d st /\ ~(bassn b st)) ->> Ppost)
/\ verification_conditions Pbody d
| DCPre P' d =>
(P ->> P') /\ verification_conditions P' d
| DCPost d Q =>
verification_conditions P d /\ (post d ->> Q)
end.

Theorem verification_correct : forall d P,
verification_conditions P d -> {{P}} (extract d) {{post d}}.
Proof. hammer_hook "Hoare2" "Hoare2.verification_correct".
induction d; intros P H; simpl in *.
-
eapply hoare_consequence_pre.
apply hoare_skip.
assumption.
-
destruct H as [H1 H2].
eapply hoare_seq.
apply IHd2. apply H2.
apply IHd1. apply H1.
-
eapply hoare_consequence_pre.
apply hoare_asgn.
assumption.
-
destruct H as [HPre1 [HPre2 [Hd1 [Hd2 [HThen HElse]]]]].
apply IHd1 in HThen. clear IHd1.
apply IHd2 in HElse. clear IHd2.
apply hoare_if.
+ eapply hoare_consequence_post with (Q':=post d1); eauto.
eapply hoare_consequence_pre; eauto.
+ eapply hoare_consequence_post with (Q':=post d2); eauto.
eapply hoare_consequence_pre; eauto.
-
destruct H as [Hpre [Hbody1 [Hpost1  Hd]]].
eapply hoare_consequence_pre; eauto.
eapply hoare_consequence_post; eauto.
apply hoare_while.
eapply hoare_consequence_pre; eauto.
-
destruct H as [HP Hd].
eapply hoare_consequence_pre. apply IHd. apply Hd. assumption.
-
destruct H as [Hd HQ].
eapply hoare_consequence_post. apply IHd. apply Hd. assumption.
Qed.

Definition verification_conditions_dec (dec : decorated) : Prop :=
match dec with
| Decorated P d => verification_conditions P d
end.

Lemma verification_correct_dec : forall dec,
verification_conditions_dec dec -> dec_correct dec.
Proof. hammer_hook "Hoare2" "Hoare2.verification_correct_dec".
intros [P d]. apply verification_correct.
Qed.

Eval simpl in (verification_conditions_dec dec_while).

Tactic Notation "verify" :=
apply verification_correct;
repeat split;
simpl; unfold assert_implies;
unfold bassn in *; unfold beval in *; unfold aeval in *;
unfold assn_sub; intros;
repeat rewrite t_update_eq;
repeat (rewrite t_update_neq; [| (intro X; inversion X)]);
simpl in *;
repeat match goal with [H : _ /\ _ |- _] => destruct H end;
repeat rewrite not_true_iff_false in *;
repeat rewrite not_false_iff_true in *;
repeat rewrite negb_true_iff in *;
repeat rewrite negb_false_iff in *;
repeat rewrite eqb_eq in *;
repeat rewrite eqb_neq in *;
repeat rewrite leb_iff in *;
repeat rewrite leb_iff_conv in *;
try subst;
repeat
match goal with
[st : state |- _] =>
match goal with
[H : st _ = _ |- _] => rewrite -> H in *; clear H
| [H : _ = st _ |- _] => rewrite <- H in *; clear H
end
end;
try eauto; try omega.

Theorem dec_while_correct :
dec_correct dec_while.
Proof. hammer_hook "Hoare2" "Hoare2.dec_while_correct". verify. Qed.

Example subtract_slowly_dec (m : nat) (p : nat) : decorated :=
{{ fun st => st X = m /\ st Z = p }} ->>
{{ fun st => st Z - st X = p - m }}
WHILE ~(X = 0)
DO   {{ fun st => st Z - st X = p - m /\ st X <> 0 }} ->>
{{ fun st => (st Z - 1) - (st X - 1) = p - m }}
Z ::= Z - 1
{{ fun st => st Z - (st X - 1) = p - m }} ;;
X ::= X - 1
{{ fun st => st Z - st X = p - m }}
END
{{ fun st => st Z - st X = p - m /\ st X = 0 }} ->>
{{ fun st => st Z = p - m }}.

Theorem subtract_slowly_dec_correct : forall m p,
dec_correct (subtract_slowly_dec m p).
Proof. hammer_hook "Hoare2" "Hoare2.subtract_slowly_dec_correct". intros m p. verify.  Qed.

Definition swap : com :=
X ::= X + Y;;
Y ::= X - Y;;
X ::= X - Y.

Definition swap_dec m n : decorated :=
{{ fun st => st X = m /\ st Y = n}} ->>
{{ fun st => (st X + st Y) - ((st X + st Y) - st Y) = n
/\ (st X + st Y) - st Y = m }}
X ::= X + Y
{{ fun st => st X - (st X - st Y) = n /\ st X - st Y = m }};;
Y ::= X - Y
{{ fun st => st X - st Y = n /\ st Y = m }};;
X ::= X - Y
{{ fun st => st X = n /\ st Y = m}}.

Theorem swap_correct : forall m n,
dec_correct (swap_dec m n).
Proof. hammer_hook "Hoare2" "Hoare2.swap_correct". intros; verify. Qed.

Definition if_minus_plus_com :=
(TEST X <= Y
THEN Z ::= Y - X
ELSE Y ::= X + Z
FI)%imp.

Definition if_minus_plus_dec :=
{{fun st => True}}
TEST X <= Y  THEN
{{ fun st => True /\ st X <= st Y }} ->>
{{ fun st => st Y = st X + (st Y - st X) }}
Z ::= Y - X
{{ fun st => st Y = st X + st Z }}
ELSE
{{ fun st => True /\ ~(st X <= st Y) }} ->>
{{ fun st => st X + st Z = st X + st Z }}
Y ::= X + Z
{{ fun st => st Y = st X + st Z }}
FI
{{fun st => st Y = st X + st Z}}.

Theorem if_minus_plus_correct :
dec_correct if_minus_plus_dec.
Proof. hammer_hook "Hoare2" "Hoare2.if_minus_plus_correct". verify. Qed.

Definition if_minus_dec :=
{{fun st => True}}
TEST X <= Y THEN
{{fun st => True /\ st X <= st Y }} ->>
{{fun st => (st Y - st X) + st X = st Y
\/ (st Y - st X) + st Y = st X}}
Z ::= Y - X
{{fun st => st Z + st X = st Y \/ st Z + st Y = st X}}
ELSE
{{fun st => True /\ ~(st X <= st Y) }} ->>
{{fun st => (st X - st Y) + st X = st Y
\/ (st X - st Y) + st Y = st X}}
Z ::= X - Y
{{fun st => st Z + st X = st Y \/ st Z + st Y = st X}}
FI
{{fun st => st Z + st X = st Y \/ st Z + st Y = st X}}.

Theorem if_minus_correct :
dec_correct if_minus_dec.
Proof. hammer_hook "Hoare2" "Hoare2.if_minus_correct". verify. Qed.

Definition div_mod_dec (a b : nat) : decorated :=
{{ fun st => True }} ->>
{{ fun st => b * 0 + a = a }}
X ::= a
{{ fun st => b * 0 + st X = a }};;
Y ::= 0
{{ fun st => b * st Y + st X = a }};;
WHILE b <= X DO
{{ fun st => b * st Y + st X = a /\ b <= st X }} ->>
{{ fun st => b * (st Y + 1) + (st X - b) = a }}
X ::= X - b
{{ fun st => b * (st Y + 1) + st X = a }};;
Y ::= Y + 1
{{ fun st => b * st Y + st X = a }}
END
{{ fun st => b * st Y + st X = a /\ ~(b <= st X) }} ->>
{{ fun st => b * st Y + st X = a /\ (st X < b) }}.

Theorem div_mod_dec_correct : forall a b,
dec_correct (div_mod_dec a b).
Proof. hammer_hook "Hoare2" "Hoare2.div_mod_dec_correct". intros a b. verify.
rewrite mult_plus_distr_l. omega.
Qed.

Definition find_parity : com :=
WHILE 2 <= X DO
X ::= X - 2
END.

Inductive ev : nat -> Prop :=
| ev_0 : ev O
| ev_SS : forall n : nat, ev n -> ev (S (S n)).

Definition find_parity_dec m : decorated :=
{{ fun st => st X = m}} ->>
{{ fun st => st X <= m /\ ev (m - st X) }}
WHILE 2 <= X DO
{{ fun st => (st X <= m /\ ev (m - st X)) /\ 2 <= st X }} ->>
{{ fun st => st X - 2 <= m /\ (ev (m - (st X - 2))) }}
X ::= X - 2
{{ fun st => st X <= m /\ ev (m - st X) }}
END
{{ fun st => (st X <= m /\ ev (m - st X)) /\ st X < 2 }} ->>
{{ fun st => st X=0 <-> ev m }}.

Lemma l1 : forall m n p,
p <= n ->
n <= m ->
m - (n - p) = m - n + p.
Proof. hammer_hook "Hoare2" "Hoare2.l1". intros. omega. Qed.

Lemma l2 : forall m,
ev m ->
ev (m + 2).
Proof. hammer_hook "Hoare2" "Hoare2.l2". intros. rewrite plus_comm. simpl. constructor. assumption. Qed.

Lemma l3' : forall m,
ev m ->
~ev (S m).
Proof. hammer_hook "Hoare2" "Hoare2.l3'". induction m; intros H1 H2. inversion H2. apply IHm.
inversion H2; subst; assumption. assumption. Qed.

Lemma l3 : forall m,
1 <= m ->
ev m ->
ev (m - 1) ->
False.
Proof. hammer_hook "Hoare2" "Hoare2.l3". intros. apply l2 in H1.
assert (G : m - 1 + 2 = S m). clear H0 H1. omega.
rewrite G in H1. apply l3' in H0. apply H0. assumption. Qed.

Theorem find_parity_correct : forall m,
dec_correct (find_parity_dec m).
Proof. hammer_hook "Hoare2" "Hoare2.find_parity_correct".
intro m. verify;

fold (2 <=? (st X)) in *;
try rewrite leb_iff in *;
try rewrite leb_iff_conv in *; eauto; try omega.
-
rewrite minus_diag. constructor.
-
rewrite l1; try assumption.
apply l2; assumption.
-
rewrite <- minus_n_O in H2. assumption.
-
destruct (st X) as [| [| n]].

+
reflexivity.
+
apply l3 in H; try assumption. inversion H.
+
clear H0 H2.
omega.
Qed.

Definition find_parity_dec' m : decorated :=
{{ fun st => st X = m}} ->>
{{ fun st => ev (st X) <-> ev m }}
WHILE 2 <= X DO
{{ fun st => (ev (st X) <-> ev m) /\ 2 <= st X }} ->>
{{ fun st => (ev (st X - 2) <-> ev m) }}
X ::= X - 2
{{ fun st => (ev (st X) <-> ev m) }}
END
{{ fun st => (ev (st X) <-> ev m) /\ ~(2 <= st X) }} ->>
{{ fun st => st X=0 <-> ev m }}.

Lemma l4 : forall m,
2 <= m ->
(ev (m - 2) <-> ev m).
Proof. hammer_hook "Hoare2" "Hoare2.l4".
induction m; intros. split; intro; constructor.
destruct m. inversion H. inversion H1. simpl in *.
rewrite <- minus_n_O in *. split; intro.
constructor. assumption.
inversion H0. assumption.
Qed.

Theorem find_parity_correct' : forall m,
dec_correct (find_parity_dec' m).
Proof. hammer_hook "Hoare2" "Hoare2.find_parity_correct'".
intros m. verify;

fold (2 <=? (st X)) in *;
try rewrite leb_iff in *;
try rewrite leb_iff_conv in *; intuition; eauto; try omega.
-
rewrite l4 in H0; eauto.
-
rewrite l4; eauto.
-
apply H0. constructor.
-
destruct (st X) as [| [| n]].
+
reflexivity.
+
inversion H.
+
clear H0 H H3.
omega.
Qed.

Definition parity_dec m : decorated :=
{{ fun st => st X = m}} ->>
{{ fun st => parity (st X) = parity m }}
WHILE 2 <= X DO
{{ fun st => parity (st X) = parity m /\ 2 <= st X }} ->>
{{ fun st => parity (st X - 2) = parity m }}
X ::= X - 2
{{ fun st => parity (st X) = parity m }}
END
{{ fun st => parity (st X) = parity m /\ ~(2 <= st X) }} ->>
{{ fun st => st X = parity m }}.

Theorem parity_dec_correct : forall m,
dec_correct (parity_dec m).
Proof. hammer_hook "Hoare2" "Hoare2.parity_dec_correct".
intros. verify;

fold (2 <=? (st X)) in *;
try rewrite leb_iff in *;
try rewrite leb_iff_conv in *; eauto; try omega.
-
rewrite <- H. apply parity_ge_2. assumption.
-
rewrite <- H. symmetry. apply parity_lt_2. assumption.
Qed.

Definition sqrt_dec m : decorated :=
{{ fun st => st X = m }} ->>
{{ fun st => st X = m /\ 0*0 <= m }}
Z ::= 0
{{ fun st => st X = m /\ st Z*st Z <= m }};;
WHILE (Z+1)*(Z+1) <= X DO
{{ fun st => (st X = m /\ st Z*st Z<=m)
/\ (st Z + 1)*(st Z + 1) <= st X }} ->>
{{ fun st => st X = m /\ (st Z+1)*(st Z+1)<=m }}
Z ::= Z + 1
{{ fun st => st X = m /\ st Z*st Z<=m }}
END
{{ fun st => (st X = m /\ st Z*st Z<=m)
/\ ~((st Z + 1)*(st Z + 1) <= st X) }} ->>
{{ fun st => st Z*st Z<=m /\ m<(st Z+1)*(st Z+1) }}.

Theorem sqrt_correct : forall m,
dec_correct (sqrt_dec m).
Proof. hammer_hook "Hoare2" "Hoare2.sqrt_correct". intro m. verify. Qed.

Definition square_dec (m : nat) : decorated :=
{{ fun st => st X = m }}
Y ::= X
{{ fun st => st X = m /\ st Y = m }};;
Z ::= 0
{{ fun st => st X = m /\ st Y = m /\ st Z = 0}} ->>
{{ fun st => st Z + st X * st Y = m * m }};;
WHILE ~(Y = 0) DO
{{ fun st => st Z + st X * st Y = m * m /\ st Y <> 0 }} ->>
{{ fun st => (st Z + st X) + st X * (st Y - 1) = m * m }}
Z ::= Z + X
{{ fun st => st Z + st X * (st Y - 1) = m * m }};;
Y ::= Y - 1
{{ fun st => st Z + st X * st Y = m * m }}
END
{{ fun st => st Z + st X * st Y = m * m /\ st Y = 0 }} ->>
{{ fun st => st Z = m * m }}.

Theorem square_dec_correct : forall m,
dec_correct (square_dec m).
Proof. hammer_hook "Hoare2" "Hoare2.square_dec_correct".
intro n. verify.
-
destruct (st Y) as [| y']. apply False_ind. apply H0.
reflexivity.
simpl. rewrite <- minus_n_O.
assert (G : forall n m, n * S m = n + n * m). {
clear. intros. induction n. reflexivity. simpl.
rewrite IHn. omega. }
rewrite <- H. rewrite G. rewrite plus_assoc. reflexivity.
Qed.

Definition square_dec' (n : nat) : decorated :=
{{ fun st => True }}
X ::= n
{{ fun st => st X = n }};;
Y ::= X
{{ fun st => st X = n /\ st Y = n }};;
Z ::= 0
{{ fun st => st X = n /\ st Y = n /\ st Z = 0 }} ->>
{{ fun st => st Z = st X * (st X - st Y)
/\ st X = n /\ st Y <= st X }};;
WHILE ~(Y = 0) DO
{{ fun st => (st Z = st X * (st X - st Y)
/\ st X = n /\ st Y <= st X)
/\ st Y <> 0 }}
Z ::= Z + X
{{ fun st => st Z = st X * (st X - (st Y - 1))
/\ st X = n /\ st Y <= st X }};;
Y ::= Y - 1
{{ fun st => st Z = st X * (st X - st Y)
/\ st X = n /\ st Y <= st X }}
END
{{ fun st => (st Z = st X * (st X - st Y)
/\ st X = n /\ st Y <= st X)
/\ st Y = 0 }} ->>
{{ fun st => st Z = n * n }}.

Theorem square_dec'_correct : forall n,
dec_correct (square_dec' n).
Proof. hammer_hook "Hoare2" "Hoare2.square_dec'_correct".
intro n. verify.
-
rewrite minus_diag. omega.
-  subst.
rewrite mult_minus_distr_l.
repeat rewrite mult_minus_distr_l. rewrite mult_1_r.
assert (G : forall n m p,
m <= n -> p <= m -> n - (m - p) = n - m + p).
intros. omega.
rewrite G. reflexivity. apply mult_le_compat_l. assumption.
destruct (st Y). apply False_ind. apply H0. reflexivity.
clear. rewrite mult_succ_r. rewrite plus_comm.
apply le_plus_l.
-
rewrite <- minus_n_O. reflexivity.
Qed.

Definition square_simpler_dec (m : nat) : decorated :=
{{ fun st => st X = m }} ->>
{{ fun st => 0 = 0*m /\ st X = m }}
Y ::= 0
{{ fun st => 0 = (st Y)*m /\ st X = m }};;
Z ::= 0
{{ fun st => st Z = (st Y)*m /\ st X = m }}->>
{{ fun st => st Z = (st Y)*m /\ st X = m }};;
WHILE ~(Y = X) DO
{{ fun st => (st Z = (st Y)*m /\ st X = m)
/\ st Y <> st X }} ->>
{{ fun st => st Z + st X = ((st Y) + 1)*m /\ st X = m }}
Z ::= Z + X
{{ fun st => st Z = ((st Y) + 1)*m /\ st X = m }};;
Y ::= Y + 1
{{ fun st => st Z = (st Y)*m /\ st X = m }}
END
{{ fun st => (st Z = (st Y)*m /\ st X = m) /\ st Y = st X }} ->>
{{ fun st => st Z = m*m }}.

Theorem square_simpler_dec_correct : forall m,
dec_correct (square_simpler_dec m).
Proof. hammer_hook "Hoare2" "Hoare2.square_simpler_dec_correct".
intro m. verify.
rewrite mult_plus_distr_r. simpl. rewrite <- plus_n_O.
reflexivity.
Qed.

Definition two_loops_dec (a b c : nat) : decorated :=
{{ fun st => True }} ->>
{{ fun st => c = 0 + c /\ 0 = 0 }}
X ::= 0
{{ fun st => c = st X + c /\ 0 = 0 }};;
Y ::= 0
{{ fun st => c = st X + c /\ st Y = 0 }};;
Z ::= c
{{ fun st => st Z = st X + c /\ st Y = 0 }};;
WHILE ~(X = a) DO
{{ fun st => (st Z = st X + c /\ st Y = 0) /\ st X <> a }} ->>
{{ fun st => st Z + 1 = st X + 1 + c /\ st Y = 0 }}
X ::= X + 1
{{ fun st => st Z + 1 = st X + c /\ st Y = 0 }};;
Z ::= Z + 1
{{ fun st => st Z = st X + c /\ st Y = 0 }}
END
{{ fun st => (st Z = st X + c /\ st Y = 0) /\ st X = a }} ->>
{{ fun st => st Z = a + st Y + c }};;
WHILE ~(Y = b) DO
{{ fun st => st Z = a + st Y + c /\ st Y <> b }} ->>
{{ fun st => st Z + 1 = a + st Y + 1 + c }}
Y ::= Y + 1
{{ fun st => st Z + 1 = a + st Y + c }};;
Z ::= Z + 1
{{ fun st => st Z = a + st Y + c }}
END
{{ fun st => (st Z = a + st Y + c) /\ st Y = b }} ->>
{{ fun st => st Z = a + b + c }}.

Theorem two_loops_correct : forall a b c,
dec_correct (two_loops_dec a b c).
Proof. hammer_hook "Hoare2" "Hoare2.two_loops_correct". intros a b c. verify. Qed.

Fixpoint pow2 n :=
match n with
| 0 => 1
| S n' => 2 * (pow2 n')
end.

Definition dpow2_down (n : nat) :=
{{ fun st => True }} ->>
{{ fun st => 1 = (pow2 (0 + 1))-1 /\ 1 = pow2 0 }}
X ::= 0
{{ fun st => 1 = (pow2 (0 + 1))-1 /\ 1 = pow2 (st X) }};;
Y ::= 1
{{ fun st => st Y = (pow2 (st X + 1))-1 /\ 1 = pow2 (st X) }};;
Z ::= 1
{{ fun st => st Y = (pow2 (st X + 1))-1 /\ st Z = pow2 (st X) }};;
WHILE ~(X = n) DO
{{ fun st => (st Y = (pow2 (st X + 1))-1 /\ st Z = pow2 (st X))
/\ st X <> n }} ->>
{{ fun st => st Y + 2 * st Z = (pow2 (st X + 2))-1
/\ 2 * st Z = pow2 (st X + 1) }}
Z ::= 2 * Z
{{ fun st => st Y + st Z = (pow2 (st X + 2))-1
/\ st Z = pow2 (st X + 1) }};;
Y ::= Y + Z
{{ fun st => st Y = (pow2 (st X + 2))-1
/\ st Z = pow2 (st X + 1) }};;
X ::= X + 1
{{ fun st => st Y = (pow2 (st X + 1))-1
/\ st Z = pow2 (st X) }}
END
{{ fun st => (st Y = (pow2 (st X + 1))-1 /\ st Z = pow2 (st X))
/\ st X = n }} ->>
{{ fun st => st Y = pow2 (n+1) - 1 }}.

Lemma pow2_plus_1 : forall n,
pow2 (n+1) = pow2 n + pow2 n.
Proof. hammer_hook "Hoare2" "Hoare2.pow2_plus_1". induction n; simpl. reflexivity. omega. Qed.

Lemma pow2_le_1 : forall n, pow2 n >= 1.
Proof. hammer_hook "Hoare2" "Hoare2.pow2_le_1". induction n. simpl. constructor. simpl. omega. Qed.

Theorem dpow2_down_correct : forall n,
dec_correct (dpow2_down n).
Proof. hammer_hook "Hoare2" "Hoare2.dpow2_down_correct".
intro m. verify.
-
rewrite pow2_plus_1. rewrite <- H0. reflexivity.
-
rewrite <- plus_n_O.
rewrite <- pow2_plus_1. remember (st X) as n.
replace (pow2 (n + 1) - 1 + pow2 (n + 1))
with (pow2 (n + 1) + pow2 (n + 1) - 1) by omega.
rewrite <- pow2_plus_1.
replace (n + 1 + 1) with (n + 2) by omega.
reflexivity.
-
rewrite <- plus_n_O. rewrite <- pow2_plus_1.
reflexivity.
-
replace (st X + 1 + 1) with (st X + 2) by omega.
reflexivity.
Qed.

Example slow_assignment_dec (m : nat) : decorated
. Admitted.

Theorem slow_assignment_dec_correct : forall m,
dec_correct (slow_assignment_dec m).
Proof. hammer_hook "Hoare2" "Hoare2.slow_assignment_dec_correct".  Admitted.

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

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

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

Fixpoint fib n :=
match n with
| 0 => 1
| S n' => match n' with
| 0 => 1
| S n'' => fib n' + fib n''
end
end.

Lemma fib_eqn : forall n,
n > 0 ->
fib n + fib (Init.Nat.pred n) = fib (n + 1).
Proof. hammer_hook "Hoare2" "Hoare2.fib_eqn".
Admitted.

Definition T : string := "T".

Definition dfib (n : nat) : decorated
. Admitted.

Theorem dfib_correct : forall n,
dec_correct (dfib n).
Admitted.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

(*i $Id: DoubleSub.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Set Implicit Arguments.

Require Import ZArith.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.

Local Open Scope Z_scope.

Section DoubleSub.
 Variable w : Type.
 Variable w_0 : w.
 Variable w_Bm1 : w.
 Variable w_WW : w -> w -> zn2z w.
 Variable ww_Bm1 : zn2z w.
 Variable w_opp_c : w -> carry w.
 Variable w_opp_carry : w -> w.
 Variable w_pred_c : w -> carry w.
 Variable w_sub_c : w -> w -> carry w.
 Variable w_sub_carry_c : w -> w -> carry w.
 Variable w_opp : w -> w.
 Variable w_pred : w -> w.
 Variable w_sub : w -> w -> w.
 Variable w_sub_carry : w -> w -> w.

 (* ** Opposites ** *)
 Definition ww_opp_c x :=
  match x with
  | W0 => C0 W0
  | WW xh xl =>
    match w_opp_c xl with
    | C0 _ =>
      match w_opp_c xh with
      | C0 h => C0 W0
      | C1 h => C1 (WW h w_0)
      end
    | C1 l => C1 (WW (w_opp_carry xh) l)
    end
  end.

 Definition ww_opp x :=
  match x with
  | W0 => W0
  | WW xh xl =>
    match w_opp_c xl with
    | C0 _ => WW (w_opp xh) w_0
    | C1 l => WW (w_opp_carry xh) l
    end
  end.

 Definition ww_opp_carry x :=
  match x with
  | W0 => ww_Bm1
  | WW xh xl => w_WW (w_opp_carry xh) (w_opp_carry xl)
  end.

 Definition ww_pred_c x :=
  match x with
  | W0 => C1 ww_Bm1
  | WW xh xl =>
    match w_pred_c xl with
    | C0 l => C0 (w_WW xh l)
    | C1 _ =>
      match w_pred_c xh with
      | C0 h => C0 (WW h w_Bm1)
      | C1 _ => C1 ww_Bm1
      end
    end
  end.

 Definition ww_pred x :=
  match x with
  | W0 => ww_Bm1
  | WW xh xl =>
    match w_pred_c xl with
    | C0 l => w_WW xh l
    | C1 l => WW (w_pred xh) w_Bm1
    end
  end.

 Definition ww_sub_c x y :=
  match y, x with
  | W0, _ => C0 x
  | WW yh yl, W0 => ww_opp_c (WW yh yl)
  | WW yh yl, WW xh xl =>
    match w_sub_c xl yl with
    | C0 l =>
      match w_sub_c xh yh with
      | C0 h => C0 (w_WW h l)
      | C1 h => C1 (WW h l)
      end
    | C1 l =>
      match w_sub_carry_c xh yh with
      | C0 h => C0 (WW h l)
      | C1 h => C1 (WW h l)
      end
    end
  end.

 Definition ww_sub x y :=
  match y, x with
  | W0, _ => x
  | WW yh yl, W0 => ww_opp (WW yh yl)
  | WW yh yl, WW xh xl =>
    match w_sub_c xl yl with
    | C0 l => w_WW (w_sub xh yh) l
    | C1 l => WW (w_sub_carry xh yh) l
    end
  end.

 Definition ww_sub_carry_c x y :=
  match y, x with
  | W0, W0 => C1 ww_Bm1
  | W0, WW xh xl => ww_pred_c (WW xh xl)
  | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl))
  | WW yh yl, WW xh xl =>
    match w_sub_carry_c xl yl with
    | C0 l =>
      match w_sub_c xh yh with
      | C0 h => C0 (w_WW h l)
      | C1 h => C1 (WW h l)
      end
    | C1 l =>
      match w_sub_carry_c xh yh with
      | C0 h => C0 (w_WW h l)
      | C1 h => C1 (w_WW h l)
      end
    end
  end.

 Definition ww_sub_carry x y :=
  match y, x with
  | W0, W0 => ww_Bm1
  | W0, WW xh xl => ww_pred (WW xh xl)
  | WW yh yl, W0 => ww_opp_carry (WW yh yl)
  | WW yh yl, WW xh xl =>
    match w_sub_carry_c xl yl with
    | C0 l => w_WW (w_sub xh yh) l
    | C1 l => w_WW (w_sub_carry xh yh) l
    end
  end.

 (*Section DoubleProof.*)
  Variable w_digits : positive.
  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[+| c |]" :=
   (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99).
  Notation "[-| c |]" :=
   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).

  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
  Notation "[+[ c ]]" :=
   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, x at level 99).
  Notation "[-[ c ]]" :=
   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, x at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_w_Bm1   : [|w_Bm1|] = wB - 1.
  Variable spec_ww_Bm1   : [[ww_Bm1]] = wwB - 1.
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].

  Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|].
  Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB.
  Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1.

  Variable spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1.
  Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|].
  Variable spec_sub_carry_c :
   forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1.

  Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB.
  Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB.
  Variable spec_sub_carry :
	 forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB.

  Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]].
  Proof.
   destruct x as [ |xh xl];simpl. reflexivity.
   rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl)
   as [l|l];intros H;unfold interp_carry in H;rewrite <- H;
   rewrite Zopp_mult_distr_l.
   assert ([|l|] = 0).
    assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
   rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh)
   as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1.
   assert ([|h|] = 0).
    assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega.
   rewrite H2;reflexivity.
   simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_w_0;ring.
   unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_opp_carry;
   ring.
  Qed.

  Lemma spec_ww_opp : forall x, [[ww_opp x]] = (-[[x]]) mod wwB.
  Proof.
   destruct x as [ |xh xl];simpl. reflexivity.
   rewrite Zopp_plus_distr;rewrite Zopp_mult_distr_l.
   generalize (spec_opp_c xl);destruct (w_opp_c xl)
   as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z.
   rewrite spec_w_0;rewrite Zplus_0_r;rewrite wwB_wBwB.
   assert ([|l|] = 0).
    assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
   rewrite H0;rewrite Zplus_0_r; rewrite Zpower_2;
    rewrite Zmult_mod_distr_r;try apply lt_0_wB.
   rewrite spec_opp;trivial.
   apply Zmod_unique with (q:= -1).
   exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW (w_opp_carry xh) l)).
   rewrite spec_opp_carry;rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_opp_carry : forall x, [[ww_opp_carry x]] = wwB - [[x]] - 1.
  Proof.
   destruct x as [ |xh xl];simpl. rewrite spec_ww_Bm1;ring.
   rewrite spec_w_WW;simpl;repeat rewrite spec_opp_carry;rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1.
  Proof.
   destruct x as [ |xh xl];unfold ww_pred_c.
   unfold interp_carry;rewrite spec_ww_Bm1;simpl ww_to_Z;ring.
   simpl ww_to_Z;replace (([|xh|]*wB+[|xl|])-1) with ([|xh|]*wB+([|xl|]-1)).
   2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];
   intros H;unfold interp_carry in H;rewrite <- H. simpl;apply spec_w_WW.
   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
   assert ([|l|] = wB - 1).
     assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
   rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1).
   generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h];
   intros H1;unfold interp_carry in H1;rewrite <- H1.
   simpl;rewrite spec_w_Bm1;ring.
   assert ([|h|] = wB - 1).
     assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega.
   rewrite H2;unfold interp_carry;rewrite spec_ww_Bm1;rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]].
  Proof.
   destruct y as [ |yh yl];simpl. ring.
   destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)).
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]))
   with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring.
   generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H;
   unfold interp_carry in H;rewrite <- H.
   generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1;
   unfold interp_carry in H1;rewrite <- H1;unfold interp_carry;
   try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring.
   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
   change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1).
   generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h];
   intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z;
   try rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_sub_carry_c :
     forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1.
  Proof.
   destruct y as [ |yh yl];simpl.
   unfold Zminus;simpl;rewrite Zplus_0_r;exact (spec_ww_pred_c x).
   destruct x as [ |xh xl].
   unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB;
   repeat rewrite spec_opp_carry;ring.
   simpl ww_to_Z.
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1)
   with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring.
   generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)
   as [l|l];intros H;unfold interp_carry in H;rewrite <- H.
   generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1;
   unfold interp_carry in H1;rewrite <- H1;unfold interp_carry;
   try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring.
   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
   change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1).
   generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h];
   intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW;
   simpl ww_to_Z; try rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB.
  Proof.
   destruct x as [ |xh xl];simpl.
   apply Zmod_unique with (-1). apply spec_ww_to_Z;trivial.
   rewrite spec_ww_Bm1;ring.
   replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring.
   generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H;
   unfold interp_carry in H;rewrite <- H;simpl ww_to_Z.
   rewrite Zmod_small. apply spec_w_WW.
   exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)).
   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
   change ([|xh|] + -1) with ([|xh|] - 1).
   assert ([|l|] = wB - 1).
    assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega.
   rewrite (mod_wwB w_digits w_to_Z);trivial.
   rewrite spec_pred;rewrite spec_w_Bm1;rewrite <- H0;trivial.
  Qed.

  Lemma spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
  Proof.
   destruct y as [ |yh yl];simpl.
   ring_simplify ([[x]] - 0);rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial.
   destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)).
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]))
   with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring.
   generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H;
   unfold interp_carry in H;rewrite <- H.
   rewrite spec_w_WW;rewrite (mod_wwB w_digits w_to_Z spec_to_Z).
   rewrite spec_sub;trivial.
   simpl ww_to_Z;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
   rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial.
  Qed.

  Lemma spec_ww_sub_carry :
	 forall x y, [[ww_sub_carry x y]] = ([[x]] - [[y]] - 1) mod wwB.
  Proof.
   destruct y as [ |yh yl];simpl.
   ring_simplify ([[x]] - 0);exact (spec_ww_pred x).
   destruct x as [ |xh xl];simpl.
   apply Zmod_unique with (-1).
   apply spec_ww_to_Z;trivial.
   fold (ww_opp_carry (WW yh yl)).
   rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring.
   replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1)
   with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring.
   generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l];
   intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW.
   rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub;trivial.
   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
   rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial.
  Qed.

(* End DoubleProof. *)

End DoubleSub.


Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Psatz. (* mainly for lia *)
Require Import PeanoNat.
Require Import Coq.Arith.Compare_dec.
Import ListNotations.

(*

Prove SN of a System D Calculus with general type selections using NbE, following

    Andreas Abel - Towards Normalization by Evaluation for the βη-Calculus of Constructions (FLOPS '10)

We model partial functions using the fuel-based interpreters from Amin & Rompf 2017.

We omit intersection and self-recursive types for now.
*)

Declare Scope dsub.
(* ### Syntax ### *)

Definition id := nat.

Open Scope dsub.

Inductive sort : Type :=
| star : sort
| box : sort
.

Notation "⋆" := star : dsub.
Notation "◻" := box : dsub.

Inductive tm : Type :=
| TSort   : sort -> tm
| TTop    : tm
| TBot    : tm
| TAll    : tm  -> tm   -> tm
| TSel    : tm  -> tm
| TMem    : tm  -> tm   -> tm
(* | TBind   : tm  -> tm *)
(* | TAnd    : tm  -> tm -> tm *)
| tsubst  : tm  -> subst -> tm
| tvar    : id  -> tm
| ttyp    : tm  -> tm
| tabs    : tm  -> tm    -> tm
| tapp    : tm  -> tm    -> tm
(* | tunpack : tm  -> tm -> tm *)
with subst : Type :=
| sid     : subst
| sweak   : subst
| scomp   : subst -> subst -> subst
| sext    : subst -> tm    -> subst
.

Notation "# i" := (tvar i) (at level 0) : dsub.
Coercion TSort : sort >-> tm.
Notation "[ T ]" := (sext sid T) : dsub.

Definition tenv := list tm. (* Γ environment: static *)

Fixpoint lookup (Γ : tenv) (i : nat) : tm :=
  match Γ, i with
  | T :: [] , 0    => (tsubst T sweak)
  | _ :: Γ , (S n) => (tsubst (lookup Γ n) sweak)
  | _ , _         => TTop (* arbitrary *)
  end.

Inductive ctx_wf : tenv -> Prop :=
| cwf_empty :
    ctx_wf []

| cwf_cons  : forall Γ (s : sort) T,
    ctx_wf Γ ->
    has_type Γ T s ->
    ctx_wf (T :: Γ)

with has_type : tenv -> tm -> tm -> Prop :=
| t_star : forall Γ,
    ctx_wf Γ ->
    has_type Γ ⋆ ◻

| t_TTop : forall Γ,
    ctx_wf Γ ->
    has_type Γ TTop ⋆

| t_TBot : forall Γ,
    ctx_wf Γ ->
    has_type Γ TBot ⋆

| t_TMem : forall Γ T1 T2,
    has_type Γ T1 ⋆ ->
    has_type Γ T2 ⋆ ->
    has_type Γ (TMem T1 T2) ⋆

| t_TAll : forall Γ T1 T2 (s s' : sort),
    has_type Γ T1 s ->
    has_type (T1 :: Γ) T2 s' ->
    has_type Γ (TAll T1 T2) s'

| t_TSel : forall Γ t T1 T2,
    has_type Γ t (TMem T1 T2) ->
    has_type Γ (TSel t) ⋆

| t_var : forall Γ x ,
    ctx_wf Γ ->
    x < length Γ ->
    has_type Γ #x (lookup Γ x)

| t_typ : forall Γ T,
    has_type Γ T ⋆ ->
    has_type Γ (ttyp T) (TMem T T)

| t_abs: forall Γ T1 T2 (s : sort) t,
    has_type (T1 :: Γ) t T2 ->
    has_type Γ (TAll T1 T2) s ->
    has_type Γ (tabs T1 t) (TAll T1 T2)

| t_app : forall Γ t1 t2 T1 T2,
    has_type Γ t1 (TAll T1 T2) ->
    has_type Γ t2 T1 ->
    has_type Γ (tapp t1 t2) (tsubst T2 [ t2 ])

(* | t_and : forall Γ x T1 T2, *)
(*     has_type Γ $x T1 -> *)
(*     has_type Γ $x T2 -> *)
(*     has_type Γ $x (TAnd T1 T2) *)

(* | t_var_pack : forall Γ x T, *)
(*     closed 0 (length Γ) (TBind T) -> *)
(*     has_type Γ $x (open $x T) -> *)
(*     has_type Γ $x (TBind T) *)

(* | t_unpack : forall Γ t1 t2 T1 T1' T2, *)
(*     has_type Γ t1 (TBind T1) -> *)
(*     T1' = (open' Γ T1) -> *)
(*     closed 0 (length Γ) T2 -> *)
(*     closed 1 (length Γ) t2 -> *)
(*     has_type (T1' :: Γ) (open' Γ t2) T2 -> *)
(*     has_type Γ (tunpack t1 t2) T2 *)

| t_subst : forall Γ σ Δ t T,
    type_subst Γ σ Δ ->
    has_type Δ t T ->
    has_type Γ (tsubst t σ) (tsubst T σ)

| t_sub: forall Γ e T1 T2,
    has_type Γ e T1 ->
    stp Γ T1 T2 ->
    has_type Γ e T2

with type_subst : tenv -> subst -> tenv -> Prop :=
| t_sid : forall Γ ,
    ctx_wf Γ ->
    type_subst Γ sid Γ

| t_sweak : forall Γ T (s : sort),
    has_type Γ T s ->
    type_subst (T :: Γ) sweak Γ

| t_sext : forall Γ σ Δ t T (s : sort),
    type_subst Γ σ Δ ->
    has_type Δ T s ->
    has_type Γ t (tsubst T σ) ->
    type_subst Γ (sext σ t) (T :: Δ)

| t_scomp : forall Γ τ Δ σ ϒ,
    type_subst Γ τ Δ ->
    type_subst Δ σ ϒ ->
    type_subst Γ (scomp σ τ) ϒ

with stp : tenv -> tm -> tm -> Prop :=
| stp_refl : forall Γ T1 T2,
    equal_tm Γ T1 T2 ⋆ ->
    stp Γ T1 T2

| stp_top : forall Γ T,
    has_type Γ T ⋆ ->
    stp Γ T TTop

| stp_bot : forall Γ T,
    has_type Γ T ⋆ ->
    stp Γ TBot T

| stp_mem : forall Γ S1 S2 T1 T2,
    stp Γ S2 S1 ->
    stp Γ T1 T2 ->
    stp Γ (TMem S1 T1) (TMem S2 T2)

| stp_sel1 : forall Γ t T,
    has_type Γ t (TMem T TTop) ->
    stp Γ T (TSel t)

| stp_sel2 : forall Γ t T,
    has_type Γ t (TMem TBot T) ->
    stp Γ (TSel t) T

| stp_selx : forall Γ t T1 T2,
    has_type Γ t (TMem T1 T2) ->
    stp Γ (TSel t) (TSel t)

| stp_all : forall Γ S1 S2 T1 T2,
    stp Γ S2 S1 ->
    stp (S2 :: Γ) T1 T2 ->
    has_type Γ (TAll S1 T1) ⋆ ->
    has_type Γ (TAll S2 T2) ⋆ ->
    stp Γ (TAll S1 T1) (TAll S2 T2)

  (* | stp_bindx: forall Γ T1 T1' T2 T2', *)
  (*     stp (T1' :: Γ) T1' T2' -> *)
  (*     T1' = (open' Γ T1) -> *)
  (*     T2' = (open' Γ T2) -> *)
  (*     closed 0 (length  Γ) (TBind T1) -> *)
  (*     closed 0 (length  Γ) (TBind T2) -> *)
  (*     stp Γ (TBind T1) (TBind T2) *)

  (* | stp_and11: forall Γ T1 T2 T, *)
  (*     stp Γ T1 T -> *)
  (*     closed 0 (length Γ) T2 -> *)
  (*     type T2 -> *)
  (*     stp Γ (TAnd T1 T2) T *)

  (* | stp_and12: forall Γ T1 T2 T, *)
  (*     stp Γ T2 T -> *)
  (*     closed 0 (length Γ) T1 -> *)
  (*     type T1 -> *)
  (*     stp Γ (TAnd T1 T2) T *)

  (* | stp_and2: forall Γ T1 T2 T, *)
  (*     stp Γ T T1 -> *)
  (*     stp Γ T T2 -> *)
  (*     stp Γ T (TAnd T1 T2) *)

| stp_trans : forall Γ S T U,
    stp Γ S T ->
    stp Γ T U ->
    stp Γ S U

with equal_tm : tenv -> tm -> tm -> tm -> Prop := (* TODO*)
| eq_refl : forall Γ t T,
    has_type Γ t T ->
    equal_tm Γ t t T

with equal_subst : tenv -> subst -> subst -> Prop := (* TODO*)
.
Hint Constructors has_type : dsub.
Hint Constructors stp : dsub.
Hint Constructors type_subst : dsub.
Hint Constructors equal_tm : dsub.
Hint Constructors equal_subst : dsub.
Hint Constructors ctx_wf : dsub.

(* syntax predicates for normal forms and neutral terms *)
Inductive Nf : tm -> Prop :=
| Nf_TSort : forall (s : sort), Nf (TSort s)
| Nf_TTop  : Nf TTop
| Nf_TBot  : Nf TBot
| Nf_TAll  : forall {T1 T2},
    Nf T1 ->
    Nf T2 ->
    Nf (TAll T1 T2)
| Nf_TMem : forall {T1 T2},
    Nf T1 ->
    Nf T2 ->
    Nf (TMem T1 T2)
| Nf_ttyp : forall {T}, (* TODO not sure if T needs to be normal*)
    Nf T ->
    Nf (ttyp T)
| Nf_tabs : forall {T t},
    Nf T ->
    Nf t ->
    Nf (tabs T t)
| Nf_Ne : forall {t},
    Ne t ->
    Nf t
with Ne : tm -> Prop :=
| Ne_var : forall x, Ne #x
| Ne_tapp : forall {t1 t2},
    Ne t1 ->
    Nf t2 ->
    Ne (tapp t1 t2)
| Ne_TSel : forall {t},
    Ne t ->
    Ne (TSel t)
.

(* Semantic normal forms of NbE*)
Inductive Dom : Type :=
| DSort : sort -> Dom
| DTop  : Dom
| DBot  : Dom
| DAll  : Dom -> Dom -> Dom
| DMem  : Dom -> Dom -> Dom
| Dabs  : list Dom -> tm -> Dom
| Dtyp  : list Dom -> tm -> Dom (* TODO not sure whether closure or Dom*)
| DNe   : DomNe -> Dom
| Drefl : Dom -> DomNe -> Dom
with DomNf : Type :=
| Dreif : Dom -> Dom -> DomNf
with DomNe : Type :=
| Dvar  : id -> DomNe
| Dapp  : DomNe -> DomNf -> DomNe
| DSel  : DomNe -> DomNe
.

Notation "$ i" := (Dvar i) (at level 0) : dsub.
Notation "↓⟨ D1 ⟩ D2" := (Dreif D1 D2) (at level 0) : dsub.
Notation "↑⟨ D ⟩ ne" := (Drefl D ne) (at level 0) : dsub.
Coercion DSort : sort >-> Dom.
Coercion DNe : DomNe >-> Dom.

Definition denv := list Dom.

Inductive Result (T : Type) : Type :=
| Done : T -> Result T
| NoFuel : Result T
| Error : Result T
.
Arguments Done {T}.
Arguments NoFuel {T}.
Arguments Error {T}.

(* evaluation *)
Fixpoint eval (fuel : nat) (γ : denv) (t : tm) : Result Dom :=
  match fuel with
  | 0   => NoFuel
  | S n =>
    match t with
    | TSort s => Done (DSort s)
    | TTop => Done DTop
    | TBot => Done DBot
    | TAll T1 T2 =>
      match (eval n γ T1) with
      | Done D1 => Done (DAll D1 (Dabs γ T2))
      | err     => err
      end
    | TSel t =>
      match (eval n γ t) with
      | Done d => eval_sel n d
      | err    => err
      end
    | TMem T1 T2 =>
      match (eval n γ T1) with
      | Done D1 =>
        match (eval n γ T2) with
        | Done D2 => Done (DMem D1 D2)
        | err     => err
        end
      | err     => err
      end
    | tsubst t σ =>
      match (eval_subst n γ σ) with
      | Done γ' => eval n γ' t
      | Error   => Error
      | NoFuel  => NoFuel
      end
    | #x =>
      match List.nth_error γ x with
      | Some D => Done D
      | None   => Error
      end
    | ttyp T   => Done (Dtyp γ T)
    | tabs T t => Done (Dabs γ t)
    | tapp t1 t2 =>
      match (eval n γ t1) with
      | Done d1 =>
        match (eval n γ t2) with
        | Done d2 => eval_app n d1 d2
        | err     => err
        end
      | err     => err
      end
    end
  end
with eval_subst (fuel : nat) (γ : denv) (σ : subst) : Result denv :=
  match fuel with
  | 0   => NoFuel
  | S n =>
    match σ with
    | sid        => Done γ
    | sweak      =>
      match γ with
      | _ :: γ' => Done γ'
      | _      => Error
      end
    | scomp σ' τ =>
      match (eval_subst n γ τ) with
      | Done γ' => (eval_subst n γ' σ')
      | err => err
      end
    | sext σ t   =>
      match (eval_subst n γ σ) with
      | Done γ' =>
        match (eval n γ t) with
        | Done D => Done (D :: γ')
        | NoFuel => NoFuel
        | Error  => Error
        end
      | err     => err
      end
    end
  end
with eval_app (fuel : nat) (d1 d2 : Dom) : Result Dom :=
  match fuel with
  | 0   => NoFuel
  | S n =>
    match d1 with
    | Dabs γ' t => eval n (d2 :: γ') t
    | Drefl (DAll D1 D2) ne =>
      match eval_app n D2 d2 with
      | Done D2d2 => Done (↑⟨ D2d2 ⟩ (Dapp ne (↓⟨ D1 ⟩ d2)))
      | err       => err
      end
    | _         => Error
    end
  end
with eval_sel (fuel : nat) (d : Dom) : Result Dom :=
  match fuel with
  | 0   => NoFuel
  | S n =>
    match d with
    | Dtyp γ T => eval n γ T
    | Drefl (DMem D1 D2) ne => Done (↑⟨ ⋆ ⟩ (DSel ne))
    | _ => Error
    end
  end.

(* readback *)
Fixpoint reify (fuel lvl : nat) (d : Dom) : Result ({ t : tm | Nf t }) :=
  match fuel with
  | 0 => NoFuel
  | S n =>
    match d with
    | DSort s => Done (exist _ _ (Nf_TSort s))
    | DTop    => Done (exist _ _ Nf_TTop)
    | DBot    => Done (exist _ _ Nf_TBot)
    | DAll D1 D2 =>
      match (reify n lvl D1) with
      | Done (exist _ _ NfT1) =>
        match (eval_app n D2 (↑⟨ D1 ⟩ $lvl)) with
        | Done   D2x =>
          match (reify n (S lvl) D2x) with
          | Done (exist _ _ NfT2) =>
            Done (exist _ _ (Nf_TAll NfT1 NfT2))
          | err => err
          end
        | NoFuel     => NoFuel
        | Error      => Error
        end
      | err => err
      end
    | DMem D1 D2 =>
      match (reify n lvl D1) with
      | Done (exist _ _ NfT1) =>
        match (reify n lvl D2) with
        | Done (exist _ _ NfT2) =>
          Done (exist _ _ (Nf_TMem NfT1 NfT2))
        | err => err
        end
      | err => err
      end
    | Dtyp γ T =>
      match (eval n γ T) with
      | Done D =>
        match (reify n lvl D) with
        | Done (exist _ _ NfT) => Done (exist _ _ (Nf_ttyp NfT))
        | err => err
        end
      | Error  => Error
      | NoFuel => NoFuel
      end
    | DNe Dn =>
      match (reify_ne n lvl Dn) with
      | Done (exist _ _ NeN) => Done (exist _ _ (Nf_Ne NeN))
      | Error => Error
      | NoFuel => NoFuel
      end
    | _ => Error
    end
  end
with reify_nf  (fuel lvl : nat) (d : DomNf) : Result ({ t : tm | Nf t }) :=
  match fuel with
  | 0 => NoFuel
  | S n =>
    match d with
    | Dreif (DAll D1 D2) Df =>
      match (reify n lvl D1) with
      | Done (exist _ _ NfT1) =>
        match (eval_app n D2 (↑⟨ D1 ⟩ $lvl)) with
        | Done   D2x =>
          match (eval_app n Df (↑⟨ D1 ⟩ $lvl)) with
          | Done Dfx =>
            match (reify_nf n (S lvl) (↓⟨ D2x ⟩ Dfx)) with
            | Done (exist _ _ Nft) =>
              Done (exist _ _ (Nf_tabs NfT1 Nft))
            | err => err
            end
          | NoFuel   => NoFuel
          | Error    => Error
          end
        | NoFuel     => NoFuel
        | Error      => Error
        end
      | err => err
      end
    | Dreif _ D => (reify n lvl D)
    end
  end
with reify_ne  (fuel lvl : nat) (d : DomNe) : Result ({ t : tm | Ne t }) :=
  match fuel with
  | 0 => NoFuel
  | S n =>
      match d with
      | $x => Done (exist _ _ (Ne_var (Nat.sub lvl (S x))))
      | Dapp nd1 d2 =>
        match (reify_ne n lvl nd1) with
        | Done (exist _ _ Net1) =>
          match (reify_nf n lvl d2) with
          | Done (exist _ _ Nft2) => Done (exist _ _ (Ne_tapp Net1 Nft2))
          | Error => Error
          | NoFuel => NoFuel
          end
        | err => err
        end
      | DSel nd => Error
      end
  end.

(* normalization *)
Fixpoint eval_ctx (fuel : nat) (Γ : tenv) : Result denv :=
  match fuel with
  | 0 => NoFuel
  | S n =>
    match Γ with
    | [] => Done []
    | T :: Γ =>
      match (eval_ctx n Γ) with
      | Done γ =>
        match (eval n γ T) with
        | Done D => Done ((↑⟨ D ⟩ $(length Γ)) :: γ)
        | Error  => Error
        | NoFuel => NoFuel
        end
      | err => err
      end
    end
  end.

(* TODO show length Γ = length (eval_ctx n Γ) for sufficient n *)

(* term nbe *)
Definition nbe (fuel : nat) (Γ : tenv) (T t : tm) : Result ({ t : tm | Nf t }) :=
  match (eval_ctx fuel Γ) with
  | Done γ =>
    match (eval fuel γ T) with
    | Done DT =>
      match (eval fuel γ t) with
      | Done Dt => reify_nf fuel (length Γ) (↓⟨ DT ⟩ Dt)
      | Error   => Error
      | NoFuel  => NoFuel
      end
    | Error   => Error
    | NoFuel  => NoFuel
    end
  | Error  => Error
  | NoFuel => NoFuel
  end.

(* type nbe *)
Definition Nbe (fuel : nat) (Γ : tenv) (T : tm) := nbe fuel Γ ◻ T.

(* TODO determinism and monotonicity properties for all the partial functions in this file*)
(* TODO it's high time we used monadic syntax and combinators for these *)

(* Kind syntax. Term dependency is erased. *)
Inductive Knd : Type :=
| K_tm   : Knd
| K_star : Knd
| K_fun  : Knd -> Knd -> Knd
.
Notation "⋄" := K_tm : dsub.
Notation "∗" := K_star : dsub.
Notation "κ1 ⇒ κ2" := (K_fun κ1 κ2) (at level 0, right associativity) : dsub.

(* Abel defines SKnd and PSKnd as a grammar, to restrict the possible occurrences of SK_tm (⋄).
   A literal translation turns out to be cumbersome to use. So we opt to have
   two predicates on the Knd syntax instead: *)
Inductive SKnd : Knd -> Type := (* simple kind *)
| SK_tm : SKnd K_tm
| SK_P  : forall {κ}, PSKnd κ -> SKnd κ
with PSKnd : Knd -> Type :=     (* proper simple kinds *)
| PSK_star : PSKnd K_star
| PSK_fun  : forall {κ1 κ2},
    SKnd κ1 -> PSKnd κ2 -> PSKnd (κ1 ⇒ κ2)
.

(* simple kinding environment *)
Definition kenv := list Knd.

(* assign the simple/erased kind to kind expressions  *)
(* TODO: need to include type selections? *)
Inductive has_skind : kenv -> tm -> Knd -> Prop :=
| k_tvar : forall γ κ, has_skind (κ :: γ) #0 κ
| k_tabs : forall γ T1 κ1 T2 κ2,
    has_skeleton γ T1 κ1 ->
    has_skind (κ1 :: γ) T2 κ2 ->
    has_skind γ (tabs T1 T2) (κ1 ⇒ κ2)
| k_tapp : forall γ T1 κ1 T2 κ2,
    has_skind γ T1 (κ1 ⇒ κ2) ->
    has_skind γ T2 κ1 ->
    has_skind γ (tapp T1 T2) κ2
| k_tsubst : forall γ σ δ T κ,
    subst_skind γ σ δ ->
    has_skind δ T κ ->
    has_skind γ (tsubst T σ) κ
with subst_skind : kenv -> subst -> kenv -> Prop :=
| sk_sid : forall γ, subst_skind γ sid γ
| sk_sweak : forall γ κ, subst_skind (κ :: γ) sweak γ
| sk_sext : forall γ σ δ T κ,
    subst_skind γ σ δ ->
    has_skind γ T κ ->
    subst_skind γ (sext σ T) (κ :: δ)
| sk_scomp : forall γ τ δ σ υ,
    subst_skind γ τ δ ->
    subst_skind δ σ υ ->
    subst_skind γ (scomp σ τ) υ
with has_skeleton : kenv -> tm -> Knd -> Prop := (* replaces the term-dependency by ⋄ *)
| sk_star : forall γ, has_skeleton γ ⋆ K_star
| sk_tm :   forall γ T,
    has_skind γ T K_star ->
    has_skeleton γ T ⋄
| sk_TAll : forall γ T1 κ1 T2 κ2,
    has_skeleton γ T1 κ1 ->
    has_skeleton (κ1 :: γ) T2 κ2 ->
    has_skeleton γ (TAll T1 T2) (κ1 ⇒ κ2)
| sk_tsubst : forall γ σ δ T κ,
    subst_skind γ σ δ ->
    has_skeleton δ T κ ->
    has_skeleton γ (tsubst T σ) κ
.

(* TODO prove that under well-formed kinding context γ, the above judgments classify terms with a κ such that SKnd κ *)

Inductive Klass : Type :=
| Kind : Klass
| Skel : Klass
.

Fixpoint shape (γ : kenv) (T : tm) {struct T} : (Knd * Klass) :=
  match T with
  | ⋆ => (∗, Skel)
  | TAll T1 T2 =>
    let κ1 := match (shape γ T1) with
             | (κ , Skel) => κ
             | _          => ⋄
             end
    in let κ2 := match shape (κ1 :: γ) T2 with
                | (κ , Skel) => κ
                | _          => ⋄
                end
       in (κ1 ⇒ κ2, Skel)
  (* | TSel x => _ *)
  (* | TMem x x0 => _ *)
  | tsubst T σ => shape (subst_kind γ σ) T
  | #0 => match γ with
         | []     => (⋄, Kind)
         | κ :: _ => (κ, Kind)
         end
  (* | ttyp x => _ *)
  | tabs T1 T2 =>
    let κ1 := match (shape γ T1) with
             | (κ , Skel) => κ
             | _          => ⋄
             end
    in let κ2 := match shape (κ1 :: γ) T2 with
                | (κ , Kind) => κ
                |  _         => ∗
                end
       in (κ1 ⇒ κ2, Kind)
  | tapp T1 T2 => match (shape γ T1) with
                 | ((K_fun _ κ) , Kind) => (κ, Kind)
                 |  _                   => (⋄, Kind)
                 end
  | _ => (⋄, Kind) (* TODO might need to have proper partial function *)
  end
with subst_kind (γ : kenv) (σ : subst) : kenv :=
       match σ with
       | sid => γ
       | sweak => match γ with
                 | []      => []
                 | _ :: γ' => γ'
                 end
       | scomp σ τ => subst_kind (subst_kind γ τ) σ
       | sext σ t  =>
         let κ := match (shape γ t) with
                 | (κ , Skel) => κ
                 | _          => ⋄
                 end
         in κ :: (subst_kind γ σ)
       end
.

Definition kind_of (γ : kenv) (T : tm) : Knd :=
  match shape γ T with
  | (κ , Kind) => κ
  |  _         => ∗
  end.
Definition skeleton_of (γ : kenv) (T : tm) : Knd :=
  match shape γ T with
  | (κ , Skel) => κ
  | _          => ⋄
  end.

(* TODO: Lemma 3, 4, and Theorem 1 in Abel's paper *)

Require Import Coq.Relations.Relation_Definitions.

Fixpoint Knd_interp (κ : Knd): Type :=
  match κ with
  | ⋄       => unit
  | ∗       => relation (Dom * unit)
  | κ1 ⇒ κ2 => (Dom * (Knd_interp κ1)) -> Knd_interp κ2 (* TODO need partial function! *)
  end.
Notation "⟨ κ ⟩" := (Knd_interp κ) (at level 0) : dsub.

(* TODO: set notation & prove these are PERs *)
Definition 𝒩ℰ : relation DomNe :=
  fun e e' => forall lvl, exists fuel, exists nf, reify_ne fuel lvl e = Done nf /\ reify_ne fuel lvl e' = Done nf.

Definition 𝒩ℱ : relation DomNf :=
  fun d d' => forall lvl, exists fuel, exists nf, reify_nf fuel lvl d = Done nf /\ reify_nf fuel lvl d' = Done nf.

Fixpoint Knd_inhabitant (κ : Knd) : ⟨ κ ⟩ :=
  match κ with
  | ⋄          => tt
  | ∗          => (fun x y => (* TODO nicify notation *)
                    match x, y with
                    | (DNe e, tt), (DNe e', tt) => 𝒩ℰ e e'
                    | _          , _            => False
                    end)
  | κ1 ⇒ κ2   => fun _ => Knd_inhabitant κ2
  end.
Notation "⊥⟨ κ ⟩" := (Knd_inhabitant κ) (at level 0) : dsub.

(* these should be PERs, which we'll have to verify externally ! *)
Notation "⟪ κ ⟫" := (relation (Dom * ⟨ κ ⟩)) (at level 0) : dsub.

Lemma term_star_coincides : ⟪ ⋄ ⟫ = ⟨ ∗ ⟩. auto. Qed.

(* TODO: extensional equality of κ inhabitants, indexed by ⟨ κ ⟩ *)

Inductive rel_elem {A} (a : A) (R : relation A): Prop :=
| meml : forall {b}, R a b -> rel_elem a R
| memr : forall {b}, R b a -> rel_elem a R
.
Arguments meml {A} {a} {R} {b}.
Arguments memr {A} {a} {R} {b}.
Notation "a ⋵ R"      := (rel_elem a R)           (at level 0) : dsub.
Notation "a == b ∈ R" := (R a b)                  (at level 0, only parsing) : dsub.
Notation "R1 ⊑ R2"    := (forall x y, R1 x y -> R2 x y) (at level 0) : dsub.

Definition Π (κ1 κ2 : Knd) (𝒦1 : ⟪ κ1 ⟫) (𝒦2 : forall {x}, x ⋵ 𝒦1 -> ⟪ κ2 ⟫): ⟪ κ1 ⇒ κ2 ⟫ :=
  fun X Y =>
    match X, Y with
    | (F, ℱ), (F', ℱ') =>
      forall A B 𝒜 ℬ, forall (p : (A, 𝒜) == (B, ℬ) ∈ 𝒦1),
          exists fuel FA F'B, eval_app fuel F A = Done FA /\ eval_app fuel F' B = Done F'B ->
                              (FA, ℱ (A, 𝒜)) == (F'B, ℱ'(B, ℬ)) ∈ (𝒦2 (meml p))

    end.
(* TODO show that Π is closed under the PER property *)

(* A (potentially major?) pain point:

   Abel's paper stipulates that simple kinds of the form κ ⇒ ⋄ should be treated as ⋄. The
   justification being that the former is a "subset" of the latter.
   This would complicate all our definitions indexed by a simple kind/skeleton syntax.

   Consider the particular instantiation of Π which models impredicative universal quantification:
*)
Check (Π ∗ ⋄).           (* forall 𝒦1 : ⟪ ∗ ⟫, (forall x : Dom * ⟨ ∗ ⟩, (x) ⋵ (𝒦1) -> ⟪ ⋄ ⟫) -> ⟪ ∗ ⇒ ⋄ ⟫ *)
(* This works as expected only if we treat ∗ ⇒ ⋄ = ⋄. Then the type becomes

       forall 𝒦1 : ⟪ ∗ ⟫, (forall x : Dom * ⟨ ∗ ⟩, (x) ⋵ (𝒦1) -> ⟪ ⋄ ⟫) -> ⟪ ⋄ ⟫

   which is identical to

       forall 𝒦1 : ⟪ ∗ ⟫, (forall x : Dom * ⟨ ∗ ⟩, (x) ⋵ (𝒦1) -> ⟨ ∗ ⟩) -> ⟨ ∗ ⟩    (by ⟪ ⋄ ⟫ = ⟨ ∗ ⟩)

   Let's compare ⟪ ⋄ ⟫ and ⟪ ∗ ⇒ ⋄ ⟫:
 *)
Eval red in ⟪ ⋄ ⟫.     (* Dom * ⟨ ⋄ ⟩     -> Dom * ⟨ ⋄ ⟩      -> Prop *)
Eval red in ⟪ ∗ ⇒ ⋄ ⟫. (* Dom * ⟨ ∗ ⇒ ⋄ ⟩ -> Dom * ⟨ ∗ ⇒ ⋄ ⟩ -> Prop *)
(*
   ⟨ ⋄ ⟩ and ⟨ ∗ ⇒ ⋄ ⟩ are different beasts:
*)
Eval red in ⟨ ⋄ ⟩.     (* unit *)
Eval red in ⟨ ∗ ⇒ ⋄ ⟩. (* Dom * relation (Dom * unit) -> unit *)
(*
   Options are :
   1) Literally enforce ∗ ⇒ ⋄ = ⋄ in the ⟨ _ ⟩ and ⟪ _ ⟫ definitions by pattern matching.
      However, that makes Coq's automagical type checking machinery stumble,
      and snowballs into most of the kind-indexed definitions.
      These need to be rewritten using refine, producing more complicated and less legible terms.

   2) Explicitly transform ⟪ κ ⇒ ⋄ ⟫ into ⟪ ⋄ ⟫ by replacing the attached
      semantic operators of type ⟨ κ ⇒ ⋄ ⟩ with unit values. Expect some pollution of the kind-indexed
      definitions, unclear to what extent. Probably less impactful if we have an implicit
      coercion.

   3) Have several specialized versions of Π for different kind pairs and in other places where
      ∗ ⇒ ⋄ = ⋄ has an impact.
*)

(** Towards PER semantics for abstract types

Musings:

    Γ ⊢ T : ⋆                --> (nbe T, ⟦ T ⟧) == (nbe T, ⟦ T ⟧) ∈ ⟦ ⋆ ⟧ : ⟪ ⋆ ⟫ = PER Dom×(PER Dom×())  (IH)
    ------------------------
    Γ ⊢ <type T> : TMem T T  --> (type T, ()) == (type T, ()) ∈ [[ TMem T T ]] : ⟨ ⋆ ⟩ = PER Dom×()      (goal)

The IH above is interesting, since we get the normal form of the type T with its semantic role, similar
to the ECOOP development. We lose this information in the conclusion, because the "type T" term is not
supposed to have a "semantic role" in Abel's terminology. It should hopefully be possible to design
[[ TMem T T ]] in a way that we could recover this pairing. There seems to be a connection to
Geuver's 1994 work, where he enriches the semantics for existentials/sigmas
so that all interpretations are metalanguage functions accepting the witness of an existential
(kind of like a state monad).

Consider the proposed formation rule for type selection:

    Γ ⊢ t : TMem T U --> (nbe t, ()) == (nbe t, ()) ∈ [[ TMem T U ]]: ⟨ ⋆ ⟩ = PER Dom×()                  (IH)
    ----------------
    Γ ⊢ t.Type : ⋆   --> (nbe t.Type, [[ t.Type ]])^2 ∈ [[ ⋆ ]] : ⟪ ⋆ ⟫ = PER Dom×(PER Dom×())          (goal)

Again, [[ TMem T U ]] must provide enough information to recover the pairing of nbe t with
its semantic type [[ t.Type ]].

Subtyping rules:

The fundamental lemma for subtyping should have the obvious subset inclusion interpretations.
Experimenting with the ECOOP paper's proofs, it turned out that it was difficult
to have the fundamental lemma satisfy all the subtyping rules on type selections and
dependent function types simultaneously. So far we only know that the proof goes through
with the peculiar choice of a number-indexed semantic domain pairing values and sets.
The pairing of semantic normal forms with their semantic role in Abel's nbe development
serves a very similar function, but does not require the number index (I am hesitant to call
it a step index, since it is not an approximation of evaluation steps).

Consider subtyping of abstract types:

     stp_sel1 : forall Γ t T,
        has_type Γ t (TMem T TTop)  --> (nbe t, ()) == (nbe t, ()) ∈ [[TMem T TTop]] :  ⟨ ⋆ ⟩ = PER Dom×() (IH)
        ---------------------------
        stp Γ T (TSel t)            --> [[T]] ⊆ [[TSel t]]

     stp_sel2 : forall Γ t T,
        has_type Γ t (TMem TBot T)  --> (nbe t, ()) == (nbe t, ()) ∈ [[TMem TBot T]] :  ⟨ ⋆ ⟩ = PER Dom×() (IH)
        --------------------------
        stp Γ (TSel t) T            --> [[TSel t]] ⊆ [[T]]

     stp_selx : forall Γ t T1 T2,
        has_type Γ t (TMem T1 T2)
        -------------------------
        stp Γ (TSel t) (TSel t)     --> [[TSel t]] ⊆ [[TSel t]] trivial

Existential types:

Intuitively, we could consider that <type T> values are packages of type ∃x:⋆,Unit.

Formation

    Γ ⊢ κ : ◻                    --> (nbe κ, [[κ]]) == (nbe κ, [[κ]]) ∈ eq(|κ|) : Per D×⟨ |κ| ⟩
    Γ, x:κ ⊢ T : ⋆               --> (nbe T, [[T]] == (nbe T, [[T]]) ∈ [[ ⋆ ]] : ⟪ ⋆ ⟫ = PER Dom×(PER Dom×())
    ---------------------------
    Γ ⊢ ∃x:κ.T : ⋆               --> (nbe ∃x:κ.T, [[∃x:κ.T]]) == (nbe ∃x:κ.T, [[∃x:κ.T]]) ∈ [[ ⋆ ]]

Intro

   Γ ⊢ T : κ                     --> (nbe T, [[T]]) == (nbe T, [[T]]) ∈ [[ κ ]] : Per D×⟨ κ ⟩
   Γ,x:κ ⊢ t : U                 --> (nbe t, ())    == (nbe t, ())    ∈ [[ U ]] : PER Dom×()
   ---------------------------
   Γ ⊢ pack (T,t) : ∃x:κ.T       --> (nbe pack (T,t), ()) == (nbe pack (T,t), ()) ∈ [[ ∃x:κ.T ]] : PER Dom×()

Elim

   Γ ⊢ t1 : ∃x:κ.T                  --> (nbe t1, ()) == (nbe t1, ()) ∈ [[ ∃x:κ.T ]] : PER Dom×()
   Γ,x:κ,y:T ⊢ t2 : U               --> (nbe t2, ()) == (nbe t2, ()) ∈ [[ U ]]      : Per Dom×()
   ------------------------------
   Γ ⊢ unpack t1 as (x,y) in t2 : U --> (nbe unpack .., ())^2 ∈ [[ U ]]

Any particular conditions on U? if existentials are weak, then x,y cannot occur in U, e.g. Γ ⊢ U : ⋆
Considering that we could express first projection of the type as (unpack t1 as (x,_) in x : ⋆),
thus having an analogue for type selection, we then realize that U should be
at the kind level, i.e., Γ ⊢ U : ◻, resp. specialized to ⋆. Thus, we have another eliminator
at the type level:

   Γ ⊢ t1 : ∃x:κ.T                  --> (nbe t1, ()) == (nbe t1, ()) ∈ [[ ∃x:κ.T ]] : PER Dom×()
   --------------------------------
   Γ ⊢ unpack t1 as (x,y) in x : κ  --> (nbe unpack t1 ..., [[unpack ... ]]) == (nbe t1, [[unpack ... ]]) ∈ [[ |κ| ]] : PER Dom×⟨ |κ| ⟩

which leads to no ambiguity. We could hence stipulate t.type := unpack t1 as (x,y) in x as derived syntax.
This also shows that we have to assign different semantics to these projections.

[[ ∃x:κ.T ]] : PER Dom×() =  ρ => {{ (d1, ()), (d2, ()) |         }}

[[ t.type ]] : PER Dom×⟨ |κ| ⟩

e.g. [[ t.type ]] : PER Dom×⟨ ⋆ ⟩ = PER Dom×(PER Dom×())

Another important remaining question is if the type-level projection above is already sufficient
to make the system inconsistent, or whether inconsistency only occurs if the strong second projection
is added. I.e., when do we cross the red line into inconsistency territory?

Definition 𝒯𝒮ℯ𝓁 (𝓉 : ⟪ ⋄ ⟫): ⟪ ∗ ⟫

   input:  PER (Dom × < ⋄ >) == PER (Dom × ())
   output: PER (Dom × < ∗ >) == PER (Dom × (PER Dom × ()))

   {{ (D1, 𝒟1) , (D2, 𝒟2) |    }}
 *)

Definition 𝒯ℳℯ𝓂 (𝒯1 𝒯2 : ⟪ ∗ ⟫): ⟪ ∗ ⟫ :=
  fun X Y =>
    match X, Y with
    | (d1, 𝒟1), (d2, 𝒟2) => (* TODO: does it make a difference if we swap the existential quantifiers? *)
      exists fuel D1 D2, eval_sel fuel d1 = Done D1 /\ eval_sel fuel d2 = Done D2 /\
                    exists (𝒳 : ⟪ ∗ ⟫), 𝒯1 ⊑ 𝒳 /\ 𝒳 ⊑ 𝒯2 /\ (D1, 𝒟1) == (D2, 𝒟2) ∈ 𝒳
    end.
(* TODO alternative would be to let 𝒳 be a function kind ∗ ⇒ ∗, like a Σ-type, and plug in the witnesses. *)

(* Main result *)
Theorem completeness : forall {Γ t t' T}, equal_tm Γ t t' T -> exists n nft nft', nbe n Γ T t = Done nft /\ nbe n Γ T t' = Done nft' /\ nft = nft'.
Admitted.

Corollary strong_normalization : forall {Γ t T}, has_type Γ t T -> exists n nft, nbe n Γ T t = Done nft.
  intros.
  pose (Heq:= completeness (eq_refl _ _ _ H)).
  destruct Heq as [n [nf [_ [norm  _]  ]]].
  exists n. exists nf. assumption.
Qed.

(* TODO: consistency *)


Require Import Coq.PArith.BinPos.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Export List.

Require Import Byte.
Require Import ByteData.
Require Import DiskSubset.
Require Import Fetch.

Local Open Scope bool.
Local Open Scope N.

(* Functional programming idioms *)
Definition flatmap {A B: Type} (opt: Exc A) (fn: A -> Exc B)
  : Exc B :=
  match opt with
    | Some v => fn v
    | None => None
  end.

Definition opt_map {A B: Type} (opt: Exc A) (fn: A -> B)
  : Exc B :=
  match opt with
    | Some v => value (fn v)
    | None => None
  end.

Definition opt_eqbN (lhs rhs: Exc N): bool :=
  match (lhs, rhs) with
  | (Some l, Some r) => l =? r
  | (None, None) => true
  | _ => false
  end.

Infix "_flatmap_" := flatmap (at level 50).
Infix "_map_" := opt_map (at level 50).

Definition range (start: N) (exclusiveEnd: N) : list N :=
  N.peano_rect
  (fun _ => N -> list N) (* Signature of recursive calls *)
  (fun (start: N) => nil) (* Base case *)
  (fun (counter: N) (rec: N -> list N) (start: N) =>
    if (exclusiveEnd <=? start)
    then nil
    else start :: (rec (start + 1)))
  (exclusiveEnd - start)
  start.

Infix "upto" := range (at level 50).

Fixpoint takeWhile {A} (predicate: A->bool) (lst: list A)
  : list A :=
  match lst with
  | head :: tail => if (predicate head)
                    then (head
                          :: (takeWhile predicate tail))
                    else nil
  | nil => nil
end.

Fixpoint flatten {A} (lst: list (Exc A)): list A :=
  match lst with
    | (value head) :: tail => head :: (flatten tail)
    | error :: tail => flatten tail
    | nil => nil
  end.

(* from a Disk, extract the list of elements
  [ disk start; disk (start + 1); ... ; disk (start + length - 1) ] *)
Definition seq_list (disk: Disk) (start length: N): @Fetch (list Byte) :=
  match length with
    | 0 => Found nil
    | N.pos l =>
      (Pos.peano_rec
        (fun _ => N -> @Fetch (list Byte))
        (fun (start': N) => (disk start') _fmap_ (fun nextEl => nextEl :: nil))
        (fun _ (seq_list_aux_pred_l: N -> @Fetch (list Byte)) (start': N) =>
          (disk start') _fflatmap_ (fun nextEl =>
            (seq_list_aux_pred_l (N.succ start')) _fmap_ (fun tail =>
              nextEl :: tail
            )
          )
        )
      )
      l
      start
  end.

Lemma seq_list_subset_subproof :
  forall (img: Disk) (offset: N) (p: positive),
    seq_list img offset (N.pos (Pos.succ p)) = (img offset)
    _fflatmap_ (fun val =>
      seq_list img (N.succ offset) (N.pos p)
      _fmap_ (fun valList => val :: valList)).
Proof.
  intros.
  unfold seq_list.
  rewrite Pos.peano_rect_succ.
  reflexivity.
Qed.

Lemma seq_list_subset :
  forall (sub super: Disk) (start length: N) (val: list Byte),
    sub ⊆ super ->
      seq_list sub start length = Found val ->
        seq_list super start length = Found val.
Proof.
  intros sub super start length.
  destruct length; [ unfold seq_list; auto |].
  revert sub super start.
  apply Pos.peano_ind with (p := p).
    (* Base Case *)
    intros.
    apply subset_fmap_existence with (sub := sub).
      assumption.
      auto.
    (* Inductive Case *)
    intros.
    rewrite seq_list_subset_subproof.
    rewrite seq_list_subset_subproof in H1.
    rewrite subset_fflatmap_existence with (sub := sub) (val := val).
      reflexivity.
      assumption.
    apply found_fflatmap_found in H1.
    destruct H1 as [aval [HSubFound HseqFound]].
    rewrite HSubFound. unfold fetch_flatmap.
    apply found_fmap_found in HseqFound.
    destruct HseqFound as [vallist [HseqSub Hconcat]].
    rewrite H with (sub := sub) (val := vallist).
      simpl. rewrite Hconcat. reflexivity.
      assumption.
      assumption.
Qed.

Lemma seq_list_shift_subset :
  forall (sub super: Disk) (amount offset length: N) (value: list Byte),
    sub ⊆ super ->
      seq_list (shift sub amount) offset length = Found value ->
        seq_list (shift super amount) offset length = Found value.
Proof.
  intros. apply seq_list_subset with (sub := (shift sub amount)).
  apply subset_shift. assumption.
  assumption.
Qed.

(* little endian unsigned *)
Fixpoint lendu (l : list Byte) : N :=
match l with
  | nil => 0
  | a :: l' => (N_of_ascii a) + (256 * lendu l')
end.

Definition seq_lendu (disk: Disk) (offset: N) (length: N): @Fetch N :=
  (seq_list disk offset length) _fmap_ (fun tail => lendu tail).

Lemma seq_lendu_subset :
  forall (sub super: Disk) (offset length value: N),
    sub ⊆ super ->
      seq_lendu sub offset length = Found value ->
        seq_lendu super offset length = Found value.
Proof.
  unfold seq_lendu.
  intros.
  apply found_fmap_found in H0.
  destruct H0 as [aval [HseqFound Hlendu]].
  apply seq_list_subset with (super := super) in HseqFound; [ | assumption].
  rewrite HseqFound. simpl.
  rewrite Hlendu. reflexivity.
Qed.

Lemma seq_lendu_shift_subset :
  forall (sub super: Disk) (amount offset length value: N),
    sub ⊆ super ->
      seq_lendu (shift sub amount) offset length = Found value ->
        seq_lendu (shift super amount) offset length = Found value.
Proof.
  intros. apply seq_lendu_subset with (sub := (shift sub amount)).
  apply subset_shift. assumption.
  assumption.
Qed.

Fixpoint listN_Byte_eqb (l r: list (N*Byte)) := match (l, r) with
  | (nil, nil) => true
  | ((lN, lByte) :: ltail, (rN, rByte) :: rtail) =>
      (lN =? rN)
      && Byte.eqb lByte rByte
      && listN_Byte_eqb ltail rtail
  | (_, _) => false
end.

Lemma listN_Byte_eqb_reflection (l r: list (N*Byte)) :
  listN_Byte_eqb l r = true <-> l = r.
Proof.
  split. (* -> *)
    generalize r.
    induction l.
      destruct r0.
        reflexivity.
        vm_compute. intros. inversion x.
    intros.
    destruct a.
    destruct r0.
      inversion H.

      destruct p.
      unfold listN_Byte_eqb in H.
      apply Bool.andb_true_iff in H. destruct H.
      apply Bool.andb_true_iff in H. destruct H.

      apply N.eqb_eq in H. rewrite H.
      apply Byte.eqb_reflection in H1. rewrite H1.
      apply IHl in H0. rewrite H0.
      reflexivity.
  (* <- *)
    generalize r.
    induction l.
      destruct r0.
        reflexivity.
        intros. inversion H.
    intros.
    destruct r0.
      inversion H.

      destruct a. destruct p.
      unfold listN_Byte_eqb. apply Bool.andb_true_iff.
      inversion H.
      split. apply Bool.andb_true_iff. split.
        apply N.eqb_eq. reflexivity.
        apply Byte.eqb_reflection. reflexivity.
        rewrite <- H3 at 1. apply IHl in H3. auto.
Qed.

Fixpoint listN_eqb (l r: list N) := match (l, r) with
  | (nil, nil) => true
  | (l :: ltail, r :: rtail) =>
      (l =? r)
      && listN_eqb ltail rtail
  | (_, _) => false
end.

Lemma listN_eqb_reflection (l r: list N) :
  listN_eqb l r = true <-> l = r.
Proof.
  split. (* -> *)
    generalize r.
    induction l.
      destruct r0.
        reflexivity.
        vm_compute. intros. inversion x.
    intros.
    destruct r0.
      inversion H.

      unfold listN_eqb in H.
      apply Bool.andb_true_iff in H. destruct H.
      apply N.eqb_eq in H. rewrite H.
      apply IHl in H0. rewrite H0.
      reflexivity.
  (* <- *)
    generalize r.
    induction l.
      destruct r0.
        reflexivity.
        intros. inversion H.
    intros.
    destruct r0.
      inversion H.

      unfold listN_eqb. apply Bool.andb_true_iff.
      inversion H.
      split.
        apply N.eqb_eq. reflexivity.
        rewrite <- H2 at 1. apply IHl in H2. auto.
Qed.

Definition optN_eqb (lhs rhs: Exc N) := match (lhs, rhs) with
  | (None, None) => true
  | (Some l, Some r) => l =? r
  | _ => false
end.

Lemma optN_eqb_reflection (lhs rhs: Exc N) :
  optN_eqb lhs rhs = true -> lhs = rhs.
Proof.
  intros. unfold optN_eqb in H.
  destruct lhs.
    destruct rhs; [|discriminate H]. apply N.eqb_eq in H. rewrite H. reflexivity.
    destruct rhs; [discriminate H|]. auto.
Qed.