From Coq Require Export Relation_Definitions.
From Coq Require Import ClassicalChoice.
From Coq Require Import ProofIrrelevance.
From Coq Require Import FunctionalExtensionality.
From Coq Require Import Description.
From ZornsLemma Require Export FunctionProperties.
From ZornsLemma Require Import Relation_Definitions_Implicit.
From ZornsLemma Require Import CSB.
From ZornsLemma Require Import EnsemblesSpec.
From ZornsLemma Require Import ZornsLemma.
From ZornsLemma Require Import EnsemblesImplicit.
From ZornsLemma Require Import CountableTypes.
From ZornsLemma Require Import FiniteTypes.
From ZornsLemma Require Import InfiniteTypes.

Inductive Cardinal : Type :=
  | cardinality: Type -> Cardinal.

Fixpoint n_element_set (n:nat) : Set :=
  match n with
  | O => False
  | S m => option (n_element_set m)
  end.
Definition nat_to_cardinal (n:nat) :=
  cardinality (n_element_set n).

Definition aleph0 := cardinality nat.

Inductive eq_cardinal : Cardinal -> Cardinal -> Prop :=
  | bij_eq_cardinal: forall {X Y:Type} (f:X->Y),
    bijective f -> eq_cardinal (cardinality X) (cardinality Y).
Inductive le_cardinal : Cardinal -> Cardinal -> Prop :=
  | inj_le_cardinal: forall {X Y:Type} (f:X->Y),
    injective f -> le_cardinal (cardinality X) (cardinality Y).

Definition lt_cardinal (kappa lambda:Cardinal) : Prop :=
  le_cardinal kappa lambda /\ ~ eq_cardinal kappa lambda.
Definition ge_cardinal (kappa lambda:Cardinal) : Prop :=
  le_cardinal lambda kappa.
Definition gt_cardinal (kappa lambda:Cardinal) : Prop :=
  lt_cardinal lambda kappa.

Lemma eq_cardinal_equiv: equivalence eq_cardinal.
Proof.
constructor.
- red; intro.
  destruct x.
  exists id.
  apply id_bijective.
- red; intros.
  destruct H.
  inversion H0. subst.
  exists (fun x:X => f0 (f x)).
  red; split.
  + red; intros.
    apply H.
    apply H2.
    assumption.
  + red; intro.
    destruct H.
    destruct H2.
    pose proof (H3 y).
    destruct H4.
    pose proof (H1 x).
    destruct H5.
    exists x0.
    rewrite H5.
    assumption.
- red; intros.
  destruct H.
  apply bijective_impl_invertible in H.
  destruct (function_inverse f H) as [finv].
  destruct a.
  exists finv.
  apply invertible_impl_bijective.
  exists f.
  + assumption.
  + assumption.
Qed.

Lemma eq_cardinal_impl_le_cardinal: forall kappa lambda: Cardinal,
  eq_cardinal kappa lambda -> le_cardinal kappa lambda.
Proof.
intros.
destruct H.
exists f.
destruct H.
assumption.
Qed.

Lemma le_cardinal_preorder: preorder le_cardinal.
Proof.
constructor.
- red; intro.
  apply eq_cardinal_impl_le_cardinal.
  apply (equiv_refl eq_cardinal_equiv).
- red; intros.
  destruct H.
  inversion H0.
  exists (fun x:X => f0 (f x)).
  red; intros.
  apply H.
  apply H2.
  assumption.
Qed.

Lemma le_cardinal_antisym: forall kappa lambda:Cardinal,
  le_cardinal kappa lambda -> le_cardinal lambda kappa ->
  eq_cardinal kappa lambda.
Proof.
intros.
destruct H.
inversion H0.
destruct H1.
destruct H2.
pose proof (CSB Y0 X0 f f0 H H3).
destruct H1.
exists x.
assumption.
Qed.

Lemma cantor_diag: forall (X:Type) (f:X->(X->bool)),
  ~ surjective f.
Proof.
intros.
red; intro.
pose (g := fun x:X => negb (f x x)).
pose proof (H g).
destruct H0.
assert (f x x = g x).
{ rewrite H0.
  reflexivity.
}
unfold g in H1.
destruct (f x x).
- discriminate H1.
- discriminate H1.
Qed.

Lemma P_neq_not_P: forall (P:Prop), P <> ~P.
Proof.
unfold not; intros.
assert (~P).
{ unfold not; intro.
  assert (P->False).
  { rewrite <- H.
    assumption.
  }
  tauto.
}
assert P.
{ rewrite H.
  assumption.
}
contradiction.
Qed.

Lemma cantor_diag2: forall (X:Type) (f:X->(X->Prop)),
  ~ surjective f.
Proof.
unfold not; intros.
pose (g := fun x:X => ~ f x x).
pose proof (H g).
destruct H0.
assert (f x x = g x).
{ rewrite H0.
  reflexivity.
}
unfold g in H1.
contradiction P_neq_not_P with (f x x).
Qed.

Lemma cardinals_unbounded: forall kappa:Cardinal, exists lambda:Cardinal,
  gt_cardinal lambda kappa.
Proof.
destruct kappa.
exists (cardinality (T->Prop)).
red; red; split.
- exists (@eq T).
  red; intros.
  rewrite H.
  reflexivity.
- intro.
  inversion H.
  destruct H0.
  destruct H2.
  contradiction (cantor_diag2 _ f).
Qed.

(* The results below require Axiom of Choice *)

Lemma surj_le_cardinal: forall {X Y:Type} (f:X->Y),
  surjective f -> le_cardinal (cardinality Y) (cardinality X).
Proof.
intros.
pose proof (choice (fun (y:Y) (x:X) => f x = y) H).
simpl in H0.
destruct H0 as [g].
exists g.
red; intros.
congruence.
Qed.

Section le_cardinal_total.

Variable X Y:Type.

Record partial_injection : Type := {
  pi_dom: Ensemble X;
  pi_func: forall x:X, In pi_dom x -> Y;
  pi_inj: forall (x1 x2:X) (i1:In pi_dom x1) (i2:In pi_dom x2),
    pi_func x1 i1 = pi_func x2 i2 -> x1 = x2
}.
Record partial_injection_ord (pi1 pi2:partial_injection) : Prop := {
  pi_dom_inc: Included (pi_dom pi1) (pi_dom pi2);
  pi_func_ext: forall (x:X) (i1:In (pi_dom pi1) x)
   (i2:In (pi_dom pi2) x),
    pi_func pi1 x i1 = pi_func pi2 x i2
}.

Lemma partial_injection_preord: preorder partial_injection_ord.
Proof.
constructor.
- red; intros.
  destruct x.
  constructor.
  + auto with sets.
  + intros. simpl in *.
    assert (i1 = i2).
    { apply proof_irrelevance. }
    rewrite H.
    reflexivity.
- red; intros.
  destruct H.
  destruct H0.
  constructor.
  + auto with sets.
  + intros.
    assert (In (pi_dom y) x0).
    { auto with sets. }
    transitivity (pi_func y x0 H); trivial.
Qed.

Lemma partial_injection_chain_ub: forall S:Ensemble partial_injection,
  chain partial_injection_ord S -> exists x:partial_injection,
  forall y:partial_injection, In S y -> partial_injection_ord y x.
Proof.
intros.
pose (ub_dom := [x:X | exists y:partial_injection,
  In S y /\ In (pi_dom y) x]).
assert (forall x:X, In ub_dom x -> { y:Y | exists z:partial_injection,
  In S z /\ exists i:In (pi_dom z) x, pi_func z x i = y }).
{ intros.
  apply constructive_definite_description.
  destruct H0.
  destruct H0.
  destruct H0.
  exists (pi_func x0 x H1).
  red; split.
  - exists x0.
    split.
    + assumption.
    + exists H1.
      reflexivity.
  - intros.
    destruct H2.
    destruct H2.
    destruct H3.
    pose proof (H x0 x1 H0 H2).
    case H4.
    + intro.
      rewrite <- H3.
      apply pi_func_ext.
      assumption.
    + intro.
      rewrite <- H3.
      symmetry.
      apply pi_func_ext.
      assumption.
}
assert (forall (x1 x2:X) (i1:In ub_dom x1) (i2:In ub_dom x2),
  proj1_sig (X0 x1 i1) = proj1_sig (X0 x2 i2) -> x1 = x2).
{ intros.
  destruct X0 in H0.
  destruct X0 in H0.
  simpl in H0.
  destruct H0.
  destruct e.
  destruct H0.
  destruct H1.
  destruct e0.
  destruct H2.
  destruct H3.
  destruct H1.
  case (H x0 x4 H0 H2).
  - intro.
    assert (In (pi_dom x4) x1).
    { apply (pi_dom_inc _ _ H1).
      assumption.
    }
    assert (pi_func x4 x1 H4 = pi_func x4 x2 x5).
    { rewrite H3.
      symmetry.
      apply pi_func_ext.
      assumption.
    }
    apply pi_inj in H5.
    assumption.
  - intro.
    assert (In (pi_dom x0) x2).
    { apply (pi_dom_inc _ _ H1).
      assumption.
    }
    assert (pi_func x0 x1 x3 = pi_func x0 x2 H4).
    { rewrite <- H3.
      apply pi_func_ext.
      assumption.
    }
    apply pi_inj in H5.
    assumption.
}
exists (Build_partial_injection ub_dom
  (fun (x:X) (i:In ub_dom x) => proj1_sig (X0 x i)) H0).
intros.
constructor.
- simpl.
  red; intros.
  constructor.
  exists y.
  tauto.
- simpl.
  intros.
  destruct (X0 x i2).
  simpl.
  destruct e.
  destruct H2.
  destruct H3.
  destruct H3.
  case (H y x1 H1 H2).
  + intro.
    apply pi_func_ext.
    assumption.
  + intro.
    symmetry.
    apply pi_func_ext.
    assumption.
Qed.

Lemma premaximal_partial_injection:
  exists x:partial_injection, premaximal partial_injection_ord x.
Proof.
apply ZornsLemmaForPreorders.
- exact partial_injection_preord.
- exact partial_injection_chain_ub.
Qed.

Lemma premaximal_pi_is_full_or_surj:
  forall x:partial_injection, premaximal partial_injection_ord x ->
    pi_dom x = Full_set \/
    forall y:Y, exists x0:X, exists i:(In (pi_dom x) x0),
      pi_func x x0 i = y.
Proof.
intros.
case (classic (pi_dom x = Full_set)).
{ left.
  trivial.
}
intro.
assert (exists x0:X, ~ In (pi_dom x) x0).
{ apply NNPP.
  intuition.
  apply H0.
  apply Extensionality_Ensembles.
  red; split.
  - red; intros.
    constructor.
  - red; intros.
    apply NNPP.
    intuition.
    apply H1.
    exists x0.
    assumption.
}
right.
destruct H1.
intros.
apply NNPP.
intuition.

pose (pi_dom_ext := Add (pi_dom x) x0).
assert (forall (x':X), In pi_dom_ext x' ->
  { y':Y | (exists i2:In (pi_dom x) x', y' = pi_func x x' i2) \/
          (x' = x0 /\ y' = y) }).
{ intros.
  apply constructive_definite_description.
  case H3.
  - intros.
    exists (pi_func x x1 H4).
    red; split.
    + left.
      exists H4.
      reflexivity.
    + intros.
      case H5.
      * intro.
        destruct H6.
        subst.
        replace H4 with x2.
        -- reflexivity.
        -- apply proof_irrelevance.
      * intros.
        destruct H6.
        subst.
        contradict H1.
        assumption.
  - intros.
    destruct H4.
    exists y.
    red; split.
    + right.
      tauto.
    + intros.
      case H4.
      * intro.
        destruct H5.
        subst.
        contradiction H1.
      * intros.
        symmetry.
        tauto.
}

pose (pi_func_ext0 := fun (x:X) (i:In pi_dom_ext x) =>
  proj1_sig (X0 x i)).

assert (forall (x1:X) (i:In (pi_dom x) x1) (i2:In pi_dom_ext x1),
  pi_func_ext0 x1 i2 = pi_func x x1 i).
{ intros.
  unfold pi_func_ext0.
  destruct (X0 x1 i2).
  simpl.
  case o.
  - intros.
    destruct H3.
    subst.
    replace i with x3.
    + reflexivity.
    + apply proof_irrelevance.
  - intros.
    destruct H3.
    contradiction H1.
    rewrite <- H3.
    assumption.
}

assert (forall (i:In pi_dom_ext x0), pi_func_ext0 x0 i = y).
{ intros.
  unfold pi_func_ext0.
  destruct (X0 x0 i); simpl.
  case o.
  - intro.
    destruct H4.
    contradiction H1.
  - tauto.
}

assert (forall (x1 x2:X) (i1:In pi_dom_ext x1) (i2:In pi_dom_ext x2),
  pi_func_ext0 x1 i1 = pi_func_ext0 x2 i2 -> x1 = x2).
{ intros.
  inversion i1; subst.
  - inversion i2; subst.
    + rewrite (H3 x1 H6 i1) in H5.
      rewrite (H3 x2 H7 i2) in H5.
      apply pi_inj in H5.
      assumption.
    + destruct H7.
      rewrite (H3 x1 H6 i1) in H5.
      rewrite H4 in H5.
      contradiction H2.
      exists x1, H6.
      assumption.
  - destruct H6.
    rewrite H4 in H5.
    inversion i2.
    + rewrite (H3 x2 H6 i2) in H5.
      contradiction H2.
      exists x2, H6.
      symmetry; assumption.
    + destruct H6.
      reflexivity.
}

pose (pi_ext := Build_partial_injection pi_dom_ext pi_func_ext0 H5).
assert (partial_injection_ord x pi_ext).
{ constructor.
  - unfold pi_ext; simpl.
    unfold pi_dom_ext.
    red; intros.
    left.
    assumption.
  - intros.
    symmetry.
    apply H3.
}

apply H in H6.
contradiction H1.
apply (pi_dom_inc _ _ H6).
simpl.
right.
constructor.
Qed.

Lemma types_comparable: (exists f:X->Y, injective f) \/
                        (exists f:Y->X, injective f).
Proof.
pose proof premaximal_partial_injection.
destruct H.
apply premaximal_pi_is_full_or_surj in H.
case H.
- left.
  assert (forall x0:X, In (pi_dom x) x0).
  { rewrite H0.
    constructor.
  }
  exists (fun x0:X => pi_func x x0 (H1 x0)).
  red; intros.
  apply pi_inj in H2.
  assumption.
- right.
  assert (forall y:Y, { x0:X | exists i:In (pi_dom x) x0, pi_func x x0 i = y }).
  { intro.
    apply constructive_definite_description.
    pose proof (H0 y).
    destruct H1.
    exists x0.
    red; split.
    - assumption.
    - intros.
      destruct H1.
      destruct H2.
      destruct H2.
      apply pi_inj in H1.
      assumption.
  }
  exists (fun y:Y => proj1_sig (X0 y)).
  red; intros.
  destruct X0 in H1; destruct X0 in H1; simpl in H1.
  destruct e; destruct e0.
  subst.
  replace x3 with x4.
  + reflexivity.
  + apply proof_irrelevance.
Qed.

End le_cardinal_total.

Corollary le_cardinal_total: forall kappa lambda:Cardinal,
  le_cardinal kappa lambda \/ le_cardinal lambda kappa.
Proof.
intros [T0] [T1].
destruct (types_comparable T0 T1) as [[f]|[f]];
  [left|right];
  exists f; assumption.
Qed.

Lemma CountableT_cardinality {X : Type} :
  CountableT X <-> le_cardinal (cardinality X) aleph0.
Proof.
split; intros.
- destruct H.
  exists f. assumption.
- inversion H; subst.
  exists f. assumption.
Qed.

Lemma FiniteT_cardinality {X : Type} :
  FiniteT X <-> lt_cardinal (cardinality X) aleph0.
Proof.
split; intros.
- constructor.
  + destruct (FiniteT_nat_embeds H) as [f].
    exists f. assumption.
  + intro.
    inversion H0; subst; clear H0.
    destruct H3.
    assert (FiniteT nat).
    { apply surj_finite with X f; auto.
      intros.
      destruct (classic (y1 = y2)); tauto.
    }
    auto using nat_infinite.
- inversion H; subst; clear H.
  inversion H0; subst; clear H0.
  apply NNPP. intro.
  destruct (infinite_nat_inj _ H) as [g].
  contradict H1.
  pose (CSB X nat f g). intuition.
  destruct H2 as [h].
  exists h. assumption.
Qed.

Lemma cardinal_no_inj_equiv_lt_cardinal (A B : Type) :
  (forall f : A -> B, ~ injective f) <->
  lt_cardinal (cardinality B) (cardinality A).
Proof.
split.
- intros.
  split.
  + (* |B| ≤ |A| *)
    destruct (le_cardinal_total (cardinality B) (cardinality A)).
    { assumption. }
    exfalso.
    inversion H0; subst; clear H0.
    apply (H f).
    assumption.
  + (* |B| ≠ |A| *)
    intro.
    inversion H0; subst; clear H0.
    apply bijective_impl_invertible in H3.
    destruct H3.
    pose proof (invertible_impl_bijective g).
    destruct H2.
    { exists f; assumption. }
    apply (H g).
    assumption.
- intros.
  intro H0.
  inversion H; clear H.
  contradict H2.
  inversion H1; subst; clear H1.
  destruct (CSB _ _ f f0) as [f1]; auto.
  apply eq_cardinal_equiv.
  exists f1. assumption.
Qed.


From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening
  DeclarativeTyping GenericTyping LogicalRelation Validity.
From LogRel.LogicalRelation Require Import Escape Reflexivity Neutral Weakening Irrelevance.
From LogRel.Substitution Require Import Irrelevance Properties.
From LogRel.Substitution.Introductions Require Import Universe Pi Application.

Set Universe Polymorphism.

Section SimpleArrValidity.

  Context `{GenericTypingProperties}.

  Lemma simpleArrValid {l Γ F G} (VΓ : [||-v Γ])
    (VF : [Γ ||-v< l > F | VΓ ])
    (VG : [Γ ||-v< l > G | VΓ]) :
    [Γ ||-v<l> arr F G | VΓ].
  Proof.
    unshelve eapply PiValid; tea.
    replace G⟨↑⟩ with G⟨@wk1 Γ F⟩ by now bsimpl.
    now eapply wk1ValidTy.
  Qed.

  Lemma simpleArrCongValid {l Γ F F' G G'} (VΓ : [||-v Γ])
    (VF : [Γ ||-v< l > F | VΓ ])
    (VF' : [Γ ||-v< l > F' | VΓ ])
    (VeqF : [Γ ||-v< l > F ≅ F' | VΓ | VF])
    (VG : [Γ ||-v< l > G | VΓ ])
    (VG' : [Γ ||-v< l > G' | VΓ ])
    (VeqG : [Γ ||-v< l > G ≅ G' | VΓ | VG]) :
    [Γ ||-v<l> arr F G ≅ arr F' G' | VΓ | simpleArrValid _ VF VG].
  Proof.
    eapply irrelevanceEq.
    unshelve eapply PiCong; tea.
    + replace G⟨↑⟩ with G⟨@wk1 Γ F⟩ by now bsimpl.
      now eapply wk1ValidTy.
    + replace G'⟨↑⟩ with G'⟨@wk1 Γ F'⟩ by now bsimpl.
      now eapply wk1ValidTy.
    + replace G'⟨↑⟩ with G'⟨@wk1 Γ F⟩ by now bsimpl.
      eapply irrelevanceEq'.
      2: now eapply wk1ValidTyEq.
      now bsimpl.
    Unshelve. 2: tea.
  Qed.

  Lemma simple_appValid {Γ t u F G l}
    (VΓ : [||-v Γ])
    {VF : [Γ ||-v<l> F | VΓ]}
    (VG : [Γ ||-v<l> G | VΓ])
    (VΠ : [Γ ||-v<l> arr F G | VΓ])
    (Vt : [Γ ||-v<l> t : arr F G | _ | VΠ])
    (Vu : [Γ ||-v<l> u : F | _ | VF]) :
    [Γ ||-v<l> tApp t u : G| _ | VG].
  Proof.
    eapply irrelevanceTm'.
    2: eapply appValid; tea.
    now bsimpl.
  Unshelve. all: tea.
  Qed.

End SimpleArrValidity.


(*
  vim: filetype=coq
*)
(*
Copyright (C) 2016-2018 Philip H. Smith

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.
*)

Require Import Way.Tactics.

Require Import Way.Nat.
Require Import Way.Preterm.

(* Replace a bound variable i with replacement u in preterm p

No shifting, lifting or other house keeping is done on the remaining de Bruijn indices.
*)
Fixpoint open (i : nat) (u p : preterm) : preterm :=
  match p with

  | free_variable _ => p

  | bound_variable b => if eq_nat_dec i b then u else p

  | product a b => product (open i u a) (open (S i) u b)

  | abstraction a b => abstraction (open i u a) (open (S i) u b)

  | application f a => application (open i u f) (open i u a)

  | type _ => p

  end.

(* Open bound variable 0 in a term with a free variable. *)
Definition open_free (a : atom) (p : preterm) : preterm :=
  open 0 (Preterm.free_variable a) p.

Hint Unfold open_free : way.

Module Examples.

Import Aliases.

Example fvar_is_unchanged :
  forall (a b : atom), open_free a (fvar b) = (fvar b).
Proof.
  infer.
Defined.

Example same_bvar_is_opened :
  forall (a : atom), open_free a (bvar 0) = (fvar a).
Proof.
  infer.
Defined.

Example different_bvar_is_unchanged :
  forall (a : atom), open_free a (bvar 1) = (bvar 1).
Proof.
  infer.
Defined.

Example prod_opens_bvar_into_annotation :
  forall (a : atom), open_free a (prod (bvar 0) (bvar 0)) = (prod (fvar a) (bvar 0)).
Proof.
  infer.
Defined.

Example prod_opens_incremented_bvar_into_body :
  forall (a : atom), open_free a (prod (bvar 1) (bvar 1)) = (prod (bvar 1) (fvar a)).
Proof.
  infer.
Defined.

Example abs_opens_bvar_into_annotation :
  forall (a : atom), open_free a (abs (bvar 0) (bvar 0)) = (abs (fvar a) (bvar 0)).
Proof.
  infer.
Defined.

Example abs_opens_incremented_bvar_into_body :
  forall (a : atom), open_free a (abs (bvar 1) (bvar 1)) = (abs (bvar 1) (fvar a)).
Proof.
  infer.
Defined.

Example app_opens_into_subterms :
  forall (a : atom), open_free a (app (bvar 0) (bvar 0)) = (app (fvar a) (fvar a)).
Proof.
  infer.
Defined.

Example type_is_unchanged :
  forall (a : atom) (n : nat), open_free a (type n) = (type n).
Proof.
  infer.
Defined.

End Examples.


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

Require Export NAxioms.
Require Import NMaxMin NParity NPow NSqrt NLog NDiv NGcd NLcm NBits.

(** This functor summarizes all known facts about N. *)

Module Type NProp (N:NAxiomsSig) :=
 NMaxMinProp N <+ NParityProp N <+ NPowProp N <+ NSqrtProp N
  <+ NLog2Prop N <+ NDivProp N <+ NGcdProp N <+ NLcmProp N
  <+ NBitsProp N.


Require Import Bool.
Require Import Heap.
Require Import Program.Tactics.

(*******************************************************************************
                    ****   Basic definitions ****
*******************************************************************************)

Set Implicit Arguments.

Section Refinement.
  Variable t : Type.
  Definition S := heap t.

Definition Pred : Type -> Type := fun a => a -> Type.

Definition K : forall {A} {a : Type}, Pred S -> (forall s:S, A s -> a -> Pred S) := fun a _ pt _ _ _ s => pt s.

Definition Ka : forall {A} {a : Type}, (a -> Pred S) -> (forall s:S, A s -> a -> Pred S) := fun _ _ pt _ _ a s => pt a s.

Implicit Arguments K [A].

Implicit Arguments Ka [A].

Definition subset : Pred S -> Pred S -> Type :=
  fun P1 P2 => forall s, P1 s -> P2 s.

Notation "P1 ⊂ P2" := (subset P1 P2) (at level 80) : type_scope.

Record PT (a : Type) : Type :=
  MkPT { pre : Pred S;
         post : (forall s : S, pre s -> a -> Pred S) }.

(*
Definition pre {a : Type} (pt : PT a) : Pred S :=
  match pt with
    | MkPT pre _ => pre
  end.

Definition post {a : Type} (pt : PT a) : (forall s : S, pre pt s -> a -> Pred S) :=
  match pt return (forall s : S, pre pt s -> a -> Pred S) with
    | Predicate pre p => p
  end.
*)

Inductive Refines {a : Type} (pt1 pt2 : PT a) : Type :=
  Refinement :
    forall (d : pre pt1 ⊂ pre pt2),
      (forall (s : S) (x : pre pt1 s) v, post pt2 s (d s x) v ⊂ post pt1 s x v) -> Refines pt1 pt2.

Notation "PT1 ⊏ PT2" := (Refines PT1 PT2) (at level 90, no associativity) : type_scope.

Notation "[ p , q ]" := (MkPT p q) (at level 70) : type_scope.

Ltac refine_simpl  := unfold pre, post, K, Ka, subset in *; intros; simpl in *.
Ltac destruct_pt a := refine_simpl; destruct_all (PT a).

Definition semantics {A : Type} (pt : PT A) : Pred (A * S) -> Pred S
  := fun P s =>
      {p : pre pt s
       & forall s' v, post pt s p v s' -> P (v, s')}.

Lemma soundness1 {a : Type} (pt1 pt2 : PT a) :
  (pt1 ⊏ pt2) -> forall P, semantics pt1 P ⊂ semantics pt2 P.
  Proof.
    intros [H1 H2] P1 s [pre1 post1].
    exists (H1 s pre1).
    intros; apply post1; now apply H2.
  Qed.

Lemma soundness2 {a : Type} : forall (pt1 pt2 : PT a),
  (forall P, semantics pt1 P ⊂ semantics pt2 P) -> (pt1 ⊏ pt2).
Proof.
  intros [Pre1 Post1] [Pre2 Post2] H.
  set (Q := fun s pre => H (fun vs => Post1 s pre (fst vs) (snd vs)) s (existT _ pre (fun _ _ q => q))).
  eapply Refinement.
  Unshelve. Focus 2.
  unfold subset; simpl in *; now apply Q.
  intros s x v s' p; simpl in *; destruct (Q s x) as [p1 p2];
     now (apply p2).
  Qed.

Theorem soundness {A : Type} : forall (pt1 pt2 : PT A),
  (pt1 ⊏ pt2 -> (forall P, semantics pt1 P ⊂ semantics pt2 P))
  * ((forall P, semantics pt1 P ⊂ semantics pt2 P) -> pt1 ⊏ pt2).
  intros; split; [ now eapply soundness1 | eapply soundness2].
  Qed.

(*******************************************************************************
             ****   Primitive Predicate Transformers ****
*******************************************************************************)

Definition SkipPT {a : Type} : PT a :=
  let skipPre := fun s => True in
  let skipPost := fun s pres v s' => s = s' in
  [skipPre , skipPost].

(*******************************************************************************
                  ****   Basic refinement rules ****
*******************************************************************************)

Lemma strengthen {a : Type} (P : Pred S) (Q1 Q2 : forall s, P s -> a -> Pred S) :
  (forall (s : S) (p : P s) (v : a), Q1 s p v ⊂ Q2 s p v) ->
  [ P , Q2 ] ⊏ [ P , Q1 ].
Proof.
  intros; set (d := fun (s : S) (H: P s) => H).
  apply (Refinement ([P, Q2]) ([P, Q1]) d).
  refine_simpl; now auto.
Qed.

Lemma weaken {a : Type} (P1 P2 : Pred S) (f : P1 ⊂ P2) (Q : S -> a -> Pred S) :
  [P1, fun s _ => Q s ] ⊏ [P2 , fun s _ => Q s ].
Proof.
  intros; apply (Refinement ([P1, fun s _ => Q s]) ([P2, fun s _ => Q s]) f).
  now refine_simpl.
Qed.

Lemma refineSkip {a : Type} (pt : PT a) :
  (forall s (pres : pre pt s) v, post pt s pres v s) -> pt ⊏ SkipPT.
  Proof.
    intros H; assert (d : pre pt ⊂ @pre a SkipPT) by (unfold subset; simpl pre; auto).
    apply (Refinement pt SkipPT d).
    destruct_pt a; subst; now trivial.
  Qed.

Definition refineTransPT {a} (pt2 pt1 pt3 : PT a) :
  pt1 ⊏ pt2 -> pt2 ⊏ pt3 -> pt1 ⊏ pt3.
    intros [pre12 post12] [pre23 post23].
    set (d (s : S) (pre1s : pre pt1 s) := pre23 s (pre12 s pre1s)).
    refine (Refinement pt1 pt3 d _).
    now (destruct_pt a; auto).
  Defined.

Definition refineReflPT {a} (pt : PT a) : pt ⊏ pt.
  refine (Refinement pt pt (fun s pres => pres) _).
  now (destruct_pt a; auto).
  Defined.

Definition BindPT {a b : Type} (pt1 : PT a) (pt2 : a -> PT b) : PT b :=
  let seqPre := fun s => {pres : pre pt1 s & forall t v, post pt1 s pres v t -> pre (pt2 v) t} in

  let seqPost : forall s : S, seqPre s -> b -> Pred S := fun (s : S) (pres : seqPre s) (v : b) (s' : S) =>
    { t : S &
    { x : a &
    { q : post pt1 s (projT1 pres) x t &
     post (pt2 x) t (projT2 pres t x q) v s'}}}
  in
  [seqPre , seqPost].

Notation "pt1 ⟫= pt2" := (BindPT pt1 pt2) (at level 52, right associativity).

(* Definition NewPT (x : t) : PT Addr.t :=               *)
(*   Predicate _ (fun s => True)  *)
(*               (fun s _ p s' =>  *)
(*                  (forall p', p' <> p -> find _ s p = find _ s' p') *)
(*                  /\ find _ s' p = Some t). *)

(* Definition ReadPT {a : Type} (ptr : Addr.t) : PT a := *)
(*   Predicate _ (fun s => exists v, find s ptr = Some (dyn a v))  *)
(*               (fun s pres v s' => (s = s') /\ (Some (dyn a v) = find s ptr)). *)

Definition Is_false (b : bool) :=
  match b with
    | true => False
    | false => True
  end.

Definition WhilePT {a : Type} (inv : S -> Type) (cond : S -> bool) (body : PT a) : PT a :=
  let whilePre := (fun s =>   (* The invariant should hold initially *)
                             prod (inv s)
                              (* If we enter the loop, the precondition of the body should hold *)
                            { H : (forall s, prod (Is_true (cond s)) (inv s) -> pre body s) &
                              (* The loop body should preserve the invariant *)
                            (forall s v s' (t : prod (Is_true (cond s)) (inv s)), post body s (H s t) v s' -> inv s')})
  in
  let whilePost := (fun _ _ _ s' => prod (inv s') (Is_false (cond s'))) in
  [ whilePre , whilePost ].

Definition WhilePT' {a : Type} (* inv: initial state -> current state -> Type*)
           (inv : S -> S -> Type) (cond : S -> bool) (body : PT a) : PT a :=
  let whilePre := (fun si =>   (* The invariant should hold initially *)
                             prod (inv si si)
                              (* If we enter the loop, the precondition of the body should hold *)
                            { H : (forall s, prod (Is_true (cond s)) (inv si s) -> pre body s) &
                              (* The loop body should preserve the invariant *)
                            (forall s v s' (t : prod (Is_true (cond s)) (inv si s)), post body s (H s t) v s' -> inv si s')})
  in
  let whilePost := (fun s _ _ s' => prod (inv s s') (Is_false (cond s'))) in
  [ whilePre , whilePost ].

Definition SeqPT {a b : Type} (pt1 : PT a) (pt2 : PT b) : PT b :=
  let seqPre := fun s => { pres : pre pt1 s & forall t v, post pt1 s pres v t -> pre pt2 t} in
  let seqPost : forall s : S, seqPre s -> b -> Pred S := fun (s : S) (pres : seqPre s) (v : b) (s' : S) =>
  {t : S &
  {v' : a &
  {q : post pt1 s (projT1 pres) v' t &
   post pt2 t (projT2 pres t v' q) v s'}}} in
  [seqPre , seqPost].

Notation "pt1 ;; pt2" := (SeqPT pt1 pt2) (at level 52, right associativity).

End Refinement.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_bnd_all_reduce :
  forall T1 x1 L1, T1 = (t_sel_bnd x1 L1) ->
              forall T2 T T', T2 = (t_all T T') ->
                             subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


(** * A finite number of global locks. *)
Require Import Coq.Vectors.Vector.
Require Import Coq.Lists.List.
Require Import Io.All.
Require Import Io.System.All.
Require Import ListString.All.
Require Import DeadLockFree.
Require Decide.
Require Model.

Import ListNotations.
Import C.Notations.

Module Locks.
  Module Command.
    Inductive t (n : nat) : Set :=
    | Lock (id : Fin.t n)
    | Unlock (id : Fin.t n).
  End Command.

  Definition answer {n : nat} (c : Command.t n) : Type :=
    unit.

  Definition E (n : nat) : Effect.t :=
    Effect.New (Command.t n) answer.

  Definition lock {n : nat} (id : Fin.t n) : C.t (E n) unit :=
    call (E n) (Command.Lock n id).

  Definition unlock {n : nat} (id : Fin.t n) : C.t (E n) unit :=
    call (E n) (Command.Unlock n id).

  Definition S (n : nat) := Vector.t bool n.

  Fixpoint init (n : nat) : S n :=
    match n with
    | O => Vector.nil bool
    | Datatypes.S n => Vector.cons bool false n (init n)
    end.

  Definition m (n : nat) : Model.t (E n) (S n) :=
    fun c s =>
      match c with
      | Command.Lock id =>
        let b := Vector.nth s id in
        if b then
          None
        else
          Some (tt, Vector.replace s id true)
      | Command.Unlock id =>
        let b := Vector.nth s id in
        if b then
          Some (tt, Vector.replace s id false)
        else
          None
      end.
End Locks.

Definition ex1 : C.t (Locks.E 1) nat :=
  do! Locks.lock Fin.F1 in
  do! Locks.unlock Fin.F1 in
  ret 12.

Lemma ex1_ok : C.DeadLockFree.t (Locks.m 1) (Locks.init 1) ex1.
  now apply Decide.C.dead_lock_free_ok.
Qed.

Fixpoint iter_seq {n : nat} (l : list (C.t (Locks.E n) unit))
  : C.t (Locks.E n) unit :=
  match l with
  | [] => ret tt
  | x :: l => do! x in iter_seq l
  end.

Fixpoint iter_par {n : nat} (l : list (C.t (Locks.E n) unit))
  : C.t (Locks.E n) unit :=
  match l with
  | [] => ret tt
  | x :: l =>
    let! _ : unit * unit := join x (iter_par l) in
    ret tt
  end.

Definition ex2 : C.t (Locks.E 3) unit :=
  let a : Fin.t 3 := Fin.F1 in
  let b : Fin.t 3 := Fin.FS Fin.F1 in
  let c : Fin.t 3 := Fin.FS (Fin.FS Fin.F1) in
  iter_par (List.map iter_seq [
    [Locks.lock a; Locks.lock c; Locks.unlock c; Locks.unlock a];
    [Locks.lock b; Locks.lock c; Locks.unlock c; Locks.unlock b];
    [Locks.lock a; Locks.lock c; Locks.unlock c; Locks.unlock a];
    [Locks.lock b; Locks.lock c; Locks.unlock c; Locks.unlock b]]).

(*Time Compute Decide.dead_lock_free (Locks.m 3) (Locks.init 3)
  (Compile.to_choose ex2).*)

Definition eval_ex2 (argv : list LString.t) : C.t System.effect unit :=
  if Decide.dead_lock_free
    (Locks.m 3) (Locks.init 3) (Compile.to_choose ex2) then
    System.log (LString.s "OK")
  else
    System.log (LString.s "error").

Definition main := Extraction.launch eval_ex2.
Extraction "extraction/main" main.

(*Lemma ex2_ok : C.DeadLockFree.t (Locks.m 3) (Locks.init 3) ex2.
  now apply Decide.C.dead_lock_free_ok.
Qed.*)

Definition ex3 : C.t (Locks.E 2) unit :=
  let a : Fin.t 2 := Fin.F1 in
  let b : Fin.t 2 := Fin.FS Fin.F1 in
  iter_par (List.map iter_seq [
    [Locks.lock a; Locks.lock b; Locks.unlock b; Locks.unlock a];
    [Locks.lock b; Locks.lock a; Locks.unlock a; Locks.unlock b]]).

(*Lemma ex3_ok : C.DeadLockFree.t (Locks.m 2) (Locks.init 2) ex3.
  now apply Decide.C.dead_lock_free_ok.
Qed.*)


Require Import Coq.omega.Omega.
Require Import ExtLib.Data.PList.
Require Import ExtLib.Data.POption.
Require Import MirrorCore.CTypes.CoreTypes.

Set Implicit Arguments.
Set Strict Implicit.
Set Universe Polymorphism.
Set Primitive Projections.

(** TODO(gmalecha): This should become a functor to avoid the extra
 ** parameter everywhere
 **)
Section dlist.
  Variable (F : nat -> Type).

  Inductive dlist (n : nat) : Type :=
  | dnil : dlist n
  | dcons : F n -> dlist (S n) -> dlist n.

  Fixpoint plus_k a b : nat :=
    match a with
    | 0 => b
    | S n => plus_k n (S b)
    end.

  Fixpoint dlist_get {n} m (dl : dlist n) : poption (F (plus_k m n)) :=
    match dl with
    | dnil _ => pNone
    | @dcons _ f dl0 =>
      match m as n1 return poption (F (plus_k n1 n)) with
      | 0 => pSome f
      | S m0 => dlist_get m0 dl0
      end
    end.

  Theorem plus_k_conv : forall m n, plus_k m n = m + n.
  Proof.
    induction m.
    - reflexivity.
    - simpl; intros.
      rewrite IHm.
      omega.
  Qed.

  Definition get_env n m (dl : dlist m)
  : poption (F (m + n)).
    rewrite PeanoNat.Nat.add_comm.
    rewrite <- plus_k_conv.
    eapply dlist_get. assumption.
  Defined.

  Definition dlist_empty := dnil.

  Lemma plus_0 : forall n, n = n + 0.
  Proof.
    induction n; simpl; auto.
  Defined.

  Definition dlist_tl {n} (dl : dlist n) : dlist (S n) :=
    match dl with
    | dnil _ => dnil _
    | dcons _ dl => dl
    end.

  Section insert.
    Variable (default : forall n, F n).

    Fixpoint dlist_insert n m (f : F (m + n) -> F (m + n)) {struct n}
      : dlist m -> dlist m.
      destruct n.
      - destruct 1.
        + apply dcons. rewrite <- plus_0 in f. apply f. apply default.
          apply dnil.
        + apply dcons. rewrite <- plus_0 in f. apply f. apply f0. apply dnil.
      - intros.
        apply dcons.
        + destruct X.
          * apply default.
          * apply f0.
        + rewrite PeanoNat.Nat.add_comm in f.  simpl in *.
          rewrite PeanoNat.Nat.add_comm in f.
          eapply dlist_insert. eapply f.
          apply dlist_tl. apply X.
    Defined.
  End insert.

End dlist.

Section symD.
  (** TODO(gmalecha): The contents should use positives rather than nats *)
  Variable env : dlist (fun n => plist (type_for_arity n)) 0.

  Record sym (n : nat) : Type := mkSym
  { idx : nat
  ; sym_valid : match get_env n env return Prop with
                | pNone => False
                | pSome x => match PList.nth_error x idx return Prop with
                             | pNone => False
                             | pSome _ => True
                             end
                end }.

  Definition symD {n : nat} (s : sym n) : type_for_arity n :=
    match get_env n env as X
          return forall idx, match X with
                             | pNone => False
                             | pSome x => match nth_error x idx with
                                          | pNone => False
                                          | pSome _ => True
                                          end
                             end -> type_for_arity n
    with
    | pNone => fun _ (pf : False) => match pf with end
    | pSome lst => fun idx =>
                     match nth_error lst idx as X
                           return match X with
                                  | pNone => False
                                  | pSome _ => True
                                  end -> type_for_arity n
                     with
                     | pNone => fun (pf : False) => match pf with end
                     | pSome res => fun (_ : True) => res
                     end
    end s.(idx) s.(sym_valid).
End symD.

Definition types : Type := plist (sigT type_for_arity).
Definition a_type := @existT _ type_for_arity.

Fixpoint build_env (t : types) : dlist (fun n => plist (type_for_arity n)) 0.
  destruct t.
  - apply dnil.
  - eapply dlist_insert.
    * intros. apply pnil.
    * instantiate (1:= projT1 s).
      exact (pcons (projT2 s)).
    * apply (build_env t).
Defined.

(** * Demo **)
Local Definition test : types :=
  pcons (a_type 0 nat)
        (pcons (a_type 1 list)
               (pcons (a_type 0 bool)
               pnil)).

(*
Eval cbv beta iota zeta delta - [ type_for_arity ] in build_env test.
*)


From Undecidability Require TM.TM TM.Util.TM_facts.
From Undecidability Require Import TM.SBTM TM.Util.SBTM_facts.
Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.FinTypes.

Require Import PeanoNat Lia.

#[local] Unset Implicit Arguments.
#[local] Unset Strict Implicit.

Require Import List ssreflect ssrbool ssrfun.
Import ListNotations SBTMNotations.

Set Default Goal Selector "!".

#[local] Notation "| a |" := (Vector.cons _ a 0 (Vector.nil _)).

Section Construction.
  (* input SBTM and initial state *)
  Context (M : SBTM) (q0 : state M).

  Definition encode_tape (t : tape) : TM.tape (finType_CS bool) :=
    match t with
    | (ls, a, rs) => TM.midtape ls a rs
    end.

  #[local] Notation state' := (option (Fin.t ((num_states M)))).

  Definition finTypeC_state' : finType :=
    @finType_CS state' _ (CompoundFinTypes.finTypeC_Option _).

  Definition halt' (q : state') : bool := if q is None then true else false.

  Definition get_symbol (ob : option (finType_CS bool)) : bool :=
    match ob with
    | None => false
    | Some b => b
    end.

  Definition encode_direction (d : direction) :=
    match d with
    | go_left => TM.Lmove
    | go_right => TM.Rmove
    end.

  Definition M' : TM.TM (finType_CS bool) 1.
  Proof using M q0.
    refine (@TM.Build_TM _ _ finTypeC_state' (fun '(q, bs) => _) (Some q0) halt').
    refine (
      match q with
      | Some qM => _
      | None => (None, | (None, TM.Nmove) | )
      end).
    refine (
      match trans' M (qM, get_symbol (Vector.hd bs)) with
      | None => (None, | (None, TM.Nmove) | )
      | Some (q', a', d') => (Some q', | (Some a',encode_direction d') | )
      end).
  Defined.

  #[local] Notation TM_step x := (@TM_facts.step _ _ M' x).
  #[local] Notation TM_config := (@TM_facts.mconfig (finType_CS bool) (TM.state M') 1).

  Definition encode_config : config M -> TM_config :=
    fun '(q, t) => TM_facts.mk_mconfig (Some q) (| encode_tape t |).

  Definition canonize_tape (t : TM.tape (finType_CS bool)) :=
    match t with
    | TM.niltape => TM.midtape [] false []
    | TM.leftof r rs => TM.midtape [] false (r :: rs)
    | TM.rightof l ls => TM.midtape (l :: ls) false []
    | _ => t
    end.

  Lemma get_symbol_canonize_tape {t1 t2} :
    canonize_tape t1 = canonize_tape t2 ->
    get_symbol (TM.current t1) = get_symbol (TM.current t2).
  Proof.
    move: t1 t2 => [ | ?? | ?? | ???] [] > /=; congruence.
  Qed.

  Lemma doAct_canonize_tape {t1 t2} a d :
    canonize_tape t1 = canonize_tape t2 ->
    canonize_tape (TM_facts.doAct t1 (Some a, encode_direction d)) =
    canonize_tape (TM_facts.doAct t2 (Some a, encode_direction d)).
  Proof.
    move: d t1 t2.
    move=> [] [ | ?? | ?? | [|??]?[|??] ] [ | ?? | ?? | [|??]?[|??] ] /=; cbn; congruence.
  Qed.

  Lemma TM_step_canonize_tape oq oq1 t1 t'1 oq2 t2 t'2 :
    canonize_tape t1 = canonize_tape t2 ->
    TM_step (TM_facts.mk_mconfig oq (| t1 |)) = TM_facts.mk_mconfig oq1 (| t'1 |) ->
    TM_step (TM_facts.mk_mconfig oq (| t2 |)) = TM_facts.mk_mconfig oq2 (| t'2 |) ->
    oq1 = oq2 /\ canonize_tape t'1 = canonize_tape t'2.
  Proof.
    move=> Ht1t2.
    rewrite /TM_facts.step /= -(get_symbol_canonize_tape Ht1t2).
    case: oq => [q|].
    - move: (trans' M _) => [[[q' a'] d']|] /=.
      + move=> [] <- <- [] <- <-. split; first done.
        by apply: doAct_canonize_tape.
      + by move=> [] <- <- [] <- <-.
    - by move=> [] <- <- [] <- <-.
  Qed.

  Lemma TM_loopM_canonize_tape (oq : TM.state M') t1 t2 k q' t'1 :
    canonize_tape t1 = canonize_tape t2 ->
    TM_facts.loopM (TM_facts.mk_mconfig oq (| t1 |)) k = Some (TM_facts.mk_mconfig q' t'1) ->
    { t'2 | TM_facts.loopM (TM_facts.mk_mconfig oq (| t2 |)) k = Some (TM_facts.mk_mconfig q' t'2) }.
  Proof.
    elim: k oq t1 t2.
    { move=> > _ /=. case: (halt' _) => [|]; last done.
      move=> [] /= -> _. by eexists. }
    move=> k IH oq t1 t2 Ht1t2 /=.
    case: (halt' _) => [|] /=. { move=> [] -> _. by eexists. }
    move E1: (TM_step _) => [q1 ts1]. move E2: (TM_step _) => [q2 ts2].
    move: E1 E2.
    rewrite (Vector.eta ts1). move: (VectorDef.tl ts1). apply: Vector.case0.
    rewrite (Vector.eta ts2). move: (VectorDef.tl ts2). apply: Vector.case0.
    move: (Ht1t2) => /TM_step_canonize_tape /[apply] /[apply].
    move=> [<-] /IH. by apply.
  Qed.

  (* step simulation up to canonize_tape *)
  Lemma simulation_step q t q' t' : step M (q, t) = Some (q', t') ->
    { t'' |
      TM_step (encode_config (q, t)) = TM_facts.mk_mconfig (Some q') (| t'' |) /\
      encode_tape t' = canonize_tape t'' }.
  Proof.
    rewrite /step /TM_facts.step /=.
    move: t => [[ls a] rs] /=. case: (trans' M _) => [[[? ?] d]|] /=; last done.
    move=> [] -> <-. case: d => /=.
    - case: ls => [|??] /=; eexists; split; reflexivity.
    - case: rs => [|??] /=; eexists; split; reflexivity.
  Qed.

  Lemma simulation_halt q t : step M (q, t) = None ->
    TM_step (encode_config (q, t)) = TM_facts.mk_mconfig None (| encode_tape t |).
  Proof.
    rewrite /step /TM_facts.step /=.
    move: t => [[ls a] rs] /=.
    by case: (trans' M _) => [[[? ?] d]|] /=.
  Qed.

  Lemma simulation q t k :
    steps M k (q, t) = None ->
    exists q' ts', TM.eval M' (Some q) (| encode_tape t |) q' ts'.
  Proof.
    elim: k q t; first done.
    move=> k IH q t.
    rewrite (steps_plus 1 k). case E: (steps M 1 _) => [[q' t']|].
    - move: E => /simulation_step [t'' [HM' Ht't'']] /IH.
      move=> [q'''] [t'''] /TM_facts.TM_eval_iff [k'].
      rewrite Ht't''. move=> /TM_loopM_canonize_tape => /(_ t'').
      move=> /(_ ltac:(by case: (t''))). move=> [{}t''' ?].
      exists q''', t'''. apply /TM_facts.TM_eval_iff. exists (S k').
      by rewrite /= HM'.
    - move=> _. exists None, (| encode_tape t |).
      apply /TM_facts.TM_eval_iff. exists 1.
      move: E.
      rewrite /= /step /TM_facts.step /=.
      move: t => [[ls a] rs] /=.
      by case: (trans' M (q, a)) => [[[??]?]|].
  Qed.

  Lemma inverse_simulation q t q' ts' :
    TM.eval M' (Some q) (| encode_tape t |) q' ts' ->
    exists k, steps M k (q, t) = None.
  Proof.
    move=> /TM_facts.TM_eval_iff => - [k Hk]. exists k.
    elim: k q t q' ts' Hk; first done.
    move=> k IH q t q' ts' Hk. rewrite (steps_plus 1 k).
    case Hqt: (steps M 1 (q, t)) => [[q'' t'']|]; last done.
    move: Hqt => /simulation_step [t'''] [H'qt Et''t'''].
    move: Hk => /=. rewrite H'qt.
    have : canonize_tape t''' = canonize_tape (encode_tape t'').
    { rewrite Et''t'''. by case: (t'''). }
    by move=> /TM_loopM_canonize_tape /[apply] => - [?] /IH.
  Qed.

End Construction.

Require Import Undecidability.Synthetic.Definitions.

Theorem reduction :
  SBTM_HALT ⪯ TM.HaltTM 1.
Proof.
  exists ((fun '(existT _ M (q, t)) =>
    existT2 _ _ (finType_CS bool) (M' M q) (| encode_tape t |)) ).
  move=> [M [q t]] /=. split.
  - by move=> [k] /simulation => /(_ q).
  - by move=> [?] [?] /inverse_simulation.
Qed.


Require Import String ZArith Lia.
Require Export lang.

Definition pred := env -> Prop.

Open Scope lang_scope.

(* Extraordinalriy awkward because of higher-order unification...
   I think this is mostly solved by defining a WP.
 *)
Inductive hoare : pred -> insn -> pred -> Prop :=
| H_Skip : forall P,
    hoare P Skip P
| H_Assign : forall P x e,
    hoare (fun f => P (f [x --> eval_expr f e])) (x :== e) P
| H_Seq : forall P Q R i j,
    hoare P i Q ->
    hoare Q j R ->
    hoare P (i;j) R
| H_Ite : forall P Q e i j,
    hoare (fun f => eval_expr f e <> 0 /\ P f) i Q ->
    hoare (fun f => eval_expr f e = 0 /\ P f) j Q ->
    hoare P (If e Then i Else j) Q
| H_While : forall (P Q I : pred) e i,
    hoare (fun f => eval_expr f e <> 0 /\ I f) i I ->
    (forall f, I f -> eval_expr f e = 0 -> Q f) ->
    (forall f, P f -> I f) ->
    hoare P (While e Do i Done) Q
| H_Weak : forall (P P' Q Q' : pred) i,
    (forall f, P' f -> P f) ->
    (forall f, Q f -> Q' f) ->
    hoare P i Q ->
    hoare P' i Q'
.

Hint Constructors hoare.

Example test : hoare (fun f => True) ("foo" :== 42) (fun f => f "foo" = 42).
Proof.
  eapply H_Weak.
  - intros.
    assert (H' : f ["foo" --> eval_expr f 42] "foo" = 42) by reflexivity.
    exact H'.
  - intros.
    exact H.
  - apply H_Assign with (P := fun f => f "foo" = 42).
Qed.

Example test' : hoare (fun f => True) (If 0 Then Skip Else "foo" :== 42) (fun f => f "foo" = 42).
Proof.
  apply H_Ite.
  - simpl.
    apply H_Weak with (P := fun f => f "foo" = 42)(Q := fun f => f "foo" = 42); intros; firstorder.
  - eapply H_Weak with (P := fun f => f ["foo" --> eval_expr f 42] "foo" = 42)
                       (Q := fun f => f "foo" = 42).
    + simpl; now auto.
    + now auto.
    + apply H_Assign with (P := fun f => f "foo" = 42).
Qed.

Lemma while_inv : forall (I Q : pred) i body f g e,
    (forall f' g', I f' -> eval_expr f' e <> 0 -> big_step f' body g' -> I g') ->
    (forall f', I f' -> eval_expr f' e = 0 -> Q f') ->
    I f ->
    big_step f i g ->
    (i = While e Do body Done) ->
    Q g.
Proof.
  intros I Q i body f g e inv_body inv_break init big.
  induction big; intro eq; try inversion eq; subst; auto.
  apply IHbig2; [| now auto].
  eapply inv_body; [| apply H | apply big1].
  apply init.
Qed.

Theorem hoare_sound : forall f g P Q i,
    hoare P i Q -> big_step f i g -> P f -> Q g.
Proof.
  intros f g P Q i h.
  revert f g.
  induction h; intros f g step; inversion step; subst; eauto.
  (* 1 subgoal! *)
  intro hf.
  eapply while_inv; intros.
  - apply IHh with (f := f'); now eauto.
  - apply H; now auto.
  - simpl; apply H0; now eauto.
  - exact step.
  - reflexivity.
Qed.

(* This should be the strongest postcondition for [While e Do body
  Done], given P as a precondition. *)

Inductive invariant : forall (P : pred) (e : expr) (i : insn) (f : env), Prop :=
| inv_0 : forall (P : pred) e i f, P f -> invariant P e i f
| inv_s : forall (P : pred) e i f g,
    eval_expr f e <> 0 ->
    big_step f i g ->
    invariant P e i f ->
    invariant P e i g.

Hint Constructors invariant.

Lemma while_SP_1 : forall body e (P : pred) f,
    P f -> invariant P e body f.
Proof.
  intros; econstructor; now eauto.
Qed.

Lemma while_SP_2_gen : forall body e (P Q : pred),
    (forall f g, P f -> big_step f (While e Do body Done) g -> Q g) ->
    forall g h, invariant P e body g -> big_step g (While e Do body Done) h -> Q h.
Proof.
  intros until h; intros inv; induction inv.
  - intros; eapply H; now eauto.
  - intros; apply IHinv; auto.
    econstructor; now eauto.
Qed.

Lemma while_SP_2 : forall body e (P Q : pred),
    (forall f g, P f -> big_step f (While e Do body Done) g -> Q g) ->
    forall g, invariant P e body g -> eval_expr g e = 0 -> Q g.
Proof.
  intros; eapply while_SP_2_gen; now eauto.
Qed.

Theorem hoare_complete : forall i (P Q : pred),
    (forall f g, P f -> big_step f i g -> Q g) -> hoare P i Q.
Proof.
  induction i; intros P Q prop.
  - apply H_Weak with (P := P)(Q := P); auto.
    intros.
    eapply prop; try apply H; now auto.
  (* eauto works! *)
  - apply H_Weak with (P := (fun f => Q (f [s --> eval_expr f e])))(Q := Q); eauto.
  - apply H_Seq with (Q := fun f => forall g, big_step f i2 g -> Q g).
    + apply IHi1.
      intros; eauto.
    + apply IHi2; intros; eauto.
  - apply H_Ite.
    + apply IHi1; intros.
      eapply prop; destruct H; eauto.
    + apply IHi2; intros.
      eapply prop; destruct H; eauto.
  - eapply H_While with (I := invariant P e i); intros.
    + apply IHi.
      intros f g [neq H] bs. now eauto.
    + eapply while_SP_2; now eauto.
    + eapply while_SP_1; now eauto.
Qed.

(* Inductive is_fix : forall (F : (env -> env) -> env -> env) (f : env -> env), Prop := *)
(*   | is_fix_unfold : forall F f, is_fix F f -> is_fix F (F f). *)

Definition is_fix (F : (env -> env) -> env -> env) (f : env -> env) :=
  forall ctx, f ctx = F f ctx.

Definition fix_of_while (e : expr) (body : env -> env)
           (F : env -> env) :=
  fun ctx =>
    if eval_expr ctx e =? 0
    then ctx
    else
      let ctx' := body ctx in
      F ctx'.

Check fix_of_while.

Definition evals_to body body_sem :=
  forall f, big_step f body (body_sem f).

Check evals_to.
Print pred.

Print env.

Check hoare_complete.

Lemma ext_eval : forall f g e, f ≃ g -> eval_expr f e = eval_expr g e.
Proof.
  intros until e; induction e; simpl; intros; auto.
  rewrite IHe1; auto; rewrite IHe2; auto.
Qed.

(* this should really be in the logic area. *)
Lemma simeq_sym : forall f g, f ≃ g -> g ≃ f.
Proof. intros; intro; auto. Qed.

Hint Resolve simeq_sym.

Lemma fix_to_while_big : forall body e body_sem f ctx,
    evals_to body body_sem ->
    let specF := fix_of_while e body_sem in
    is_fix specF f ->
    big_step ctx (While e Do body Done) (f ctx).
Proof.
  intros body e body_sem f ctx h_body_sem specF h_is_fix.
  Search ({ _ = _} + {_ <> _}).
  case (Z.eq_dec (eval_expr ctx e) 0); intro eq_e.
  - subst specF.
    unfold fix_of_while, is_fix in *.
    assert (eval_zero : eval_expr ctx e =? 0 = true) by (apply Z.eqb_eq; auto).
    assert (h_is_fix' := h_is_fix ctx).
    rewrite eval_zero in *.
    rewrite h_is_fix'.
    apply BS_While_halt; now auto.
  - subst specF.
    unfold fix_of_while, is_fix in *.
    assert (eval_nz : eval_expr ctx e =? 0 = false) by (apply Z.eqb_neq; auto).
    eapply BS_While_continue; eauto.
    assert (h_is_fix' := h_is_fix ctx).
    rewrite eval_nz in *; rewrite h_is_fix'.
    (* Uh oh *)
Admitted.

Theorem fix_to_while : forall body e body_sem f,
    evals_to body body_sem ->
    let specF := fix_of_while e body_sem in
    is_fix specF f ->
    forall ctx,
      hoare (fun k => k ≃ ctx) (While e Do body Done) (fun k => k ≃ (f ctx)).
Proof.
  intros.
  eapply hoare_complete; intros.
  eapply big_step_ext; [eauto | | apply H1 | reflexivity].
  eapply fix_to_while_big; now eauto.
Qed.


(** * ImpParser: Lexing and Parsing in Coq *)

(** The development of the [Imp] language in Imp.v completely ignores
    issues of concrete syntax -- how an ascii string that a programmer
    might write gets translated into the abstract syntax trees defined
    by the datatypes [aexp], [bexp], and [com].  In this file we
    illustrate how the rest of the story can be filled in by building
    a simple lexical analyzer and parser using Coq's functional
    programming facilities.

    This development is not intended to be understood in detail: the
    explanations are fairly terse and there are no exercises.  The
    main point is simply to demonstrate that it can be done.  You are
    invited to look through the code -- most of it is not very
    complicated, though the parser relies on some "monadic"
    programming idioms that may require a little work to make out --
    but most readers will probably want to just skip down to the
    Examples section at the very end to get the punchline. *)

(* ####################################################### *)
(** * Internals *)

Require Import SfLib.
Require Import Imp.

Require Import String.
Require Import Ascii.

Open Scope list_scope.

(* ####################################################### *)
(** ** Lexical Analysis *)

Definition isWhite (c : ascii) : bool :=
  let n := nat_of_ascii c in
  orb (orb (beq_nat n 32)   (* space *)
           (beq_nat n 9))   (* tab *)
      (orb (beq_nat n 10)   (* linefeed *)
           (beq_nat n 13)). (* Carriage return. *)

Notation "x '<=?' y" := (ble_nat x y)
  (at level 70, no associativity) : nat_scope.

Definition isLowerAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
    andb (97 <=? n) (n <=? 122).

Definition isAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
    orb (andb (65 <=? n) (n <=? 90))
        (andb (97 <=? n) (n <=? 122)).

Definition isDigit (c : ascii) : bool :=
  let n := nat_of_ascii c in
     andb (48 <=? n) (n <=? 57).

Inductive chartype := white | alpha | digit | other.

Definition classifyChar (c : ascii) : chartype :=
  if isWhite c then
    white
  else if isAlpha c then
    alpha
  else if isDigit c then
    digit
  else
    other.

Fixpoint list_of_string (s : string) : list ascii :=
  match s with
  | EmptyString => []
  | String c s => c :: (list_of_string s)
  end.

Fixpoint string_of_list (xs : list ascii) : string :=
  fold_right String EmptyString xs.

Definition token := string.

Fixpoint tokenize_helper (cls : chartype) (acc xs : list ascii)
                       : list (list ascii) :=
  let tk := match acc with [] => [] | _::_ => [rev acc] end in
  match xs with
  | [] => tk
  | (x::xs') =>
    match cls, classifyChar x, x with
    | _, _, "("      => tk ++ ["("]::(tokenize_helper other [] xs')
    | _, _, ")"      => tk ++ [")"]::(tokenize_helper other [] xs')
    | _, white, _    => tk ++ (tokenize_helper white [] xs')
    | alpha,alpha,x  => tokenize_helper alpha (x::acc) xs'
    | digit,digit,x  => tokenize_helper digit (x::acc) xs'
    | other,other,x  => tokenize_helper other (x::acc) xs'
    | _,tp,x         => tk ++ (tokenize_helper tp [x] xs')
    end
  end %char.

Definition tokenize (s : string) : list string :=
  map string_of_list (tokenize_helper white [] (list_of_string s)).

Example tokenize_ex1 :
    tokenize "abc12==3  223*(3+(a+c))" %string
  = ["abc"; "12"; "=="; "3"; "223";
       "*"; "("; "3"; "+"; "(";
       "a"; "+"; "c"; ")"; ")"]%string.
Proof. reflexivity. Qed.

(* ####################################################### *)
(** ** Parsing *)

(* ####################################################### *)
(** *** Options with Errors *)

(* An option with error messages. *)
Inductive optionE (X:Type) : Type :=
  | SomeE : X -> optionE X
  | NoneE : string -> optionE X.

Implicit Arguments SomeE [[X]].
Implicit Arguments NoneE [[X]].

(* Some syntactic sugar to make writing nested match-expressions on
   optionE more convenient. *)

Notation "'DO' ( x , y ) <== e1 ; e2"
   := (match e1 with
         | SomeE (x,y) => e2
         | NoneE err => NoneE err
       end)
   (right associativity, at level 60).

Notation "'DO' ( x , y ) <-- e1 ; e2 'OR' e3"
   := (match e1 with
         | SomeE (x,y) => e2
         | NoneE err => e3
       end)
   (right associativity, at level 60, e2 at next level).

(* ####################################################### *)
(** *** Symbol Table *)

(* Build a mapping from [tokens] to [nats].  A real parser would do
   this incrementally as it encountered new symbols, but passing
   around the symbol table inside the parsing functions is a bit
   inconvenient, so instead we do it as a first pass. *)
Fixpoint build_symtable (xs : list token) (n : nat) : (token -> nat) :=
  match xs with
  | [] => (fun s => n)
  | x::xs =>
    if (forallb isLowerAlpha (list_of_string x))
     then (fun s => if string_dec s x then n else (build_symtable xs (S n) s))
     else build_symtable xs n
  end.

(* ####################################################### *)
(** *** Generic Combinators for Building Parsers *)

Open Scope string_scope.

Definition parser (T : Type) :=
  list token -> optionE (T * list token).

Fixpoint many_helper {T} (p : parser T) acc steps xs :=
match steps, p xs with
| 0, _ => NoneE "Too many recursive calls"
| _, NoneE _ => SomeE ((rev acc), xs)
| S steps', SomeE (t, xs') => many_helper p (t::acc) steps' xs'
end.

(* A (step-indexed) parser which expects zero or more [p]s *)
Fixpoint many {T} (p : parser T) (steps : nat) : parser (list T) :=
  many_helper p [] steps.

(* A parser which expects a given token, followed by p *)
Definition firstExpect {T} (t : token) (p : parser T) : parser T :=
  fun xs => match xs with
              | x::xs' => if string_dec x t
                           then p xs'
                          else NoneE ("expected '" ++ t ++ "'.")
              | [] =>  NoneE ("expected '" ++ t ++ "'.")
            end.

(* A parser which expects a particular token *)
Definition expect (t : token) : parser unit :=
  firstExpect t (fun xs => SomeE(tt, xs)).

(* ####################################################### *)
(** *** A Recursive-Descent Parser for Imp *)

(* Identifiers *)
Definition parseIdentifier (symtable :string->nat) (xs : list token)
                         : optionE (id * list token) :=
match xs with
| [] => NoneE "Expected identifier"
| x::xs' =>
    if forallb isLowerAlpha (list_of_string x) then
      SomeE (Id (symtable x), xs')
    else
      NoneE ("Illegal identifier:'" ++ x ++ "'")
end.

(* Numbers *)
Definition parseNumber (xs : list token) : optionE (nat * list token) :=
match xs with
| [] => NoneE "Expected number"
| x::xs' =>
    if forallb isDigit (list_of_string x) then
      SomeE (fold_left (fun n d =>
                        10 * n + (nat_of_ascii d - nat_of_ascii "0"%char))
                (list_of_string x)
                0,
              xs')
    else
      NoneE "Expected number"
end.

(* Parse arithmetic expressions *)
Fixpoint parsePrimaryExp (steps:nat) symtable (xs : list token)
   : optionE (aexp * list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
      DO (i, rest) <-- parseIdentifier symtable xs ;
          SomeE (AId i, rest)
      OR DO (n, rest) <-- parseNumber xs ;
          SomeE (ANum n, rest)
      OR (DO (e, rest)  <== firstExpect "(" (parseSumExp steps' symtable) xs;
          DO (u, rest') <== expect ")" rest ;
          SomeE(e,rest'))
  end
with parseProductExp (steps:nat) symtable (xs : list token)  :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    DO (e, rest) <==
      parsePrimaryExp steps' symtable xs ;
    DO (es, rest') <==
      many (firstExpect "*" (parsePrimaryExp steps' symtable)) steps' rest;
    SomeE (fold_left AMult es e, rest')
  end
with parseSumExp (steps:nat) symtable (xs : list token)  :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    DO (e, rest) <==
      parseProductExp steps' symtable xs ;
    DO (es, rest') <==
      many (fun xs =>
             DO (e,rest') <--
               firstExpect "+" (parseProductExp steps' symtable) xs;
                                 SomeE ( (true, e), rest')
             OR DO (e,rest') <==
               firstExpect "-" (parseProductExp steps' symtable) xs;
                                 SomeE ( (false, e), rest'))
                            steps' rest;
      SomeE (fold_left (fun e0 term =>
                          match term with
                            (true,  e) => APlus e0 e
                          | (false, e) => AMinus e0 e
                          end)
                       es e,
             rest')
  end.

Definition parseAExp := parseSumExp.

(* Parsing boolean expressions. *)
Fixpoint parseAtomicExp (steps:nat) (symtable : string->nat) (xs : list token)  :=
match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
     DO    (u,rest) <-- expect "true" xs;
         SomeE (BTrue,rest)
     OR DO (u,rest) <-- expect "false" xs;
         SomeE (BFalse,rest)
     OR DO (e,rest) <-- firstExpect "not" (parseAtomicExp steps' symtable) xs;
         SomeE (BNot e, rest)
     OR DO (e,rest) <-- firstExpect "(" (parseConjunctionExp steps' symtable) xs;
          (DO (u,rest') <== expect ")" rest; SomeE (e, rest'))
     OR DO (e, rest) <== parseProductExp steps' symtable xs ;
            (DO (e', rest') <--
              firstExpect "==" (parseAExp steps' symtable) rest ;
              SomeE (BEq e e', rest')
             OR DO (e', rest') <--
               firstExpect "<=" (parseAExp steps' symtable) rest ;
               SomeE (BLe e e', rest')
             OR
               NoneE "Expected '==' or '<=' after arithmetic expression")
end
with parseConjunctionExp (steps:nat) (symtable : string->nat) (xs : list token)   :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    DO (e, rest) <==
      parseAtomicExp steps' symtable xs ;
    DO (es, rest') <==
      many (firstExpect "&&" (parseAtomicExp steps' symtable)) steps' rest;
    SomeE (fold_left BAnd es e, rest')
  end.

Definition parseBExp := parseConjunctionExp.

(*
Eval compute in
  (parseProductExp 100 (tokenize "x*y*(x*x)*x")).

Eval compute in
  (parseDisjunctionExp 100 (tokenize "not((x==x||x*x<=(x*x)*x)&&x==x)")).
*)

(* Parsing commands *)
Fixpoint parseSimpleCommand (steps:nat) (symtable:string->nat) (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    DO (u, rest) <-- expect "SKIP" xs;
      SomeE (SKIP, rest)
    OR DO (e,rest) <--
         firstExpect "IF" (parseBExp steps' symtable) xs;
       DO (c,rest')  <==
         firstExpect "THEN" (parseSequencedCommand steps' symtable) rest;
       DO (c',rest'') <==
         firstExpect "ELSE" (parseSequencedCommand steps' symtable) rest';
       DO (u,rest''') <==
         expect "END" rest'';
       SomeE(IFB e THEN c ELSE c' FI, rest''')
    OR DO (e,rest) <--
         firstExpect "WHILE" (parseBExp steps' symtable) xs;
       DO (c,rest') <==
         firstExpect "DO" (parseSequencedCommand steps' symtable) rest;
       DO (u,rest'') <==
         expect "END" rest';
       SomeE(WHILE e DO c END, rest'')
    OR DO (i, rest) <==
         parseIdentifier symtable xs;
       DO (e, rest') <==
         firstExpect ":=" (parseAExp steps' symtable) rest;
       SomeE(i ::= e, rest')
  end

with parseSequencedCommand (steps:nat) (symtable:string->nat) (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
      DO (c, rest) <==
        parseSimpleCommand steps' symtable xs;
      DO (c', rest') <--
        firstExpect ";;" (parseSequencedCommand steps' symtable) rest;
        SomeE(c ;; c', rest')
      OR
        SomeE(c, rest)
  end.

Definition bignumber := 1000.

Definition parse (str : string) : optionE (com * list token) :=
  let tokens := tokenize str in
  parseSequencedCommand bignumber (build_symtable tokens 0) tokens.

(* ####################################################### *)
(** * Examples *)

(*
Eval compute in parse "
    IF x == y + 1 + 2 - y * 6 + 3 THEN
      x := x * 1;;
      y := 0
    ELSE
      SKIP
    END  ".
====>
    SomeE
       (IFB BEq (AId (Id 0))
                (APlus
                   (AMinus (APlus (APlus (AId (Id 1)) (ANum 1)) (ANum 2))
                      (AMult (AId (Id 1)) (ANum 6)))
                   (ANum 3))
        THEN Id 0 ::= AMult (AId (Id 0)) (ANum 1);; Id 1 ::= ANum 0
        ELSE SKIP FI, [])
*)

(*
Eval compute in parse "
    SKIP;;
    z:=x*y*(x*x);;
    WHILE x==x DO
      IF z <= z*z && not x == 2 THEN
        x := z;;
        y := z
      ELSE
        SKIP
      END;;
      SKIP
    END;;
    x:=z  ".
====>
     SomeE
        (SKIP;;
         Id 0 ::= AMult (AMult (AId (Id 1)) (AId (Id 2)))
                        (AMult (AId (Id 1)) (AId (Id 1)));;
         WHILE BEq (AId (Id 1)) (AId (Id 1)) DO
           IFB BAnd (BLe (AId (Id 0)) (AMult (AId (Id 0)) (AId (Id 0))))
                     (BNot (BEq (AId (Id 1)) (ANum 2)))
              THEN Id 1 ::= AId (Id 0);; Id 2 ::= AId (Id 0)
              ELSE SKIP FI;;
           SKIP
         END;;
         Id 1 ::= AId (Id 0),
        [])
*)

(*
Eval compute in parse "
   SKIP;;
   z:=x*y*(x*x);;
   WHILE x==x DO
     IF z <= z*z && not x == 2 THEN
       x := z;;
       y := z
     ELSE
       SKIP
     END;;
     SKIP
   END;;
   x:=z  ".
=====>
      SomeE
         (SKIP;;
          Id 0 ::= AMult (AMult (AId (Id 1)) (AId (Id 2)))
                (AMult (AId (Id 1)) (AId (Id 1)));;
          WHILE BEq (AId (Id 1)) (AId (Id 1)) DO
            IFB BAnd (BLe (AId (Id 0)) (AMult (AId (Id 0)) (AId (Id 0))))
                     (BNot (BEq (AId (Id 1)) (ANum 2)))
              THEN Id 1 ::= AId (Id 0);;
                   Id 2 ::= AId (Id 0)
              ELSE SKIP
            FI;;
            SKIP
          END;;
          Id 1 ::= AId (Id 0),
         []).
*)

(** $Date: 2014-12-31 11:17:56 -0500 (Wed, 31 Dec 2014) $ *)


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export Peano.
Require Export Arith.
Require Export Arith.EqNat.
Require Export Eqdep_dec.
Require Export eq_rel.
Require Export tactics.
Require Export tactics2.

Lemma contraposition :
  forall A B : Type, (A -> B) -> (!B -> !A).
Proof. sp. Qed.

Definition ltb (n m : nat) : bool :=
  if lt_dec n m then true else false.

Definition Ltb (n m : nat) : Prop := ltb n m = true.

Lemma Ltb_proof_irrelevance :
  forall {n m : nat}
         (x y : Ltb n m),
    x = y.
Proof.
  intros.
  apply UIP_dec.
  apply bool_dec.
Qed.

Lemma Ltb_lt {n m : nat} : Ltb n m -> n < m.
Proof.
  introv h.
  unfold Ltb, ltb in h.
  destruct (lt_dec n m); ginv.
Qed.

Lemma lt_Ltb {n m : nat} : n < m -> Ltb n m.
Proof.
  introv h.
  unfold Ltb, ltb.
  destruct (lt_dec n m); tcsp.
Qed.

Definition nat_k (k : nat) := {n : nat & Ltb n k}.
Definition mk_nat_k {k} (n : nat) (p : Ltb n k) : nat_k k := existT _ n p.
Definition mk_nat_k1 {k} (n : nat) (p : n < k) : nat_k k := mk_nat_k n (lt_Ltb p).

Definition kseq (n : nat) := nat_k n -> nat.
Definition pseq := {n : nat & kseq n}.
Definition seq := nat -> nat.

Definition mk_pseq {n : nat} (f : kseq n) : pseq := existT _ n f.

Definition emseq : seq := fun x => 0.
Definition emkseq : kseq 0 := fun x => 0.
Definition empseq : pseq := mk_pseq emkseq.

Definition m_seq2kseq (s : seq) (n : nat) : kseq n :=
  fun x =>
    match x with
      | existT _ k ltk => s k
    end.

Definition m_seq2pseq (s : seq) (n : nat) : pseq :=
  mk_pseq (m_seq2kseq s n).

Definition extend1 (n : nat) (f : kseq n) (k : nat) : kseq (S n) :=
  fun x =>
    match x with
      | existT _ m _ =>
        match lt_dec m n with
          | left p => f (mk_nat_k1 m p)
          | _ => k
        end
    end.

Definition extend (s : pseq) (k : nat) : pseq :=
  match s with
    | existT _ n f => mk_pseq (extend1 n f k)
  end.

Definition barind_dec (R : pseq -> Type) : Type :=
  forall (s : pseq), R s [+] !(R s).

Definition barind_bared (R : pseq -> Type) : Prop :=
  forall (s : seq),
    exists n, Cast (R (m_seq2pseq s n)).

Definition barind_imp (R : pseq -> Type) (A : pseq -> Prop) : Type :=
  forall (s : pseq), R s -> A s.

Definition barind_ind (A : pseq -> Prop) : Type :=
  forall (s : pseq),
    (forall k, A (extend s k))
    -> A s.

Require Export Classical_Pred_Type.

Lemma barind_ind_cont :
  forall (A : pseq -> Prop),
    barind_ind A
    -> forall s,
         !(A s)
         -> exists k, !(A (extend s k)).
Proof.
  introv bi na.
  pose proof (bi s) as h; clear bi.
  apply contraposition in h; auto.
  apply not_all_ex_not in h; auto.
Qed.

Definition barind (R : pseq -> Type) (A : pseq -> Prop) : Type :=
  barind_dec R
  -> barind_bared R
  -> barind_imp R A
  -> barind_ind A
  -> A empseq.

Definition pseqNA (A : pseq -> Prop) :=
  {s : pseq & !(A s)}.

Definition mk_pseqna {A : pseq -> Prop}
           (s : pseq)
           (p : !(A s)) : pseqNA A :=
  existT _ s p.

Definition pseqNA2seq {A : pseq -> Prop}
           (s : pseqNA A) : pseq := projT1 s.

Lemma nat_le : forall n, 0 <= n.
Proof. introv; omega. Qed.

Lemma nat_lt_S : forall n, n < S n.
Proof. introv; omega. Qed.

Lemma le2ltS : forall {n m}, n <= m -> n < S m.
Proof. introv; omega. Qed.

Lemma le2leS : forall {n m}, n <= m -> n <= S m.
Proof. introv; omega. Qed.

Definition kseq_at {n : nat} (s : kseq n) (m : nat) (p : m < n) : nat :=
  s (mk_nat_k1 m p).

Definition kseqNA (n : nat) (A : pseq -> Prop) :=
  {m : nat
   & {s : kseq (S n)
   & kseq_at s n (nat_lt_S n) = m
   # !(A (mk_pseq s)) }}.

Definition kseqNA2seq {n : nat} {A : pseq -> Prop}
           (k : kseqNA n A) : kseq (S n) :=
  match k with
    | existT _ _ (existT _ s _) => s
  end.

Definition kseqNA2m {n : nat} {A : pseq -> Prop}
           (k : kseqNA n A) : nat :=
  match k with
    | existT _ m _ => m
  end.

Definition mk_kseqna {n : nat} {A : pseq -> Prop}
           (m : nat)
           (s : kseq (S n))
           (q : kseq_at s n (nat_lt_S n) = m)
           (p : !(A (mk_pseq s))) : kseqNA n A :=
  existT _ m (existT _ s (q,p)).

Lemma kseq_at_extend1 :
  forall (n : nat)
         (g : kseq (S n))
         (k : nat),
    kseq_at (extend1 (S n) g k) (S n) (nat_lt_S (S n)) = k.
Proof.
  introv.
  unfold kseq_at, extend1; simpl.
  destruct (lt_dec (S n) (S n)); omega.
Qed.

Fixpoint alpha
         (A : pseq -> Prop)
         (h : !A empseq)
         (f : pseqNA A -> nat)
         (ind : forall a : pseqNA A, !A (extend (pseqNA2seq a) (f a)))
         (n : nat) : kseqNA n A :=
  match n with
    | 0 =>
      let ps := empseq in
      let p := mk_pseqna ps h in
      let k := f p in
      mk_kseqna k (extend1 0 emkseq k) eq_refl (ind p)
    | S n =>
      let (_,r) := alpha A h f ind n in
      let (g,pp) := r in
      let (_,na) := pp in
      let ps := mk_pseq g in
      let p := mk_pseqna ps na in
      let k := f p in
      mk_kseqna k (extend1 (S n) g k) (kseq_at_extend1 n g k) (ind p)
  end.

Definition kseq2kseq (n m : nat) (s : kseq n) (lemn : m <= n) : kseq m :=
  fun x =>
    match x with
      | existT _ k ltkm => s (mk_nat_k1 k (lt_le_trans k m n (Ltb_lt ltkm) lemn))
    end.

Definition kseqS2kseq (n : nat) (s : kseq (S n)) : kseq n :=
  fun x =>
    match x with
      | existT _ k ltkn => s (mk_nat_k1 k (lt_trans k n (S n) (Ltb_lt ltkn) (nat_lt_S n)))
    end.

Axiom functional_extensionality_dep : forall {A} {B : A -> Type},
  forall (f g : forall x : A, B x),
  (forall x, f x = g x) -> f = g.

Lemma fun_app :
  forall {A : Type} {B : A -> Type}
         (a : A)
         (f g : forall a : A, B a),
    f = g -> f a = g a.
Proof.
  introv e.
  subst; auto.
Qed.

Lemma alpha_prop1 :
  forall (A : pseq -> Prop)
         (h : !A empseq)
         (f : pseqNA A -> nat)
         (ind : forall a : pseqNA A, !A (extend (pseqNA2seq a) (f a)))
         (n m : nat)
         (lemn : m <= n),
    kseq2kseq (S n) (S m) (kseqNA2seq (alpha A h f ind n)) (le_n_S m n lemn)
    = kseqNA2seq (alpha A h f ind m).
Proof.
  introv.
  assert {k : nat & n = k + m} as e.
  { exists (n - m); omega. }
  exrepnd; subst.
  remember (le_n_S m (k + m) lemn) as lem; clear Heqlem lemn.
  induction k; introv;
  apply functional_extensionality_dep; introv; allsimpl.

  - unfold kseq2kseq.
    destruct x; allsimpl.
    unfold mk_nat_k1, mk_nat_k.

    match goal with
      | [ |- context[lt_Ltb ?a] ] => remember (lt_Ltb a) as l2
    end; clear Heql2.

    pose proof (Ltb_proof_irrelevance l l2) as e; subst; auto.

  - assert (S m <= S (k + m)) as e by omega.
    pose proof (IHk e) as q; clear IHk.
    rw <- q; clear q.
    unfold kseq2kseq.
    destruct x; allsimpl.

    remember (alpha A h f ind (k + m)) as am.
    unfold kseqNA in am; exrepnd; allsimpl.
    subst.
    dup l as ltx.
    apply Ltb_lt in ltx.
    destruct (lt_dec x (S (k + m))) as [d|d]; try omega;[].

    allunfold @mk_nat_k1.

    match goal with
      | [ |- context[lt_Ltb ?a] ] => remember (lt_Ltb a) as l1
    end; clear Heql1.

    match goal with
      | [ |- context[lt_Ltb ?a] ] => remember (lt_Ltb a) as l2
    end; clear Heql2.

    pose proof (Ltb_proof_irrelevance l1 l2) as xx; subst; auto.
Qed.

Lemma kseqNA2seq_last :
  forall (n : nat) (A : pseq -> Prop) (k : kseqNA n A),
    kseqNA2seq k (mk_nat_k n (lt_Ltb (nat_lt_S n)))
    = kseqNA2m k.
Proof.
  introv.
  unfold kseqNA2seq, kseqNA2m.
  destruct k; exrepnd.
  rw <- s2.
  unfold kseq_at.
  unfold mk_nat_k1; auto.
Qed.

Lemma emkseq_eq :
  forall s, emkseq = m_seq2kseq s 0.
Proof.
  introv.
  apply functional_extensionality_dep; introv; allsimpl.
  destruct x.
  dup l as q.
  apply Ltb_lt in q.
  destruct x; try omega.
Qed.

Axiom FunctionalChoice_on :
  forall (A B : Type) (R : A -> B -> Prop),
    (forall a : A, exists (b : B), R a b)
    -> (exists (f : A -> B), forall a : A, R a (f a)).

Require Export Classical_Prop.

(* Following Dummett's proof *)
Lemma barind_true_classically :
  forall (R : pseq -> Type) (A : pseq -> Prop),
    barind R A.
Proof.
  introv dec bar imp ind.
  pose proof (classic (A empseq)) as h.
  repndors; auto.
  provefalse.

  (* we now construct a sequence s which has no initial segment in R,
     i.e., forall n, ~(R (seq2pseq s n)) *)
  pose proof (barind_ind_cont A ind) as ind1; clear ind.

  assert (forall x : pseqNA A,
            exists k, !A (extend (pseqNA2seq x) k)) as ind2.
  { unfold pseqNA; introv; exrepnd; simpl; auto. }
  clear ind1.
  apply FunctionalChoice_on in ind2; exrepnd.
  rename ind0 into ind.

  remember (alpha A h f ind) as g.

  remember (fun m => kseqNA2m (g m)) as s.

  assert (forall n,
            m_seq2pseq s n
            = mk_pseq (kseqS2kseq n (kseqNA2seq (g n)))) as e.
  { introv; unfold m_seq2pseq.
    f_equal.
    subst.
    apply functional_extensionality_dep; introv.
    destruct x.

    unfold m_seq2kseq.
    unfold kseqS2kseq.

    unfold mk_nat_k1.

    match goal with
      | [ |- context[lt_Ltb ?a] ] => remember (lt_Ltb a) as l1
    end; clear Heql1.
    clear l.

    dup l1 as ltx.
    apply Ltb_lt in ltx.
    applydup lt_n_Sm_le in ltx as ltx2.

    pose proof (alpha_prop1 A h f ind n x ltx2) as e.
    apply (fun_app (mk_nat_k x (lt_Ltb (nat_lt_S x)))) in e.
    rw kseqNA2seq_last in e.
    rw <- e.

    unfold kseq2kseq; simpl.
    unfold mk_nat_k1.

    match goal with
      | [ |- context[lt_Ltb ?a] ] => remember (lt_Ltb a) as l2
    end; clear Heql2.

    pose proof (Ltb_proof_irrelevance l1 l2) as xx; subst; auto.
  }

  pose proof (bar s) as b.
  exrepnd.
  inversion b0 as [b]; clear b0.
  apply imp in b.

  induction n; allsimpl.

  { unfold m_seq2pseq in b; allsimpl.
    rw <- emkseq_eq in b; auto. }

  pose proof (e (S n)) as q1.
  rw q1 in b.
  pose proof (e n) as q2.
  rw q2 in IHn.
  clear q1 q2 e.
  subst.
  allsimpl.
  remember (alpha A h f ind n) as an.
  unfold kseqNA in an; exrepnd; allsimpl.

  assert (kseqS2kseq (S n) (extend1 (S n) s (f (mk_pseqna (mk_pseq s) an1))) = s) as ee.
  { apply functional_extensionality_dep; introv.
    destruct x.
    unfold kseqS2kseq; simpl.
    dup l as ltx.
    apply Ltb_lt in ltx.
    destruct (lt_dec x (S n)); try omega.
    unfold mk_nat_k1, mk_nat_k.

    match goal with
      | [ |- context[lt_Ltb ?a] ] => remember (lt_Ltb a) as l2
    end; clear Heql2.

    pose proof (Ltb_proof_irrelevance l l2) as xx; subst; auto.
  }

  rw ee in b; auto.
Qed.