(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import Int63.

Require Import List.

Section Trace.

  Definition trace (step:Type) := ((list step) * step)%type.

  Definition trace_to_list {step:Type} (t:trace step) : list step :=
    let (t, _) := t in t.

  Definition trace_length {step:Type} (t:trace step) : int :=
    let (t,_) := t in
    List.fold_left (fun i _ => (i+1)%int) t 0%int.

  Fixpoint trace_get_aux {step:Type} (t:list step) (def:step) (i:int) : step :=
    match t with
    | nil => def
    | s::ss =>
      if (i == 0)%int then
        s
      else
        trace_get_aux ss def (i-1)
    end.
  Definition trace_get {step:Type} (t:trace step) : int -> step :=
    let (t,def) := t in trace_get_aux t def.

  Definition trace_fold {state step:Type} (transition: state -> step -> state) (s0:state) (t:trace step) :=
    let (t,_) := t in
    List.fold_left transition t s0.

  Lemma trace_fold_ind (state step : Type) (P : state -> Prop) (transition : state -> step -> state) (t : trace step)
      (IH: forall (s0 : state) (i : int), (i < trace_length t)%int = true -> P s0 -> P (transition s0 (trace_get t i))) :
      forall s0 : state, P s0 -> P (trace_fold transition s0 t).
  Admitted.

End Trace.

Require Import PeanoNat.

Definition nat_eqb := Nat.eqb.
Definition nat_eqb_eq := Nat.eqb_eq.
Definition nat_eqb_refl := Nat.eqb_refl.

(*
   Local Variables:
   coq-load-path: ((rec "../.." "SMTCoq"))
   End:
*)


Ltac find_if :=
  match goal with
    | [ |- if ?X then _ else _ ] => destruct X
  end.

Theorem duh : forall (a b c : bool),
  if a
    then if b
      then True
      else True
    else if c
      then True
      else True.
  intros.
  repeat find_if; constructor.
Qed.

Ltac find_if_inside :=
  match goal with
    | [ |- context[if ?X then _ else _] ] => destruct X
  end.

Theorem duh2 : forall (a b : bool),
  (if a then 42 else 42) = (if b then 42 else 42).
  intros.
  repeat find_if_inside; reflexivity.
Qed.

Ltac my_tauto :=
  repeat match goal with
	   | [ H : ?P |- ?P ] => exact H

	   | [ |- True ] => constructor
	   | [ |- _ /\ _ ] => constructor
	   | [ |- _ -> _ ] => intro

	   | [ H : False |- _ ] => destruct H
	   | [ H : _ /\ _ |- _ ] => destruct H
	   | [ H : _ \/ _ |- _ ] => destruct H

	   | [ H1 : ?P -> ?Q, H2 : ?P |- _ ] =>
	     let H := fresh "H" in
	       (generalize (H1 H2); clear H1; intro H)
	 end.

Section propositional.
  Variables P Q R : Prop.

  Theorem and_comm : (P \/ Q) /\ (P -> Q) -> Q.
    my_tauto.
  Qed.
End propositional.

Ltac use H e :=
  match type of e with
    | ?A -> ?B =>
      let H' := fresh "H'" in
	(assert (H' : A);
	  [idtac
	    | assert (H : B);
	      [exact (e H')
		| clear H']])
  end.

Section use.
  Variable T : Set.
  Variable e : T.

  Variables A B : T -> Prop.
  Hypothesis Ae : A e.
  Variable G : Prop.
  Variable BeG : B e -> G.

  Theorem thm : (forall x, A x -> B x) -> G.
    intros.
    use H' (H e).
    exact Ae.
    apply BeG; exact H'.
  Qed.
End use.

Ltac autoUse :=
  repeat match goal with
	   | [ H : ?A -> ?B |- _ ] =>
	     let H' := fresh "H'" with H'' := fresh "H''" in
	       (assert (H' : A);
		 [clear H; auto; fail
		   | assert (H'' : B);
		     [exact (H H')
		       | clear H H'; auto]])
	 end.

Section autoUse.
  Variables a b c : nat.

  Hypothesis H1 : a = a -> b = c.
  Hypothesis H2 : c = b -> c = a.

  Theorem thm2 : a = c.
    autoUse.
  Qed.
End autoUse.

Ltac crazyRewriter limit :=
  match limit with
    | O => auto
    | S ?limit' =>
      try match goal with
	    | [ H : forall _, _ = _ |- context[?E] ] =>
	      rewrite (H E); auto; crazyRewriter limit'; fail
	  end
  end.

Section crazyRewriter.
  Variable A : Set.
  Variable e : A.
  Variable f : A -> A.
  Variable g : A -> A -> A.

  Hypothesis f_inverse : forall x, x = f (f x).
  Hypothesis g_e : forall x, f (f (f x)) = g e x.

  Theorem t : f e = g e e.
    crazyRewriter 1.
  Qed.

  Hint Extern 2 (_ = _) => crazyRewriter 1.

  Theorem t' : 0 < 1 /\ f e = g e e.
    intuition.
  Qed.
End crazyRewriter.


Require Import Bedrock.Platform.AutoSep.

Definition spec1 := SPEC reserving 0
  PRE[_] Emp
  POST[_] Emp.

Definition spec2 := SPEC reserving 1
  PRE[_] Emp
  POST[_] Emp.

Definition m1 := bmodule "1" {{
  bfunction "f"() [spec1]
    Return 0
  end
}}.

Definition m2 := bimport [[ "1"!"f" @ [spec1] ]]
  bmodule "2" {{
    bfunction "g"() [spec2]
      Call "1"!"f"()
      [PRE[_] Emp
       POST[_] Emp];;
      Return 0
    end
  }}.

Theorem ok1 : moduleOk m1.
  vcgen; sep_auto.
Qed.

Theorem ok2 : moduleOk m2.
  vcgen; sep_auto; words.
Qed.

Definition m := link m1 m2.

Theorem ok : moduleOk m.
  link ok1 ok2.
Qed.


From cgraphs.sessiontypes Require Import invariant progress.

Theorem safety (e : expr) (es : list expr) (h : heap) :
  typed ∅ e UnitT ->
  steps [e] ∅ es h ->
    (h = ∅ ∧ ∀ e, e ∈ es -> e = Val UnitV) ∨
    (∃ es' h', step es h es' h').
Proof.
  intros Htyped Hsteps.
  by eapply global_progress, invariant_holds.
Qed.

(*
  The following command can be used to verify that everything has been formally
  proved. It should print "classic : ∀ P : Prop, P ∨ ¬ P" as the only axiom.
  This indicates that our proof relies on classical logic.
  (we use classical logic for convenience.)
*)
(* Print Assumptions safety. *)


From Coq Require Import Classes.RelationClasses Lists.List Program.Equality Setoid ssreflect Strings.String.
From mathcomp Require Import bigop choice eqtype seq ssrbool ssrfun ssrnat.
From deriving Require Import deriving.
From extructures Require Import fmap fset ord.
From AlphaPearl Require Import Alpha AlphaImpl Util.

Set Asymmetric Patterns.
Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".
Unset Printing Implicit Defensive.

#[local] Open Scope fset_scope.
#[local] Open Scope string_scope.

Import AlphaString.
Import AlphaStringFacts.

(** Notation inspired by _PLFA_ (https://plfa.github.io/Lambda). *)
#[local] Notation "'`' x" := (variable x) (at level 0).

#[local] Notation "'λ' x y" := (abstraction x y) (at level 200, x at level 0).

#[local] Infix "⋅" := application (at level 40).

#[local] Notation a := "a".
#[local] Notation x := "x".
#[local] Notation y := "y".
#[local] Notation z := "z".

Example examples :
  `x ≢_α `y /\
  (λ x `x) ≡_α (λ y `y) /\
  (λ x λ y `x⋅(`x⋅`y)) ≡_α (λ y λ x `y⋅(`y⋅`x)) /\
  (λ x `x) ≢_α (λ x `x⋅`y) /\
  (λ x `x⋅`y) ≡_α (λ a `a⋅`y) /\
  (λ x `x⋅`y) ≢_α (λ x `x⋅`z) /\
  (λ x λ y `y⋅`x) ≢_α (λ x λ y `x⋅`y) /\
  (λ x λ x `x) ≡_α (λ y λ x `x).
Proof.
  unfold α_equivalent.
  repeat split; try apply negbT, Bool.not_true_iff_false; intros_all;
  try apply α_equivalent_iff_α_equivalent'_free_variables;
  simpl in *.
  - apply (rwP getmP). rewrite updateE //.
  - repeat rewrite <- (rwP andP). repeat split;
    apply (rwP getmP); repeat rewrite updateE //=.
  - repeat rewrite <- (rwP andP). repeat split;
    apply (rwP getmP); repeat rewrite updateE //=.
    rewrite identityE !in_fsetD !in_fsetU //.
  - apply (rwP andP) in H as [].
    apply (rwP getmP) in H0.
    rewrite updateE identityE !in_fsetD !in_fsetU // in H0.
  - apply (rwP andP) in H as [].
    apply (rwP getmP) in H0.
    repeat rewrite updateE // in H0.
  - apply (rwP getmP). rewrite updateE //.
Qed.


Require Import AST.
Require Import Coqlib.

Require Import extspec.
Require Import semantics.
Require Import semantics_lemmas.

Section safety.
  Context {G C M D Z:Type}.
  Context (Hcore:CoreSemantics G C M).
  Variable (Hspec:external_specification M external_function Z).

  Variable ge : G.

  Fixpoint safeN (n:nat) (z:Z) (c:C) (m:M) : Prop :=
    match n with
    | O => True
    | S n' =>
       match at_external Hcore c, halted Hcore c with
       | None, None =>
           exists c', exists m',
             corestep Hcore ge c m c' m' /\
             safeN n' z c' m'
       | Some (e,sig,args), None =>
           exists x:ext_spec_type Hspec e,
             ext_spec_pre Hspec e x (sig_args sig) args z m /\
             (forall ret m' z',
               ext_spec_post Hspec e x (sig_res sig) ret z' m' ->
               exists c',
                 after_external Hcore ret c = Some c' /\
                 safeN n' z' c' m')
       | None, Some i => ext_spec_exit Hspec (Some i) z m
       | Some _, Some _ => False
       end
    end.

  Definition corestep_fun  :=
       forall ge m q m1 q1 m2 q2 ,
       corestep Hcore ge q m q1 m1 ->
       corestep Hcore ge q m q2 m2 ->
       (q1, m1) = (q2, m2).

  Lemma safe_corestep_forward:
     corestep_fun ->
    forall c m c' m' n z,
    corestep Hcore ge c m c' m' -> safeN (S n) z c m -> safeN n z c' m'.
  Proof.
    simpl; intros.
    erewrite corestep_not_at_external in H1; eauto.
    erewrite corestep_not_halted in H1; eauto.
    destruct H1 as [c'' [m'' [? ?]]].
    assert ((c',m') = (c'',m'')).
    eapply H; eauto.
   inv H3; auto.
  Qed.

  Lemma safe_corestep_backward:
    forall c m c' m' n z,
    corestep Hcore ge c m c' m' -> safeN n z c' m' -> safeN (S n) z c m.
  Proof.
    simpl; intros.
    erewrite corestep_not_at_external; eauto.
    erewrite corestep_not_halted; eauto.
  Qed.

  Lemma safe_downward1 :
    forall n c m z,
      safeN (S n) z c m -> safeN n z c m.
  Proof.
    induction n; simpl; intros; auto.
    destruct (at_external Hcore c);
      destruct (halted Hcore c).
    destruct p; auto.
    destruct p. destruct p.
    destruct H as [x ?].
    exists x.
    destruct H. split; auto.
    intros. specialize (H0 ret m' z' H1).
    destruct H0 as [c' [? ?]].
    exists c'; split; auto.
    auto.
    destruct H as [c' [m' [? ?]]].
    exists c'. exists m'; split; auto.
  Qed.

  Lemma safe_downward :
    forall n n' c m z,
      le n' n ->
      safeN n z c m -> safeN n' z c m.
  Proof.
    do 6 intro. revert c m z. induction H; auto.
    intros. apply IHle. apply safe_downward1. auto.
  Qed.

  Lemma safe_corestepN_forward:
    corestep_fun ->
    forall z c m c' m' n n0,
      corestepN Hcore ge n0 c m c' m' ->
      safeN (n + S n0) z c m ->
      safeN n z c' m'.
  Proof.
    intros.
    revert c m c' m' n H0 H1.
    induction n0; intros; auto.
    simpl in H0; inv H0.
    eapply safe_downward in H1; eauto. omega.
    simpl in H0. destruct H0 as [c2 [m2 [STEP STEPN]]].
    apply (IHn0 _ _ _ _ n STEPN).
    assert (Heq: (n + S (S n0) = S (n + S n0))%nat) by omega.
    rewrite Heq in H1.
    eapply safe_corestep_forward in H1; eauto.
  Qed.

  Lemma safe_step'_back2 :
    forall
      {ora st m st' m' n},
      corestep Hcore ge st m st' m' ->
      safeN (n-1) ora st' m' ->
      safeN n ora st m.
  Proof.
    intros.
    destruct n.
    hnf. auto.
    simpl in H0.
    replace (n-0)%nat with n in H0.
    eapply safe_corestep_backward; eauto.
    omega.
  Qed.

  Lemma safe_corestepN_backward:
    forall z c m c' m' n n0,
      corestepN Hcore ge n0 c m c' m' ->
      safeN (n - n0) z c' m' ->
      safeN n z c m.
  Proof.
    simpl; intros.
    revert c m c' m' n H H0.
    induction n0; intros; auto.
    simpl in H; inv H.
    solve[assert (Heq: (n = n - 0)%nat) by omega; rewrite Heq; auto].
    simpl in H. destruct H as [c2 [m2 [STEP STEPN]]].
    assert (H: safeN (n - 1 - n0) z c' m').
    eapply safe_downward in H0; eauto. omega.
    specialize (IHn0 _ _ _ _ (n - 1)%nat STEPN H).
    solve[eapply safe_step'_back2; eauto].
  Qed.

  Lemma convergent_controls_safe :
    forall m q1 q2,
      (at_external Hcore q1 = at_external Hcore q2) ->
      (forall ret q', after_external Hcore ret q1 = Some q' ->
                      after_external Hcore ret q2 = Some q') ->
      (halted Hcore q1 = halted Hcore q2) ->
      (forall q' m', corestep Hcore ge q1 m q' m' -> corestep Hcore ge q2 m q' m') ->
      (forall n z, safeN n z q1 m -> safeN n z q2 m).
  Proof.
    intros. destruct n; simpl in *; auto.
    rewrite H in H3. rewrite H1 in H3.
    destruct (at_external Hcore q2);
      destruct (halted Hcore q2); auto.
    destruct p. destruct p.
    destruct H3 as [x ?].
    exists x.
    destruct H3; split; auto.
    intros. specialize (H4 ret m' z' H5).
    destruct H4 as [c' [? ?]].
    exists c'; split; auto.
    destruct H3 as [c' [m' [? ?]]].
    exists c'. exists m'; split; auto.
  Qed.

  Lemma wlog_safeN_gt0 : forall
    n z q m,
    (lt 0 n -> safeN n z q m) ->
    safeN n z q m.
  Proof.
    intros. destruct n.
    hnf. auto.
    apply H. omega.
  Qed.

End safety.


Require Export CatSem.CAT.rmonad.
Require Export CatSem.CAT.rmodule_TYPE.
Require Export CatSem.TLC.TLC_semantics.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Program Instance TLCBs : RMonad_struct (IDelta TY) BETA := {
  rweta c := SM_ind (var (V:=c)) ;
  rkleisli := subst
}.

Canonical Structure TLCB := Build_RMonad TLCBs.

Lemma shift_shift r V t (y : opt r V t) W
  (f : ipo_mor (sm_ipo (T:=TY) V) (BETA W)):
     sshift_ (P:=TLCB) (W:=W) f y = y >- f.
Proof.
  intros r v t y.
  destruct y as [t y | ];
  simpl;
  intros;
  fin.
Qed.

Section app_po.

Variables r s : TLCtypes.

Obligation Tactic := idtac.

Program Instance app_po_mors c : PO_mor_struct
  (a := PO_product (ipo_proj (BETA c) (r ~> s))  (ipo_proj (BETA c) r))
  (b := ipo_proj (BETA c) s)
  (fun z => app (fst z) (snd z)).
Next Obligation.
Proof.
  intros c.
  unfold Proper;
  red.
  intros x y H.
  destruct H.
  simpl in *.
  transitivity (app v' w).
    apply cp_App1; auto.
    apply cp_App2; auto.
Qed.

Definition app_po_mor c := Build_PO_mor (app_po_mors c).

Obligation Tactic := fin.

Program Instance tlc_app_s  : RModule_Hom_struct
  (M:=product ((FIB_RMOD TLCB (r ~> s)) TLCB)
              ((FIB_RMOD TLCB r) TLCB))
  (N:=FIB_RMOD TLCB s TLCB) (app_po_mor).

Definition tlc_app := Build_RModule_Hom tlc_app_s.

End app_po.

Section abs_po.

Variables r s : TLCtypes.

Obligation Tactic := unfold Proper; red;
        simpl; intros; apply cp_Lam; auto.

Program Instance abs_po_mors c : PO_mor_struct
  (a := (ipo_proj (BETA (c * r)) s))
  (b := ipo_proj (BETA c) (r ~> s)) (@abs _ _ _ ).

Definition abs_po_mor c := Build_PO_mor (abs_po_mors c).

Obligation Tactic := idtac.

Program Instance tlc_abs_s : RModule_Hom_struct
 (M:=(FIB_RMOD TLCB s) ((DER_RMOD _ TLCB r) TLCB))
 (N:=(FIB_RMOD TLCB (r ~> s)) TLCB) abs_po_mor.
Next Obligation.
Proof.
  fin.
  apply f_equal.
  apply subst_eq.
  intros.
  apply (shift_shift y f ).
Qed.

Definition tlc_abs := Build_RModule_Hom tlc_abs_s.

End abs_po.


(** * Libwp.v : Partial correctness *)
Require Export Carac.
Set Implicit Arguments.

Module Liberal (Univ:Universe).
Import Univ.

Module CP := (CaracFun Univ).
Import CP.
Import CP.RP.
Import CP.RP.PP.
Import CP.RP.PP.MP.
Import CP.RP.PP.MP.UP.

Section LibDefProp.
Variable A : Type.

(** ** Definition and basic properties *)

Definition lib (m:distr A) : M A := fun f => [1-] (mu m (finv f)).

Lemma le_mu_lib : forall m f, mu m f <= lib m f.
unfold lib; intros.
apply Ule_trans with (mu m (finv (finv f))).
apply mu_monotonic; unfold finv; auto.
apply mu_stable_inv; auto.
Qed.

Lemma lib_one : forall m, 1 <= lib m (f_one A).
unfold lib; intros.
apply Ule_trans with ([1-] mu m (f_zero A)).
rewrite mu_zero; auto.
apply Uinv_le_compat; apply mu_monotonic; unfold finv,f_one,f_zero; auto.
Qed.

Lemma lib_inv : forall m f,  lib m (finv f) == [1-]mu m f.
unfold lib; intros.
Usimpl.
apply (mu_stable_eq m); unfold finv; auto.
Qed.

Lemma lib_monotonic : forall m, monotonic (lib m).
red; unfold lib; intros; Usimpl.
apply (mu_monotonic m).
unfold fle,finv; auto.
Qed.

Hint Resolve lib_one lib_inv lib_monotonic le_mu_lib.

Lemma lib_stable_eq : forall m, stable_eq (lib m).
auto.
Qed.
Hint Resolve lib_stable_eq.

Lemma mu_lib_le_esp : forall m f g, lib m f & mu m g <= mu m (fesp f g).
unfold lib; intros.
rewrite Uesp_sym.
apply Uplus_inv_le_esp; Usimpl.
apply Ule_trans with (mu m (fplus (fesp f g) (finv f))); auto.
apply (mu_monotonic m); unfold fplus, fle, fesp,finv; intros; auto.
rewrite Uesp_sym; auto.
Qed.
Hint Resolve mu_lib_le_esp.

Lemma le_lib_mu : forall m f, lib m f & mu m (f_one A) <= mu m f.
intros; apply Ule_trans with (mu m (fesp f (f_one A))); auto.
apply (mu_monotonic m); unfold fle,fesp,f_one; auto.
Qed.
Hint Resolve le_lib_mu.

Lemma lib_le_esp : forall m f g, lib m f & lib m g <= lib m (fesp f g).
intros; unfold lib.
rewrite <- Uinv_plus_esp; Usimpl.
apply Ule_trans with (mu m (fplus (finv f) (finv g))); auto.
apply (mu_monotonic m); unfold fle,fesp,finv; auto.
Qed.
Hint Resolve lib_le_esp.

Lemma lib_plus_left : forall m f g, fplusok f g -> lib m (fplus f g) == lib m f + mu m g.
intros; unfold lib.
setoid_replace (mu m (finv f)) with (mu m (finv (fplus f g)) + mu m g).
rewrite Uinv_plus_right; auto.
apply Ule_trans with ([1-]mu m (finv g)); try Usimpl; auto.
apply mu_monotonic; auto.
apply Ueq_trans with (mu m (fplus (finv (fplus f g)) g)).
apply mu_stable_eq; unfold fplusok,fle,finv in H;
unfold feq,fplus,finv; intros.
rewrite Uinv_plus_right; auto.
apply (mu_stable_plus m); auto.
Qed.

Lemma lib_plus_right : forall m f g, fplusok f g -> lib m (fplus f g) == mu m f + lib m g.
intros; apply Ueq_trans with (lib m (fplus g f)).
apply lib_stable_eq.
red; unfold fplus; auto.
apply Ueq_trans with (lib m g + mu m f); auto.
apply lib_plus_left; auto.
Qed.

Definition okl (p : U) (m : distr A) (q : A -> U) := p <= lib m q.

End LibDefProp.
Hint Resolve lib_one lib_inv lib_monotonic le_mu_lib lib_stable_eq
                    mu_lib_le_esp le_lib_mu lib_le_esp lib_plus_left lib_plus_right.

(** ** Rules for liberal constructions of programs *)
Section Programs.
Variables A B: Type.

Lemma lib_unit : forall (x:A) (p : A -> U), lib (Munit x) p == p x.
intros; compute; auto.
Qed.

Lemma lib_let : forall (m : distr A) (M : A -> distr B) (p : B -> U),
        lib (Mlet m M) p == lib m (fun x => lib (M x) p).
intros; compute; Usimpl.
destruct m.
apply (monotonic_stable_eq mu_monotonic0); auto.
Qed.

Lemma lib_if : forall (mb:distr bool) (m1 m2 : distr A) (p : A -> U),
        lib (Mif mb m1 m2) p == lib mb (fun b => if b then lib m1 p else lib m2 p).
intros; compute; Usimpl.
destruct mb.
apply (monotonic_stable_eq mu_monotonic0).
red; destruct x; auto.
Qed.

(** *** Rules for liberal fixpoints
with $\phi(x)=F(\phi)(x)$,

$\bfrac{\forall f, (\forall x, \okl{p(x)}{f}{q}) \Ra \forall x, \okl{p(x)}{F(f)(x)}{q}}%
     {\forall x, \okl{p~x}{\phi(x)}{q}}$
*)
Section Fixrules.

Definition oklfun (p : A->U) (m : A->distr B) (q : A -> B-> U) :=
     forall x, p x <= lib (m x) (q x).

Definition uplfun (p : A->U) (m : A->distr B) (q : A -> B-> U) :=
     forall x, lib (m x) (q x) <= p x.

Variable F : (A -> distr B) -> A -> distr B.

Hypothesis F_mon : forall f g : A -> (distr B),
  (forall x, le_distr (f x) (g x)) -> forall x, le_distr (F f x) (F g x).

Lemma libfixrule :
   forall p q,
   (forall (f:A->distr B), oklfun p f q -> oklfun p (fun x => F f x) q)
   -> oklfun p (Mfix F F_mon) q.
unfold oklfun,lib; intros.
apply Uinv_le_perm_right.
unfold Mfix; simpl; unfold mu_lub_.
apply lub_le.
intro n; generalize x; induction n; simpl; auto.
Qed.

Section UplibFixRule.
Variable p : A -> nat -> U.
Hypothesis p1 : forall x, p x O == 1.
Variable q : A -> B -> U.

Lemma up_libfixrule :
   (forall (i:nat)(f:A->distr B), uplfun (fun x => p x i) f q
                                        -> uplfun (fun x => p x (S i)) (fun x => F f x) q)
   -> uplfun (fun x => glb (p x)) (Mfix F F_mon) q.
red; intros.
assert (forall n:nat,
        (uplfun (fun x => (p x n))
        (fun x => (iter F n x)) q)).
induction n; simpl; auto.
repeat red; intros; auto.
rewrite p1; auto.
unfold lib, glb; Usimpl.
apply lub_le; auto.
intro n; apply Ule_trans with (mu (iter F n x) (finv (q x))).
unfold uplfun, lib in H0.
apply Uinv_le_perm_left.
apply (H0 n).
apply Mfix_le_iter; auto.
Qed.

End UplibFixRule.

(** ** Case the post-expectation is transformed in a functorial way *)

(** *** Invariant rules *)

Section Fix_nuF.

Variable nuF :  (A -> U) -> A -> U.

Hypothesis nuF_mon : Fmonotonic nuF.

Variable q : A -> B -> U.

Lemma nuF_stable : Fstable nuF.
auto.
Qed.

Hypothesis F_nuF_eq :
    forall f x, lib (F f x) (q x) == nuF (fun y => lib (f y) (q y)) x.

Lemma nufix_lib : forall x, nufix nuF x == lib (Mfix F F_mon x) (q x).
intros; unfold nufix, lib.
unfold glb; Usimpl.
unfold Mfix; simpl.
unfold mu_lub_.
apply lub_eq_stable; intros.
generalize x; induction n; simpl; intros; auto.
apply Uinv_eq_perm_left.
rewrite (F_nuF_eq (iter F n) x0).
apply nuF_stable.
repeat red; unfold lib; auto.
Qed.
Hint Resolve nufix_lib.

Lemma nuF_le : forall f, fle f (nuF f)
        -> forall x, f x <= lib (Mfix F F_mon x) (q x).
intros; apply Ule_trans with (nufix nuF x); auto.
apply nufix_inv; auto.
Qed.

Lemma nuF_muF_le : forall f, fle f (nuF f)
     -> forall x, f x & pterm F F_mon x <= mu (Mfix F F_mon x) (q x).
intros; apply Ule_trans with (lib (Mfix F F_mon x) (q x) & pterm F F_mon x).
apply Uesp_le_compat;auto.
apply  nuF_le; auto.
apply Ule_trans with (mu (Mfix F F_mon x) (fesp (q x) (f_one B))).
unfold pterm; auto.
apply mu_monotonic; auto.
Qed.
Hint Resolve nuF_muF_le.

Lemma muF_pterm_le :
          forall f, fle (fplus f (finv (pterm F F_mon))) (nuF (fplus f (finv (pterm F F_mon))))
     -> fle f (pterm F F_mon) -> forall x, f x <= mu (Mfix F F_mon x) (q x).
intros; apply Ule_trans with ((f x + [1-](pterm F F_mon x)) & pterm F F_mon x).
rewrite (Uplus_inv_esp_simpl); auto.
apply nuF_muF_le with (f:= fun x => f x + [1-] pterm F F_mon x); auto.
Qed.

End Fix_nuF.

(** *** Case nuF is parametric in q *)
Variable nuF : (A->B->U) -> (A -> U) -> A -> U.
Hypothesis nuF_mon : forall q, Fmonotonic (nuF q).

Hypothesis nuF_q_monotonic :
    forall q1 q2 f, (forall x y, q1 x y <= q2 x y) -> fle (nuF q1 f)  (nuF q2 f).

Lemma nuF_q_eq_stable :
    forall q1 q2 f, (forall x y, q1 x y == q2 x y) -> feq (nuF q1 f) (nuF q2 f).
auto.
Qed.

Variable muF : (A->B->U) -> (A -> U) -> A -> U.

Hypothesis muF_mon : forall q, Fmonotonic (muF q).

Hypothesis nuF_plus : forall q1 q2 f1 f2,
     feq (nuF (fun x y => q1 x y + q2 x y)  (fplus f1 f2)) (fplus (muF q1 f1) (nuF q2 f2)).

Hypothesis nuF_mult : forall a q f,
           feq (nuF  (fun x y => a * (q x y)) (fmult a f)) (fmult a (nuF q f)).

Hypothesis nuF_inv : forall q f,
           feq (nuF  (fun x y => [1-](q x y)) (finv f)) (finv (muF q f)).

Hypothesis muF_mult : forall a q f,
           feq (muF  (fun x y => a * (q x y)) (fmult a f)) (fmult a (muF q f)).

Hypothesis muF_q_monotonic :
    forall q1 q2 f, (forall x y, q1 x y <= q2 x y) -> fle (muF q1 f) (muF q2 f).

Hypothesis F_muF_eq_one :
    forall f x, (forall y, le_distr (f y) (Mfix F F_mon y)) -> mu (F f x) (f_one B) == muF (fun (x:A) => f_one B) (fun y => mu (f y) (f_one B)) x.

Hypothesis F_nuF_eq_one :
    forall f x, (forall y, le_distr (f y) (Mfix F F_mon y)) -> lib (F f x) (f_one B) == nuF (fun (x:A) => f_one B) (fun y => lib (f y) (f_one B)) x.

Hypothesis muF_cont :  Fcontlub (muF (fun (x:A) => f_one B)).

Section InvariantTerm.

Variable q : A -> B -> U.

Hypothesis F_nuF_eq :
    forall f x, lib (F f x) (q x) == nuF q (fun y => lib (f y) (q y)) x.

Lemma muF_pterm_le_inv :
          forall f, fle f (muF q f)
          -> fle f (pterm F F_mon) -> forall x, f x <= mu (Mfix F F_mon x) (q x).
intros; apply (muF_pterm_le (nuF:=nuF q)); intros; auto.
rewrite (nuF_q_eq_stable q (fun (x: A) (y: B) => q x y + 0)); auto.
rewrite (nuF_plus q (fun x y => 0)).
apply fplus_fle_compat; auto.
rewrite (nuF_q_eq_stable (fun (x: A) (y: B) => 0) (fun (x: A) (y: B) => [1-]1)); auto.
rewrite (nuF_inv (fun (x:A)(y:B)=>1) (pterm F F_mon)).
apply finv_fle_compat.
apply feq_fle_sym.
apply (muF_pterm  (muF_mon (fun (x:A) => f_one B)) F_muF_eq_one muF_cont); auto.
Qed.

End InvariantTerm.

Lemma muF_pterm_le_mult :
          forall a f,  fle f (muF (fun (x:A) (y:B) => 1) f) ->
          (forall f x, lib (F f x) (fun _: B => a * 1) ==
                         nuF (fun (x:A) (y:B) => a * 1) (fun y => lib (f y) (fun _: B => a * 1)) x)
          -> ~ 0==a -> fle (fmult a f) (pterm F F_mon) -> fle f (pterm F F_mon).
red; intros a f H nuF_eq_a H0 H1 x; apply Umult_le_simpl_left with a; trivial.
unfold pterm; rewrite <- (mu_stable_mult (Mfix F F_mon x) a (f_one B)).
apply muF_pterm_le_inv with (q:=fun (x:A) (y:B) => a * 1) (f:=fmult a f) (x:=x); intros;auto.
rewrite (muF_mult a (fun (x:A) (y:B) => 1) f); auto.
Qed.

Lemma muF_pterm_le_inv_mult :
          forall q a f, fle f (muF q f) ->
          (forall f x, lib (F f x) (q x) == nuF q (fun y => lib (f y) (q y)) x) ->
          (forall f x, lib (F f x) (fun _: B => a * 1) ==
                         nuF (fun (x:A) (y:B) => a * 1) (fun y => lib (f y) (fun _: B => a * 1)) x) ->
          ~ 0==a ->
          fle (fmult a f) (pterm F F_mon) -> forall x, f x <= mu (Mfix F F_mon x) (q x).
intros; apply muF_pterm_le_inv; auto.
apply muF_pterm_le_mult with (a:=a); auto.
apply fle_trans with (muF q f); auto.
Qed.

(** ** Termination *)
Section Termination.

Variable next : A -> Ndistr A.

Definition Facc (t:A->U) := fun (x:A) => nu (next x) t.

Lemma Facc_monotonic : Fmonotonic Facc.
repeat red; unfold Facc; intros.
apply (nu_monotonic (next x)); auto.
Qed.
Hint Resolve Facc_monotonic.

Lemma Facc_continuous : Fcontlub Facc.
repeat red; unfold Facc; intros.
apply (nu_continuous (next x) (fn:=fn)); auto.
Qed.
Hint Resolve Facc_continuous.

Definition acc := mufix Facc.

Lemma acc_sup : forall x, nu (next x) acc  <= acc x.
intros; change (Facc acc x <= acc x).
unfold acc; apply mufix_sup; auto.
Qed.

Lemma prob_acc : forall f : A -> U,
        (forall x, nu (next x) f <= f x) -> fle acc f.
intros f H; unfold acc.
apply mufix_inv; auto.
Qed.

Lemma distr_acc : forall (f : A -> distr B) (q:A -> B -> U),
  okfun (fun x => nu (next x)  (fun y => mu (f y) (q y))) f q -> okfun acc f q.
unfold okfun,ok; intros.
apply prob_acc with (f:= fun y : A => mu (f y) (q y)); auto.
Qed.

(** ** Results on termination *)
Section Wfterm.

Variable R : A -> A -> Prop.
Hypothesis term_next : forall x, 1<= nu (next x) (f_one A).

(** *** First result *)
(** The distribution (next x) always gives values such that (R x y) **)
Section Result1.
Hypothesis support_next :
   forall x f g, (forall y, R y x -> f y <= g y) -> nu (next x) f <= nu (next x) g.

Lemma acc_next_term : forall x,  Acc R x -> 1 <= acc x.
induction 1; intros.
apply Ule_trans with (nu (next x) acc).
apply Ule_trans with (1:= term_next x); auto.
apply acc_sup; auto.
Qed.

Lemma wf_next_term : (well_founded R) -> forall x, 1 <= acc x.
intros; apply acc_next_term; auto.
Qed.
End Result1.

(** *** Second result *)
(** The probability (next x) gives values such that (R x y) is greater than 1 **)

Hypothesis Rdec : forall x, dec (fun y => R y x).
Lemma acc_almost_term :
   forall x, Acc R x -> (forall x, 1 <= nu (next x) (carac (Rdec x))) -> 1 <= acc x.
intros; apply acc_next_term; intros; auto.
setoid_replace (nu (next x0) f) with (nu (next x0) (fesp (carac (Rdec x0)) f)).
setoid_replace (nu (next x0) g) with (nu (next x0) (fesp (carac (Rdec x0)) g)).
apply (nu_monotonic (next x0)); red; auto.
unfold fesp; intros; apply carac_esp_fun_le; auto.
apply (Ndistr_eq_esp (next x0)); auto.
apply (Ndistr_eq_esp (next x0)); auto.
Qed.

Lemma wf_almost_term :
   (well_founded R) -> (forall x, 1 <= nu (next x) (carac (Rdec x))) -> forall x, 1 <= acc x.
intros; apply acc_almost_term; auto.
Qed.

End Wfterm.
End Termination.

End Fixrules.
End Programs.
Hint Resolve lib_unit lib_let lib_if.

End Liberal.


Require Import Program.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Require Import Monad.
Require Import Category.
Require Import Functor.
Require Import Isomorphism.

Set Universe Polymorphism.

Instance KleisliCategory T `{Monad T} : Category := {|
  object := Type;
  morphism A B := A -> T B;
  id A := ret;
  composition A B C f g a := bind (f a) g
|}.
Proof.
  - intros.
    extensionality a.
    apply left_identity.
  - intros.
    extensionality a.
    apply right_identity.
  - intros.
    extensionality a.
    apply associativity.
Defined.

Instance maybeCat : Category := {|
  object := Type;
  morphism A B := A -> option B;
  id A := Some;
  composition A B C f g a := match f a with None => None | Some b => g b end
|}.
Proof.
  - intros.
    reflexivity.
  - intros.
    extensionality a.
    case (f a); reflexivity.
  - intros.
    extensionality a.
    case (f a); reflexivity.
Defined.

Example composeMaybe0 {A} : Some ∘ Some ∘ Some = Some   :> (A -> option A).
  compute; reflexivity.
Defined.

Example composeMaybe1 {A} : Some ∘ const None ∘ Some = const None   :> (A -> option A).
  compute; reflexivity.
Defined.

Example composeMaybe2 {A} : Some ∘ id ∘ id = Some   :> (A -> option A).
  compute; reflexivity.
Defined.

Example composeMaybe3 : Some ∘ const (id 5) ∘ id = const (id 5)   :> (nat -> option nat).
  compute; reflexivity.
Defined.

Example composeMaybe4 : const (id 5) ∘ const (id 4) = const (id 4)   :> (nat -> option nat).
  compute; reflexivity.
Defined.

Instance maybeCatKleisliIso : @Isomorphism Cat maybeCat (KleisliCategory option) := {|
  f := _;
  g := _
|}.
Proof.
  - refine {| fobj o := _; fmap a b f := _ |}.
    + exact o.
    + exact f.
    + reflexivity.
    + reflexivity.
  - refine {| fobj o := _; fmap a b f := _ |}.
    + exact o.
    + exact f.
    + reflexivity.
    + reflexivity.
  - compute.
    reflexivity.
  - compute.
    reflexivity.
Defined.


(******************************************************************************)
(** * Helper lemmas for proving prefix-finiteness                             *)
(** * of model-specific "hb" relations.                                       *)
(******************************************************************************)

From hahn Require Import Hahn.
Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import ImmFair.
Require Import FairExecution.
Require Import FinThreads.
Require Import Lia.
Require Import ClassicalChoice.
Require Import ChoiceFacts.
Require Import IndefiniteDescription.
Require Import AuxRel2.
Require Import AuxDef.
Require Import Program.Basics.
Import ListNotations.
Require Import EnumProperties.

Set Implicit Arguments.

Section HardwareFairness.

Variable G : execution.

Notation "'E'" := (acts_set G).
Notation "'lab'" := (lab G).
Notation "'sb'" := (sb G).
Notation "'rf'" := (rf G).
Notation "'co'" := (co G).
Notation "'rmw'" := (rmw G).
Notation "'data'" := (data G).
Notation "'addr'" := (addr G).
Notation "'ctrl'" := (ctrl G).
Notation "'deps'" := (deps G).
Notation "'rmw_dep'" := (rmw_dep G).

Notation "'fre'" := (fre G).
Notation "'rfe'" := (rfe G).
Notation "'coe'" := (coe G).
Notation "'rfi'" := (rfi G).
Notation "'fri'" := (fri G).
Notation "'coi'" := (coi G).
Notation "'fr'" := (fr G).
Notation "'eco'" := (eco G).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'R_ex'" := (fun a => is_true (R_ex lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).
Notation "'W_ex'" := (W_ex G).

Notation "'loc'" := (loc lab).
Notation "'val'" := (val lab).
Notation "'mod'" := (mod lab).
Notation "'same_loc'" := (same_loc lab).

Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'Loc_' l" := (fun x => loc x = l) (at level 1).

Lemma exists_inf_thread (f: nat -> actid) (S: actid -> Prop) b
      (IN_E: f ↑₁ set_full ⊆₁ E \₁ is_init)
      (INF: ~ set_finite (f ↓₁ S))
      (FINTHREADS : threads_bound G b):
    exists t, BinPos.Pos.lt t b /\ ~ set_finite (f ↓₁ (S ∩₁ Tid_ t)).
Proof using.
  apply set_infinite_bunion.
  { exists (mk_list (Datatypes.S (BinPos.Pos.to_nat b)) BinPos.Pos.of_nat). intros.
    apply in_mk_list_iff. eexists. split.
    2: { symmetry. apply Pnat.Pos2Nat.id. }
    red in IN. apply Pnat.Pos2Nat.inj_lt in IN. lia. }
  intros FIN. destruct INF.
  rewrite set_bunion_separation with (fab := tid).
  rewrite set_map_bunion.
  rewrite set_full_split with (S := flip BinPos.Pos.lt b).
  rewrite set_bunion_union_l, set_finite_union. split; auto.
  exists []. ins. unfolder in IN. desc. destruct IN. red.
  rewrite <- IN1. apply FINTHREADS. apply IN_E. vauto.
Qed.

Lemma exists_inf_loc (f: nat -> actid) (S: actid -> Prop) locs
      (IN_E: f ↑₁ set_full ⊆₁ E \₁ is_init)
      (INF: ~ set_finite (f ↓₁ S))
      (FINLOCS: forall e (ENIe: (E \₁ is_init) e), In (loc e) locs):
    exists l, In l locs /\ ~ set_finite (f ↓₁ (S ∩₁ Loc_ l)).
Proof using.
  eapply set_infinite_bunion; [by vauto| ].
  intros FIN. destruct INF.
  rewrite set_bunion_separation with (fab := loc).
  rewrite set_map_bunion.
  rewrite set_full_split with (S := fun l => In l locs).
  rewrite set_bunion_union_l, set_finite_union. split; auto.
  exists []. ins. unfolder in IN. desc.
  destruct IN. rewrite <- IN1. apply FINLOCS. apply IN_E. vauto.
Qed.

End HardwareFairness.


(** ** Decidability of Beta Equivalence *)

(** Proof that algorithmic equivalence and definitional equivalence are equivalent,
following
A case study on logical relations using contextual Types (Andrew Cave, Brigitte Pientka, 2015)
and
Logical Relations and a case study in equivalence checking (Karl Crary, 2005)
**)

Require Export List Omega.
  Require Import core core_axioms unscoped unscoped_axioms.
  Import UnscopedNotations.
From Chapter3 Require Export utlc_pure.

Ltac inv H := inversion H; subst.

Inductive ty := Base | arr : ty -> ty -> ty.

(** *** Reduction, multireduction, and their properties *)

Inductive whr : tm -> tm -> Prop :=
| beta M N M' : M' = M[N..] -> whr (app (lam M) N) M'
| whrapp M M' N : whr M M' -> whr (app M N) (app M' N).

Inductive mwhr : tm -> tm -> Prop :=
 | mwhrR s : mwhr s s
 | mwhrS s t u : whr s t -> mwhr t u -> mwhr s u.

Hint Constructors whr mwhr.

Lemma mwhr_appL s s' t :
  mwhr s s' -> mwhr (app s t) (app s' t).
Proof. induction 1; eauto using whr. Qed.

Lemma mwhr_trans s t u :
  mwhr s t -> mwhr t u ->  mwhr s u.
Proof. induction 1; eauto. Qed.

 Hint Immediate mwhr_trans.

Lemma whr_ren xi M N :
  whr M  N -> whr (M⟨xi⟩) (N⟨xi⟩).
Proof.
  intros H. revert xi.
  induction H; intros; subst; asimpl; eauto.
  econstructor. now asimpl.
Qed.

Lemma mwhr_ren xi M N :
  mwhr M  N -> mwhr (M⟨xi⟩) (N⟨xi⟩).
Proof. induction 1; eauto using whr_ren. Qed.

Lemma confluence {M N1 N2} : mwhr M N1 -> mwhr M N2 -> exists P, mwhr N1 P /\ mwhr N2 P.
Proof.
  induction 1; eauto. destruct 1; eauto.
  enough (t = t0).
  - subst. eauto.
  - clear - H H1. revert t0 H1.
    induction H; intros; inv H1; eauto. inv H4. inv H.
    f_equal. eauto.
Qed.

(** As we are unscoped, a context is a list of types and we need to define
a function get that gets the nth element of the context. *)

Definition ctx := list ty.

Definition get (Gamma : ctx) (n : nat) : ty :=
  nth n Gamma Base.
Notation "Gamma `_ i" := (get Gamma i) (at level 70).

(** A context Delta is a reordering of  Gamma via the renaming xi, if
1.) If x is a valid position in Gamma, then xi x is a valid position in Delta.
2.) For every valid position x in Gamma, the element at position x in Gamma equals the element at position xi x in Delta.
*)
Definition cont_ext Gamma xi Delta :=
  forall x , x < length Gamma -> xi x < length Delta /\  get Gamma x = get Delta (xi x).

Lemma cont_ext_shift Gamma T :
  cont_ext Gamma ↑ (T :: Gamma).
Proof. split. simpl. unfold shift. omega. now asimpl. Qed.

Lemma cont_ext_cons Gamma xi Delta A :
  cont_ext Gamma xi Delta -> cont_ext (A :: Gamma) (up_ren xi) (A :: Delta).
Proof.
  intros H. intros [|i] HH; split; eauto; simpl in *; try omega.
  - asimpl. specialize (H i). omega.
  - cbn. apply H. omega.
Qed.

(** *** Algorithmic Equivalence *)

Inductive algeq : ctx -> tm -> tm -> ty -> Prop :=
| alg_base Gamma M N P Q:  mwhr M P -> mwhr N Q -> algeqNeu Gamma P Q Base -> algeq Gamma M N Base
| alg_arr Gamma M N T S: algeq (T :: Gamma) (app (M⟨↑⟩) 0__tm) (app (N⟨↑⟩) 0__tm) S
                     -> algeq Gamma M N (arr T S)
with algeqNeu : ctx -> tm -> tm -> ty ->  Prop :=
| alg_var Gamma x : x < length Gamma -> forall s, s = (Gamma `_ x) ->  algeqNeu Gamma (var_tm x) (var_tm x) s
| alg_app Gamma M1 M2 T S N1 N2: algeqNeu Gamma M1 M2 (arr T S) -> algeq Gamma N1 N2 T -> algeqNeu Gamma (app M1 N1) (app M2 N2) S.

Scheme algeq_ind_2 := Induction for algeq Sort Prop
  with algeqNeu_ind_2  := Induction for algeqNeu Sort Prop.

Combined Scheme algeq_mut_ind from algeq_ind_2, algeqNeu_ind_2.

 Lemma algEq_monotone :
  (forall Gamma M1 M2 A, algeq Gamma M1 M2 A -> forall Delta xi, cont_ext Gamma xi Delta -> algeq Delta (M1⟨xi⟩) (M2⟨xi⟩) A)
/\ (  (forall Gamma M1 M2 A, algeqNeu Gamma M1 M2 A -> forall Delta xi, cont_ext Gamma xi Delta -> algeqNeu Delta (M1⟨xi⟩) (M2 ⟨xi⟩) A)).
Proof.
  apply algeq_mut_ind; intros; subst; asimpl in *; try (now (econstructor; eauto)).
  - econstructor; [| |eauto]. all: eauto using mwhr_ren.
  - constructor.
    specialize (H _ _ (cont_ext_cons _ _ _ T H0)).
    asimpl in *. auto.
  - destruct (H x l) as (?&->). now constructor.
Qed.

Lemma algeq_backward_closure Gamma s t A s' t':
  algeq Gamma s t A -> mwhr s' s -> mwhr t' t -> algeq Gamma s' t' A.
Proof.
  intros H. revert s' t'. induction H; intros.
  - econstructor; [| |apply H1]; eauto.
  - econstructor. eapply IHalgeq; eauto using mwhr_appL, mwhr_ren.
Qed.

Lemma algeq_sym :
  (forall Gamma s t A, algeq Gamma s t A -> algeq Gamma t s A) /\ (forall Gamma s t A, algeqNeu Gamma s t A -> algeqNeu Gamma t s A).
Proof. apply algeq_mut_ind; intros; econstructor; eauto. Qed.

(** The following statements will be necessary to prove transitivity. *)

Lemma neutral_whr {M N Gamma P T}:
  whr M N -> algeqNeu Gamma M P T -> M = N.
Proof.
  intros H H'. revert N H.
  induction H'; intros; eauto; inv H0; eauto.
  inv H1. inv H'. specialize (IHH' _ H4). now subst.
Qed.

Lemma neutral_mwhr {M N Gamma P T}:
  mwhr M N -> algeqNeu Gamma M P T -> M = N.
Proof.
  induction 1; eauto. intros HH.
  specialize (neutral_whr H HH) as ->. eauto.
Qed.

Lemma type_unique Gamma M1 M2 M3 S T:
  algeqNeu Gamma M1 M2 S -> algeqNeu Gamma M2 M3 T -> S = T.
Proof.
  intros H. revert T M3. induction H; subst; eauto.
  - intros. now inv H0.
  - intros. inv H1. specialize (IHalgeqNeu _ _ H5). congruence.
Qed.

Lemma algeq_trans :
  (forall Gamma s t A, algeq Gamma s t A -> forall u,  algeq Gamma t u A -> algeq Gamma s u A) /\
  (forall Gamma s t A, algeqNeu Gamma s t A -> forall u, algeqNeu Gamma t u A -> algeqNeu Gamma s u A).
Proof.
  apply algeq_mut_ind; intros; try now (econstructor; eauto).
  - inv H0. destruct (confluence m0 H1) as (?&?&?).
    specialize (neutral_mwhr H5 H3) as ->.
    apply algeq_sym in a. specialize (neutral_mwhr H4 a) as ->.
    eapply algeq_backward_closure. econstructor; try (apply H; eauto).
    all: eauto.
  - inv H0. econstructor. now eapply H.
  - subst. inv H. eauto.
  - inv H1.
    enough (T  = T0) by (subst; econstructor; eauto).
    enough (arr T0 S = arr T S) by congruence.
    symmetry. eapply type_unique; eauto.
Qed.

(** *** Logical Equivalence *)

Fixpoint logeq (Gamma : ctx) (s s' : tm) (A: ty) : Prop :=
  match A with
  | Base => algeq Gamma s s' Base
  | arr T1 T2 =>  forall t t' Delta xi, cont_ext Gamma xi Delta
               -> logeq Delta t t' T1 -> logeq Delta (app (s⟨xi⟩) t) (app (s'⟨xi⟩) t') T2
  end.

Lemma logEq_monotone (Gamma : ctx) M1 M2 A :
  logeq Gamma M1 M2 A -> forall Delta xi, cont_ext Gamma xi Delta ->
                           forall M1' M2', M1' = (M1⟨xi⟩) -> M2' =  (M2⟨xi⟩) -> logeq Delta M1' M2' A.
Proof.
  revert Gamma M1 M2. induction A; intros; subst.
  - eapply algEq_monotone; eauto.
  - asimpl in IHA2. cbn. intros. cbn in H. asimpl. eapply H; eauto.
    + intros x A.
      destruct (H0 x A) as (?&->).
      destruct (H1 _ H3) as (?&->).
      eauto.
Qed.

Lemma logeq_backward_closure Gamma s t A s' t':
  logeq Gamma s t A -> mwhr s' s -> mwhr t' t -> logeq Gamma s' t' A.
Proof.
  revert Gamma s t s' t'. induction A; simpl in *; intros; eauto using algeq_backward_closure.
  - eapply IHA2. all: eauto using mwhr_appL, mwhr_ren.
Qed.

Lemma logeq_sym Gamma A s t:
  logeq Gamma s t A -> logeq Gamma t s A.
Proof.
  revert Gamma s t. induction A; simpl in *; intros; eauto.
  - now apply algeq_sym.
Qed.

Lemma logeq_trans Gamma A s t u :
  logeq Gamma s t A -> logeq Gamma t u A -> logeq Gamma s u A.
Proof.
  revert Gamma s t u. induction A; intros; eauto; simpl in *; eauto using algeq_trans.
  - eapply algeq_trans; eauto.
  - intros. eapply IHA2.
    + eapply H; eauto.
    + eapply H0; eauto. eapply IHA1. eapply logeq_sym. eassumption. eassumption.
Qed.

(** *** Main Lemma. *)

Lemma main T :
  (forall Gamma s t, logeq Gamma s t T -> algeq Gamma s t T) /\ (forall Gamma p q, algeqNeu Gamma p q T -> logeq Gamma p q T).
Proof.
  induction T as [|T IHT S IHS]; split; simpl in *; intros; eauto.
  - econstructor; eauto.
  - econstructor. eapply IHS, H; eauto using cont_ext_shift.
    + eapply IHT. constructor. simpl. omega. now asimpl.
  - eapply IHS. econstructor; eauto.
    + eapply algEq_monotone; eauto.
    +  eapply IHT. eauto.
Qed.

(** *** Declarative Equivalence *)

Inductive decleq  : forall (Gamma: ctx) A,  tm -> tm -> Prop :=
| DecBeta Gamma A B M N M' N': decleq (A :: Gamma) B M M' -> decleq Gamma A N N' -> decleq Gamma B (app (lam M) N) (M'[N'..])
| DecLam Gamma A B M N: decleq (A :: Gamma) B M N  -> decleq Gamma (arr A B) (lam M) (lam N)
| DecExt Gamma A B M N : decleq (A :: Gamma) B (app (M⟨↑⟩) 0__tm) (app (N⟨↑⟩) 0__tm)  -> decleq Gamma (arr A B) M N
| DecVar Gamma x: x < length Gamma -> decleq Gamma (get Gamma x) (var_tm x) (var_tm x)
| DecApp Gamma A B M M' N N'  : decleq Gamma (arr A B) M M'  -> decleq Gamma A N N'  -> decleq Gamma B (app M N) (app M' N')
| DecSym Gamma A M N : decleq Gamma A M N -> decleq Gamma A N M
| DecTrans Gamma A M N O : decleq Gamma A M N -> decleq Gamma A N O -> decleq Gamma A M O.

(** All elements in the context will have to be pairwise logically equivalent. *)
Definition logeq_rel (Gamma: ctx) gamma delta Gamma' : Prop :=
  forall x, x < length Gamma ->  logeq Gamma' (gamma x) (delta x) (get Gamma x).

Lemma logeq_id Gamma:  logeq_rel Gamma ids ids Gamma.
Proof. unfold logeq_rel. intros. eapply main. constructor; eauto. Qed.
Lemma cont_ext_id Gamma : cont_ext Gamma id Gamma.
Proof. intros x H. split; auto. Qed.

(** The fundamental theorem. *)
Theorem fundamental Gamma A s t:
  decleq Gamma A s t -> forall Gamma' gamma delta, logeq_rel Gamma gamma delta Gamma' -> logeq Gamma' (s[gamma]) (t[delta]) A.
Proof.
  induction 1; intros.
  - asimpl. eapply logeq_backward_closure; [| |constructor].
    2: {eright. constructor. now asimpl. constructor. }
    eapply IHdecleq1.
    intros [|] HH; cbn; eauto.
    + eapply H1. simpl in *. omega.
  - cbn. intros. eapply logeq_backward_closure.
    2,3 : eright; now constructor.
    asimpl. eapply IHdecleq.
    intros [|x]; unfold get; simpl in *; intros; eauto.
    eapply logEq_monotone; eauto.
    all: try (substify; now reflexivity).
    eapply H0. omega.
  - simpl. intros. asimpl in *. asimpl in IHdecleq.
    (* adrian: had to change scons notation below to not use t, gamma *)
    Open Scope fscope.
    specialize (IHdecleq Delta (t .: gamma >> ⟨xi⟩) (t' .: delta >> ⟨xi⟩)).
    asimpl in *.
    eapply IHdecleq.
    intros [|i] HH; asimpl; eauto.
    cbn. eapply logEq_monotone; eauto. eapply H0. simpl in *. omega.
  - simpl. now eapply H0.
  - specialize (IHdecleq1 _ _ _ H1). asimpl in *.
    specialize (IHdecleq2 _ _ _ H1). cbn in *.
    specialize (IHdecleq1 _ _ _ _ (cont_ext_id Gamma') IHdecleq2).
    asimpl in *. now apply IHdecleq1.
  - apply logeq_sym. eapply IHdecleq.
    intros i HH. now eapply logeq_sym, H0.
  - eapply logeq_trans; eauto.
    eapply IHdecleq2. intros i HH.
    eapply logeq_trans.
    + now eapply logeq_sym, H1.
    + now eapply H1.
Qed.

Lemma completeness Gamma A s t:
  decleq Gamma A s t -> algeq Gamma s t A.
Proof.
  intros H. eapply fundamental with (Gamma' := Gamma) (gamma := ids) (delta := ids) in H; eauto using logeq_id.
  - apply main. now asimpl in H.
Qed.


(************************************************************
* Lambda-calculus with exceptions,                          *
* Pretty-big-step semantics                                 *
*************************************************************)

Set Implicit Arguments.
Require Export Common.

(************************************************************)
(* ** Syntax *)

Inductive trm : Type :=
  | trm_var : var -> trm
  | trm_abs : var -> trm -> trm
  | trm_app : trm -> trm -> trm
  | trm_try : trm -> var -> trm -> trm
  | trm_raise : trm -> trm.

(** Grammar of values and terms *)

Inductive val : Type :=
  | val_int : int -> val
  | val_clo : env val -> var -> trm -> val
  | val_err : val.

Definition stack := env val.

Inductive beh :=
  | beh_ret : val -> beh
  | beh_exn : val -> beh
  | beh_err : beh.

Coercion beh_ret : val >-> beh.

Implicit Types v : val.
Implicit Types t : trm.
Implicit Types b : beh.

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

Notation "x ~~ a" := (single x a)
  (at level 27, left associativity) : env_scope.

(************************************************************)
(* ** Semantics *)

Implicit Types s : stack.

(** Grammar of outcomes, isomorphic to:
      Inductive out :=
        | out_ret : val -> out
        | out_exn : val -> out
        | out_div : out.
    *)

Inductive out :=
  | out_beh : beh -> out
  | out_div : out.

Coercion out_beh : beh >-> out.
Implicit Types o : out.
Notation "'out_exn' v" := (out_beh (beh_exn v)) (at level 60).
Notation "'out_err'" := (out_beh (beh_err)) (at level 0).

(** Grammar of extended terms *)

Inductive ext : Type :=
  | ext_trm : trm -> ext
  | ext_app_1 : out -> trm -> ext
  | ext_app_2 : val -> out -> ext
  | ext_try_1 : out -> var -> trm -> ext
  | ext_raise_1 : out -> ext.

Coercion ext_trm : trm >-> ext.
Implicit Types e : ext.

(** Abort behavior *)

Inductive abort : out -> Prop :=
  | abort_exn : forall v, abort (out_exn v)
  | abort_div : abort out_div
  | abort_err : abort out_err.

(** "One rule applies" judgment *)

Inductive one : stack -> ext -> Prop :=
  | one_var : forall s x v,
      binds x v s ->
      one s (trm_var x)
  | one_abs : forall s x t,
      one s (trm_abs x t)
  | one_app : forall s t1 t2,
      one s (trm_app t1 t2)
  | one_app_1_abort : forall s o1 t2,
      abort o1 ->
      one s (ext_app_1 o1 t2)
  | one_app_1 : forall s v1 t2,
      one s (ext_app_1 v1 t2)
  | one_app_2_abort : forall s v1 o2,
      abort o2 ->
      one s (ext_app_2 v1 o2)
  | one_app_2 : forall s' s x t3 v2,
      one s' (ext_app_2 (val_clo s x t3) v2)
  | one_try : forall s t1 x t2,
      one s (trm_try t1 x t2)
  | one_try_1_val : forall s v1 x t2,
      one s (ext_try_1 v1 x t2)
  | one_try_1_exn : forall s x t2 v,
      one s (ext_try_1 (out_exn v) x t2)
  | one_try_1_div : forall s x t2,
      one s (ext_try_1 out_div x t2)
  | one_raise : forall s t1,
      one s (trm_raise t1)
  | one_raise_1_abort : forall s o1,
      abort o1 ->
      one s (ext_raise_1 o1)
  | one_raise_1 : forall s v,
      one s (ext_raise_1 v).

(** Evaluation judgment *)

Inductive red : stack -> ext -> out -> Prop :=
  | red_var : forall s x v,
      binds x v s ->
      red s (trm_var x) v
  | red_abs : forall s x t,
      red s (trm_abs x t) (val_clo s x t)
  | red_app : forall s t1 t2 o1 o,
      red s t1 o1 ->
      red s (ext_app_1 o1 t2) o ->
      red s (trm_app t1 t2) o
  | red_app_1_abort : forall s o1 t2,
      abort o1 ->
      red s (ext_app_1 o1 t2) o1
  | red_app_1 : forall s v1 t2 o o2,
      red s t2 o2 ->
      red s (ext_app_2 v1 o2) o ->
      red s (ext_app_1 v1 t2) o
  | red_app_2_abort : forall s v1 o2,
      abort o2 ->
      red s (ext_app_2 v1 o2) o2
  | red_app_2 : forall (s s':stack) x t3 v2 o,
      red (s' & x ~~ v2) t3 o ->
      red s (ext_app_2 (val_clo s' x t3) v2) o
  | red_try : forall s t1 x t2 o1 o,
      red s t1 o1 ->
      red s (ext_try_1 o1 x t2) o ->
      red s (trm_try t1 x t2) o
  | red_try_1_val : forall s v1 x t2,
      red s (ext_try_1 v1 x t2) v1
  | red_try_1_exn : forall s t2 o v x,
      red (s & x ~~ v) t2 o ->
      red s (ext_try_1 (out_exn v) x t2) o
  | red_try_1_div : forall s x t2,
      red s (ext_try_1 out_div x t2) out_div
  | red_raise : forall s t1 o1 o,
      red s t1 o1 ->
      red s (ext_raise_1 o1) o ->
      red s (trm_raise t1) o
  | red_raise_1_abort : forall s o1,
      abort o1 ->
      red s (ext_raise_1 o1) o1
  | red_raise_1 : forall s v,
      red s (ext_raise_1 v) (out_exn v)
  | red_err : forall s e,
      ~ one s e ->
      red s e out_err.

(** Coevaluation judgment:
    copy-paste of the above definition,
    simply replacing [red] with [cored] *)

Inductive cored : stack -> ext -> out -> Prop :=
  | cored_var : forall s x v,
      binds x v s ->
      cored s (trm_var x) v
  | cored_abs : forall s x t,
      cored s (trm_abs x t) (val_clo s x t)
  | cored_app : forall s t1 t2 o1 o,
      cored s t1 o1 ->
      cored s (ext_app_1 o1 t2) o ->
      cored s (trm_app t1 t2) o
  | cored_app_1_abort : forall s o1 t2,
      abort o1 ->
      cored s (ext_app_1 o1 t2) o1
  | cored_app_1 : forall s v1 t2 o o2,
      cored s t2 o2 ->
      cored s (ext_app_2 v1 o2) o ->
      cored s (ext_app_1 v1 t2) o
  | cored_app_2_abort : forall s v1 o2,
      abort o2 ->
      cored s (ext_app_2 v1 o2) o2
  | cored_app_2 : forall (s s':stack) x t3 v2 o,
      cored (s' & x ~~ v2) t3 o ->
      cored s (ext_app_2 (val_clo s' x t3) v2) o
  | cored_try : forall s t1 x t2 o1 o,
      cored s t1 o1 ->
      cored s (ext_try_1 o1 x t2) o ->
      cored s (trm_try t1 x t2) o
  | cored_try_1_val : forall s v1 x t2,
      cored s (ext_try_1 v1 x t2) v1
  | cored_try_1_exn : forall s t2 o v x,
      cored (s & x ~~ v) t2 o ->
      cored s (ext_try_1 (out_exn v) x t2) o
  | cored_try_1_div : forall s x t2,
      cored s (ext_try_1 out_div x t2) out_div
  | cored_raise : forall s t1 o1 o,
      cored s t1 o1 ->
      cored s (ext_raise_1 o1) o ->
      cored s (trm_raise t1) o
  | cored_raise_1_abort : forall s o1,
      abort o1 ->
      cored s (ext_raise_1 o1) o1
  | cored_raise_1 : forall s v,
      cored s (ext_raise_1 v) (out_exn v)
  | cored_err : forall s e,
      ~ one s e ->
      cored s e out_err.

(*==========================================================*)
(* * Typing *)

(************************************************************)
(* ** Grammar of simple types *)

CoInductive typ :=
  | typ_int : typ
  | typ_arrow : typ -> typ -> typ.

(************************************************************)
(* ** Typing judgment *)

Inductive trmtyping : env typ -> trm -> typ -> Prop :=
  | trmtyping_var : forall E x T,
      binds x T E ->
      trmtyping E (trm_var x) T
  | trmtyping_abs : forall x E U T t1,
      trmtyping (E & x ~~ U) t1 T ->
      trmtyping E (trm_abs x t1) (typ_arrow U T)
  | trmtyping_app : forall T1 T2 E t1 t2,
      trmtyping E t1 (typ_arrow T1 T2) ->
      trmtyping E t2 T1 ->
      trmtyping E (trm_app t1 t2) T2
  | trmtyping_raise : forall E t1 T,
      trmtyping E t1 typ_int ->
      trmtyping E (trm_raise t1) T
  | trmtyping_try : forall E t1 x t2 T,
      trmtyping E t1 T ->
      trmtyping (E & x~~typ_int) t2 T ->
      trmtyping E (trm_try t1 x t2) T.

Inductive valtyping : val -> typ -> Prop :=
  | valtyping_int : forall k,
      valtyping (val_int k) typ_int
  | valtyping_clo : forall E s x T1 T2 t1,
      stacktyping E s ->
      trmtyping (E & x ~~ T1) t1 T2 ->
      valtyping (val_clo s x t1) (typ_arrow T1 T2)

with stacktyping : env typ -> stack -> Prop :=
  | stacktyping_intro : forall E s,
     (forall x T, binds x T E ->
        exists v, binds x v s /\ valtyping v T) ->
     stacktyping E s.
(*
  | stacktyping_empty :
     stacktyping empty
  | stacktyping_push : forall s x v T,
     stacktyping s ->
     valtyping v T ->
     stacktyping (s & x ~~ v).
*)

Inductive outtyping : out -> typ -> Prop :=
  | outtyping_ter : forall v T,
      valtyping v T ->
      outtyping (out_beh v) T
  | outtyping_exn : forall v T,
      valtyping v typ_int ->
      outtyping (out_exn v) T
  | outtyping_div : forall T,
      outtyping out_div T.

Inductive exttyping : env typ -> ext -> typ -> Prop :=
  | extyping_trm : forall E t T,
      trmtyping E t T ->
      exttyping E t T
  | exttyping_app_1 : forall E T1 T2 o1 t2,
      outtyping o1 (typ_arrow T1 T2) ->
      trmtyping E t2 T1 ->
      exttyping E (ext_app_1 o1 t2) T2
  | exttyping_app_2 : forall E T1 T2 v1 o2,
      valtyping v1 (typ_arrow T1 T2) ->
      outtyping o2 T1 ->
      exttyping E (ext_app_2 v1 o2) T2
  | extyping_raise_1 : forall E T o1,
      outtyping o1 typ_int ->
      exttyping E (ext_raise_1 o1) T
  | extyping_try_1 : forall E T o1 x t2,
      outtyping o1 T ->
      trmtyping (E & x ~~ typ_int) t2 T ->
      exttyping E (ext_try_1 o1 x t2) T.

(*==========================================================*)
(* * Proofs *)

Lemma stacktyping_push : forall E s x v T,
  stacktyping E s ->
  valtyping v T ->
  stacktyping (E & x ~~ T) (s & x ~~ v).
Proof.
  introv M H. inverts M as M.
  constructors. introv B. binds_cases B.
  forwards* (v'&?&?): M.
  subst*.
Qed.

Lemma stacktyping_binds : forall E x s v T,
  stacktyping E s -> binds x v s -> binds x T E ->
  valtyping v T.
Proof.
  introv M Bv BT. inverts M as M.
  forwards* (v'&Bv'&?): M. unfolds binds.
  asserts: (v = v'). congruence. subst*.
Qed.

Lemma stacktyping_elim_1 : forall E x s T,
  stacktyping E s -> binds x T E -> exists v, binds x v s.
Proof.
  introv M B. inverts M as M. forwards* (?&?&?): M.
Qed.

Hint Resolve stacktyping_push stacktyping_binds.

(************************************************************)
(* ** Soundness *)

Hint Constructors one abort outtyping exttyping valtyping.

Lemma abort_outyping : forall o T T',
  abort o -> outtyping o T -> outtyping o T'.
Proof.
  introv A M. inverts M; inverts A; auto.
Qed.

Lemma soundness_ind : forall E s e o T,
  red s e o -> stacktyping E s -> exttyping E e T ->
  outtyping o T.
Proof.
  introv R. gen E T. induction R; introv S M.
  inverts M as M. inverts* M.
  inverts M as M. inverts* M.
  inverts M as M. inverts* M.
  inverts M as M1 M2. forwards*: abort_outyping H.
  inverts M as M. inverts* M.
  inverts M as M1 M2. forwards*: abort_outyping H.
  inverts M as M1 M2. inverts M2. inverts* M1.
  inverts M as M. inverts* M.
  inverts M as M. inverts* M.
  inverts M as M. inverts* M.
  inverts M as M. inverts* M.
  inverts M as M. inverts* M.
  inverts M as M1 M2. forwards*: abort_outyping H.
  inverts M as M. inverts* M.
  false (rm H). inverts M as.
    introv M. inverts* M. forwards* (?&?): stacktyping_elim_1.
    introv M1 M2. inverts* M1.
    introv M1 M2. inverts M1. inverts* M2.
    introv M1. inverts* M1.
    introv M1 M2. inverts* M1.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Lists.SetoidList.
Require Import Coq.Classes.Morphisms Coq.Setoids.Setoid.
Require Import Coq.Structures.Equalities.
Require Import Crypto.Util.Structures.Equalities.
Require Import Crypto.Util.ListUtil.

Local Set Implicit Arguments.

Module ListTyp (E : Typ) <: Typ.
  Definition t := list E.t.
End ListTyp.

Module ListHasEq (E : Eq).
  Definition eq : relation (list E.t) := eqlistA E.eq.
End ListHasEq.

Module ListIsEq (E : EqualityType).
  Local Notation eq := (eqlistA E.eq).
  Global Instance eq_equiv : Equivalence eq | 5.
  Proof.
    constructor; exact _.
  Defined.
End ListIsEq.

Module ListIsEqOrig (E : EqualityTypeOrig).
  Local Notation eq := (eqlistA E.eq).
  Lemma eq_refl : Reflexive eq.
  Proof. apply eqlistA_equiv; split; first [ exact E.eq_refl | exact E.eq_sym | exact E.eq_trans ]. Qed.
  Lemma eq_sym : Symmetric eq.
  Proof. apply eqlistA_equiv; split; first [ exact E.eq_refl | exact E.eq_sym | exact E.eq_trans ]. Qed.
  Lemma eq_trans : Transitive eq.
  Proof. apply eqlistA_equiv; split; first [ exact E.eq_refl | exact E.eq_sym | exact E.eq_trans ]. Qed.
End ListIsEqOrig.

Module ListHasEqDec (E : Eq) (EDec : HasEqDec E).
  Local Notation eq := (eqlistA E.eq).
  Definition eq_dec x y : {eq x y} + {~eq x y}.
  Proof.
    revert y; induction x as [|x xs IH], y as [|y ys]; try destruct (IH ys), (EDec.eq_dec x y).
    all: try solve [ constructor; repeat (constructor + assumption) ].
    all: try (right; abstract (inversion 1; subst; eauto)).
  Defined.
End ListHasEqDec.

Module ListHasEqb (E : Typ) (Eb : HasEqb E).
  Definition eqb := list_beq _ Eb.eqb.
End ListHasEqb.

Module ListEqbNotation (E : Typ) (Es : HasEqb E).
  Module Import _ListEqbNotation.
    Module T := ListTyp E.
    Module E := ListHasEqb E Es.
  End _ListEqbNotation.
  Include EqbNotation T _ListEqbNotation.E.
End ListEqbNotation.

Module ListEqbSpec (E : Typ) (Ee : HasEq E) (Eb : HasEqb E) (Es : EqbSpec E Ee Eb).
  Local Notation eq := (eqlistA Ee.eq).
  Local Notation eqb := (list_beq _ Eb.eqb).
  Lemma eqb_eq x y : eqb x y = true <-> eq x y.
  Proof.
    split; first [ apply eqlistA_lb | apply eqlistA_bl ].
    all: apply Es.eqb_eq.
  Qed.
End ListEqbSpec.

Module ListHasEqBool (E : Eq) (Es : HasEqBool E) := ListHasEqb E Es <+ ListEqbSpec E E Es Es.

Module ListUsualHasEqDec (E : UsualEq) (EDec : HasEqDec E).
  Definition eq_dec (x y : list E.t) : {eq x y} + {~eq x y}
    := List.list_eq_dec EDec.eq_dec x y.
End ListUsualHasEqDec.

Module ListUsualEqbSpec (E : UsualBoolEq).
  Lemma eqb_eq x y : @list_beq _ E.eqb x y = true <-> eq x y.
  Proof.
    split; first [ apply internal_list_dec_lb | apply internal_list_dec_bl ].
    all: apply E.eqb_eq.
  Qed.
End ListUsualEqbSpec.

Module ListHasUsualEq (E : UsualEq).
  Module Import _ListHasUsualEq.
    Module E' := ListTyp E.
  End _ListHasUsualEq.
  Include HasUsualEq E'.
End ListHasUsualEq.

Module ListUsualEq (E : UsualEq) <: UsualEq := ListTyp E <+ HasUsualEq.

Module ListUsualIsEq (E : UsualEq).
  Module Import _ListUsualIsEq.
    Module E' := ListUsualEq E.
  End _ListUsualIsEq.
  Include UsualIsEq E'.
End ListUsualIsEq.

Module ListUsualIsEqOrig (E : UsualEq).
  Module Import _ListUsualIsEqOrig.
    Module E' := ListUsualEq E.
  End _ListUsualIsEqOrig.
  Include UsualIsEqOrig E'.
End ListUsualIsEqOrig.

Module ListMiniDecidableType (E : MiniDecidableType) <: MiniDecidableType.
  Include ListTyp E.
  Module Import _ListMiniDecidableType.
    Module E' := Make_UDT E.
  End _ListMiniDecidableType.
  Include ListUsualHasEqDec E' E'.
End ListMiniDecidableType.

Module ListUsualHasEqBool (E : UsualBoolEq) := ListHasEqb E E <+ ListUsualEqbSpec E.

Module ListEq (E : Eq) <: Eq := ListTyp E <+ ListHasEq E.
Module ListEqualityType (E : EqualityType) <: EqualityType := ListEq E <+ ListIsEq E.
Module ListEqualityTypeOrig (E : EqualityTypeOrig) <: EqualityTypeOrig := ListEq E <+ ListIsEqOrig E.
Module ListEqualityTypeBoth (E : EqualityTypeBoth) <: EqualityTypeBoth := ListEq E <+ ListIsEq E <+ ListIsEqOrig E.
Module ListDecidableType (E : DecidableType) <: EqualityType := ListEqualityType E <+ ListHasEqDec E E.
Module ListDecidableTypeOrig (E : DecidableTypeOrig) <: DecidableTypeOrig := ListEqualityTypeOrig E <+ ListHasEqDec E E.
Module ListDecidableTypeBoth (E : DecidableTypeBoth) <: DecidableTypeBoth := ListEqualityTypeBoth E <+ ListHasEqDec E E.
Module ListBooleanEqualityType (E : BooleanEqualityType) <: BooleanEqualityType := ListEqualityType E <+ ListHasEqb E E <+ ListEqbSpec E E E E.
Module ListBooleanDecidableType (E : BooleanDecidableType) <: BooleanDecidableType := ListBooleanEqualityType E <+ ListHasEqDec E E.
Module ListDecidableTypeFull (E : DecidableTypeFull) <: DecidableTypeFull := ListEq E <+ ListIsEq E <+ ListIsEqOrig E <+ ListHasEqDec E E <+ ListHasEqBool E E.

Module ListEq' (E : Eq) := ListEq E <+ EqNotation.
Module ListEqualityType' (E : EqualityType) := ListEqualityType E <+ EqNotation.
Module ListEqualityTypeOrig' (E : EqualityTypeOrig) := ListEqualityTypeOrig E <+ EqNotation.
Module ListEqualityTypeBoth' (E : EqualityTypeBoth) := ListEqualityTypeBoth E <+ EqNotation.
Module ListDecidableType' (E : DecidableType) := ListDecidableType E <+ EqNotation.
Module ListDecidableTypeOrig' (E : DecidableTypeOrig) := ListDecidableTypeOrig E <+ EqNotation.
Module ListDecidableTypeBoth' (E : DecidableTypeBoth) := ListDecidableTypeBoth E <+ EqNotation.
Module ListBooleanEqualityType' (E : BooleanEqualityType) := ListBooleanEqualityType E <+ EqNotation <+ EqbNotation.
Module ListBooleanDecidableType' (E : BooleanDecidableType) := ListBooleanDecidableType E <+ EqNotation <+ EqbNotation.
Module ListDecidableTypeFull' (E : DecidableTypeFull) := ListDecidableTypeFull E <+ EqNotation.

Module ListUsualEqualityType (E : UsualEqualityType) <: UsualEqualityType := ListUsualEq E <+ UsualIsEq.
Module ListUsualEqualityTypeOrig (E : UsualEqualityTypeOrig) <: UsualEqualityTypeOrig := ListUsualEq E <+ UsualIsEqOrig.
Module ListUsualEqualityTypeBoth (E : UsualEqualityTypeBoth) <: UsualEqualityTypeBoth := ListUsualEq E <+ UsualIsEq <+ UsualIsEqOrig.

Module ListUsualDecidableType (E : UsualDecidableType) <: UsualDecidableType
:= ListUsualEq E <+ UsualIsEq <+ ListUsualHasEqDec E E.
Module ListUsualDecidableTypeOrig (E : UsualDecidableTypeOrig) <: UsualDecidableTypeOrig
:= ListUsualEq E <+ UsualIsEqOrig <+ ListUsualHasEqDec E E.
Module ListUsualDecidableTypeBoth (E : UsualDecidableTypeBoth) <: UsualDecidableTypeBoth
 := ListUsualDecidableType E <+ UsualIsEqOrig.
Module ListUsualBoolEq (E : UsualBoolEq) <: UsualBoolEq
:= ListUsualEq E <+ ListUsualHasEqBool E.
Module ListUsualDecidableTypeFull (E : UsualDecidableTypeFull) <: UsualDecidableTypeFull
 := ListUsualEq E <+ UsualIsEq <+ UsualIsEqOrig <+ ListUsualHasEqDec E E <+ ListUsualHasEqBool E.

Local Coercion is_true : bool >-> Sortclass.
Module ListIsEqb (E : EqbType).
  Global Instance eqb_equiv : Equivalence (list_beq _ E.eqb) | 5.
  Proof.
    split; hnf;
      [ induction x as [|x xs IH];
        try pose proof ((_ : Reflexive E.eqb) x)
      | induction x as [|x xs IH], y as [|y ys];
        try (specialize (IH ys); pose proof ((_ : Symmetric E.eqb) x y))
      | induction x as [|x xs IH], y as [|y ys], z as [|z zs];
        try (specialize (IH ys zs); pose proof ((_ : Transitive E.eqb) x y z)) ];
      cbn in *; cbv [is_true] in *;
      rewrite ?Bool.andb_true_iff; intuition (congruence + eauto).
  Qed.
End ListIsEqb.

Module ListEqbType (E : EqbType) <: EqbType := ListTyp E <+ ListHasEqb E E <+ ListIsEqb E.


Require Import TM.Prelim TM.Code.CodeTM.
Require Import TM.Lifting.LiftAlphabet.

(** * Alphabet-lift for "programmed" Turing Machines *)

(** All "programmed" Turing machines are defined on an alphabet [Σ^+]. In this module, we instanciate the [LiftAlphabet] operator. Given a machine [M:TM_{Σ^+}] and a retraction [f: Σ ↪ Γ], we define a machine [⇑M : TM_{Γ^+}]. *)

Generalizable All Variables.

Section SurjectInject.
  Variable (sig tau : finType).
  Variable def : sig.
  Variable retr : Retract sig tau.

  Definition injectSymbols : list sig -> list tau := map Retr_f.
  Definition surjectSymbols : list tau -> list sig := map (surject Retr_g def).

  (* This can be easyly proven without induction. *)
  Lemma surject_inject (str : list sig) (str' : list tau) :
    injectSymbols str = str' ->
    str = surjectSymbols str'.
  Proof.
    intros <-. induction str as [ | s str IH ]; cbn.
    - reflexivity.
    - unfold surject. retract_adjoint. f_equal. auto.
  Qed.

  Lemma inject_surject (str : list tau) (str' : list sig) :
    (forall t, t el str -> exists s, Retr_g t = Some s) ->
    surjectSymbols str = str' ->
    str = injectSymbols str'.
  Proof.
    intros H <-. unfold injectSymbols, surjectSymbols. rewrite map_map. erewrite map_ext_in. symmetry. eapply map_id.
    intros t Ht. specialize (H _ Ht) as (s&Hs).
    erewrite retract_g_inv; eauto.
    unfold surject. rewrite Hs. reflexivity.
  Qed.

  Lemma surject_cons (str : list tau) (str2 : list sig) (s : sig) :
    surjectSymbols str = s :: str2 ->
    exists (t : tau) (str' : list tau),
      str = t :: str' /\
      surject Retr_g def t = s /\
      surjectSymbols str' = str2.
  Proof.
    destruct str as [ | t str ]; cbn in *; intros; inv H; eauto.
  Qed.

  Lemma surject_app (str : list tau) (str2 str3 : list sig) :
    surjectSymbols str = str2 ++ str3 ->
    exists (str' str'' : list tau),
      str = str' ++ str'' /\
      surjectSymbols str'  = str2 /\
      surjectSymbols str'' = str3.
  Proof.
    revert str str3. induction str2 as [ | s str2 IH]; intros str str3 H; cbn in *.
    - exists nil, str. cbn. auto.
    - pose proof surject_cons H as (t&str'&->&L1&L2). cbn in *. specialize (IH _ _ L2) as (Str&Str'&->&IH1&IH2).
      inv H. repeat eexists. instantiate (1 := t :: Str). reflexivity. cbn. reflexivity.
  Qed.

End SurjectInject.

Corollary map_length_eq : forall (A B C : Type) (f : A -> C) (g : B -> C) (l1 : list A) (l2 : list B), map f l1 = map g l2 -> |l1| = |l2|.
Proof.
  intros. erewrite <- map_length. symmetry. erewrite <- map_length. symmetry. rewrite H. reflexivity.
Qed.

Section MapCode.
  Variable sig tau : finType.
  Variable retr : Retract sig tau.

  (* [Retract_sum] isn't declared as instance *)
  Global Instance Retract_plus : Retract (sig^+) (tau^+) := Retract_sum _ _.
  Notation "'f''" := (@Retr_f (sig^+) (tau^+) Retract_plus).
  Notation "'g''" := (@Retr_g (sig^+) (tau^+) Retract_plus).

  Context `{cX : codable sig X}.

  (* Translation Functions *)
  Notation injectTape := (mapTape f').
  Notation surjectTape := (surjectTape g' (inl UNKNOWN)).

  Check injectTape : tape (sig^+) -> tape (tau^+) .
  Check surjectTape : tape (tau^+) -> tape (sig^+).

  (* The other direction does not hold *)
  Lemma surjectTape_injectTape t :
    surjectTape (injectTape t) = t.
  Proof.
    unfold surjectTape. unfold surject. simpl_tape.
    erewrite mapTape_ext. apply mapTape_id. intros a. retract_adjoint. reflexivity.
  Qed.

  Lemma contains_translate_sig (x : X) (t : tape (sig^+)) :
    t ≃ x <-> (injectTape t) ≃ x.
  Proof.
    split; intros (r1&HCode); subst; cbn in *; hnf.
    - repeat eexists. cbn. f_equal. rewrite map_app, !List.map_map. cbn. reflexivity.
    - unfold injectTape in HCode.
      exists (surjectSymbols (inl UNKNOWN) _ r1).
      apply mapTape_inv_midtape in HCode as (ls'&m'&rs'&->&->&HCode1&HCode2).
      rewrite map_map in HCode2.
      destruct m'; cbn in *; inv HCode1.
      f_equal.
      + unfold surjectSymbols. rewrite map_map. rewrite <- map_id at 1. eapply map_ext.
        intros [ | ]; cbn. reflexivity. unfold surject. cbn. retract_adjoint. reflexivity.
      + symmetry. eapply map_injective with (f := retract_sum_f id Retr_f); eauto.
        { intros. eapply retract_f_injective; eauto. }
        now rewrite map_app, !map_map.
  Qed.

  Lemma contains_translate_tau1 (x : X) (t : tape (tau^+)) :
    t ≃ x -> surjectTape t ≃ x.
  Proof.
    intros (ls&HCode). cbn in *. subst. cbn. rewrite !map_map.
    repeat econstructor. f_equal. rewrite map_app, !map_map. f_equal.
    eapply map_ext. intros. unfold surject. cbn. retract_adjoint. reflexivity.
  Qed.

  Lemma surject_inject_inr (x : boundary) (str : list tau^+) (code : list sig) :
    surjectSymbols (inl x) Retract_plus str = map inr code ->
    exists str' : list tau, str = map inr str' /\ map Retr_g str' = map Some code.
  Proof.
    revert x code. induction str as [ | s str' IH]; intros; cbn in *.
    - apply map_eq_nil' in H as ->. exists nil. cbn. tauto.
    - destruct code as [ | c code']; cbn in *; inv H.
      destruct s; cbn in *; inv H1.
      specialize (IH _ _ H2) as (str''&->&IH). rewrite <- IH.
      exists (e :: str''). cbn. split. auto. f_equal.
      unfold surject, retract_sum_g in H0. destruct (Retr_g e) eqn:E; inv H0; auto.
  Qed.

  Lemma in_encode_retract (x : X) :
    forall t' : tau, t' el encode x -> exists s' : sig, Retr_g t' = Some s'.
  Proof. cbn. intros t' (?&<-&?) % in_map_iff. retract_adjoint. eauto. Qed.

  Lemma contains_translate_tau2 (x : X) (t : tape (tau^+)) :
    surjectTape t ≃ x ->
    t ≃ x.
  Proof.
    intros (r1&HCode). cbn in *.
    eapply mapTape_inv_midtape in HCode as (ls'&m'&rs'&->&->&HCode1&HCode2).
    repeat econstructor; cbn in *. f_equal.
    - unfold surject in HCode1. destruct m'; cbn in *. cbv [id] in *. now inv HCode1.
      destruct (Retr_g e); inv HCode1.
    - symmetry in HCode2.
      change (surjectSymbols (inl UNKNOWN) Retract_plus rs' = map inr (cX x) ++ [inl STOP]) in HCode2.
      eapply surject_app in HCode2 as (str1&str2&->&L1&L2).
      eapply inject_surject in L1 as ->; eauto.
      eapply inject_surject in L2 as ->; eauto.
      + f_equal. unfold injectSymbols. rewrite !map_map. eapply map_ext. intros. cbn. reflexivity.
      + unfold surjectSymbols in L2. eapply map_eq_cons in L2 as (t & ? & -> & ? & -> % map_eq_nil').
        unfold surject in H. destruct t; cbn in *; swap 1 2. destruct (Retr_g e); inv H. inv H.
        intros [ | ]; intros [ | ]; try congruence; auto. inv H. eexists. cbn. reflexivity.
      + intros [ | ]; intros He; cbn; eauto.
        destruct (Retr_g e) eqn:E1; cbn; eauto. exfalso.
        pose proof surject_inject_inr L1 as (str1'&->&L3).
        apply in_map_iff in He as (?&HETmp&HE); inv HETmp.
        enough (e el encode x) as L4.
        {
          pose proof in_encode_retract L4 as (?&?). congruence.
        }
        assert (None el map Retr_g str1') as L5.
        {
          rewrite <- E1. eapply in_map_iff; eauto.
        }
        rewrite L3 in L5. apply in_map_iff in L5 as (?&?&?). congruence.
  Qed.

  Corollary contains_translate_tau (x : X) (t : tape (tau^+)) :
    surjectTape t ≃ x <-> t ≃ x.
  Proof. split; auto using contains_translate_tau1, contains_translate_tau2. Qed.

  Corollary contains_translate_eq (t1 t2 : tape (tau^+)) (x : X) :
    surjectTape t1 = surjectTape t2 ->
    t1 ≃ x -> t2 ≃ x.
  Proof.
    intros HEq HEnc.
    eapply contains_translate_tau2; auto.
    rewrite <- HEq. now eapply contains_translate_tau1 in HEnc.
  Qed.

  Lemma surjectTape_isRight (t : tape (tau^+)) :
    isRight t -> isRight (surjectTape t).
  Proof. unfold surjectTape. apply mapTape_isRight. Qed.

  Lemma surjectTape_isRight' (t : tape (tau^+)) :
    isRight (surjectTape t) -> isRight t.
  Proof. unfold surjectTape. apply mapTape_isRight. Qed.

End MapCode.

Hint Unfold surjectTape surjectTapes injectTape : tape.

(** This makes sure that we can apply the above lemmas ([contains_translate_sig], [contains_translate_tau1], [contains_translate_tau2]), even after [cbn] *)
Arguments Retract_plus : simpl never.
Arguments injectTape : simpl never.
Arguments surjectTape : simpl never.

(** ** Definition of the lifted machine *)

Section ChangeAlphabet.
  Variable (sig tau : finType).
  Variable (n : nat) (F : finType).
  Variable pM : pTM sig^+ F n.
  Variable (retr : Retract sig tau).

  Definition ChangeAlphabet : pTM tau^+ F n :=
    LiftAlphabet pM (Retract_plus retr) (inl UNKNOWN).

End ChangeAlphabet.

(** This tactic removes [surjectTape] in hypothesises and in the goal *)
Ltac simpl_surject_step :=
  lazymatch goal with
  (* encoding *)
  | [ |- surjectTape _ _ ?t ≃ _ ] => apply contains_translate_tau1
  | [ H : surjectTape _ _ ?t ≃ _ |- _ ] => apply contains_translate_tau2 in H
  (* variants with shown encoding *)
  | [ |- surjectTape _ _ ?t ≃(_) _ ] => apply contains_translate_tau1
  | [ H : surjectTape _ _ ?t ≃(_) _ |- _ ] => apply contains_translate_tau2 in H
  (* [isRight] *)
  | [ |- isRight (surjectTape _ _ ?t) ] => apply surjectTape_isRight
  | [ H : isRight (surjectTape _ _ ?t) |- _ ] => apply surjectTape_isRight' in H
  end.

Ltac simpl_surject := repeat simpl_surject_step.

(** ** Function Computation of the lifted machine *)

Section Computes_ChangeAlphabet.

  Variable (sig tau : finType).

  Variable (n_tapes : nat).
  Variable F : finType.

  Variable (pM : pTM sig^+ F (S (S n_tapes))).

  Variable retr : Retract sig tau.
  (** Use this to say the [TM_Correct] tactic to apply [ChangeAlphabet_Computes] instead of only unfolding [ChangeAlphabet] and applying [LiftAlphabet_Realise]. *)

  Variable X Y : Type.
  Variable (cX : codable sig X) (cY : codable sig Y).
  Variable (func : X -> Y).

  Lemma ChangeAlphabet_Computes :
    pM ⊨ Computes_Rel func ->
    ChangeAlphabet pM retr ⊨ Computes_Rel func.
  Proof.
    intros H. eapply Realise_monotone.
    {
      eapply LiftAlphabet_Realise; eauto.
    }
    {
      hnf. intros tin (yout&tout) HComp.
      cbn. intros x HEncX HOut HIntern.
      cbn in HComp. repeat autounfold with tape in HComp. simpl_vector in HComp. cbn in HComp.
      eapply contains_translate_tau1 in HEncX; eauto.
      specialize (HComp x HEncX).
      destruct HComp as (HComp1&HComp2&HComp3); cbn in *.
      { now eapply surjectTape_isRight. }
      { intros. simpl_tape. eapply surjectTape_isRight. eauto. }
      repeat split.
      + eapply contains_translate_tau2; eauto.
      + eapply contains_translate_tau2; eauto.
      + intros i. specialize (HComp3 i). simpl_tape in HComp3.
        now eapply surjectTape_isRight' in HComp3.
    }
  Qed.

  Lemma ChangeAlphabet_Terminates T :
    projT1 pM ↓ Computes_T T ->
    projT1 (ChangeAlphabet pM retr) ↓ Computes_T T.
  Proof.
    intros H. eapply TerminatesIn_monotone.
    { unfold ChangeAlphabet. TM_Correct. apply H. }
    {
      intros t k HComp. cbn in *. destruct HComp as (x&HEncX&HOut&HInt&Hk).
      exists x. simpl_tape. repeat split; simpl_surject; auto.
      now intros i; cbn; simpl_tape; simpl_surject.
    }
  Qed.

End Computes_ChangeAlphabet.

Section Computes_ChangeAlphabet2.

  Variable (sig tau : finType).

  Variable (n_tapes : nat).
  Variable F : finType.
  Variable (pM : pTM sig^+ F (S (S (S n_tapes)))).

  Variable retr : Retract sig tau.

  Variable X Y Z : Type.
  Variable (cX : codable sig X) (cY : codable sig Y) (cZ : codable sig Z).
  Variable (func : X -> Y -> Z).

  Lemma ChangeAlphabet_Computes2 :
    pM ⊨ Computes2_Rel func ->
    ChangeAlphabet pM _ ⊨ Computes2_Rel func.
  Proof.
    intros H. eapply Realise_monotone.
    {
      unfold ChangeAlphabet. eapply LiftAlphabet_Realise; eauto.
    }
    {
      hnf. intros tin (yout&tout) HComp.
      cbn. intros x y HEncX HEncY HOut HIntern.
      cbn in HComp. repeat autounfold with tape in HComp. simpl_vector in HComp. cbn in HComp.
      eapply contains_translate_tau1 in HEncX; eauto.
      eapply contains_translate_tau1 in HEncY; eauto.
      specialize (HComp x y HEncX HEncY).
      destruct HComp as (HComp1&HComp2&HComp3&HComp4); cbn in *.
      { now eapply surjectTape_isRight. }
      { intros. simpl_tape. cbn. eapply surjectTape_isRight. eauto. }
      repeat split.
      + eapply contains_translate_tau2; eauto.
      + eapply contains_translate_tau2; eauto.
      + eapply contains_translate_tau2; eauto.
      + intros i. specialize (HComp4 i). simpl_tape in HComp4.
        now eapply surjectTape_isRight' in HComp4.
    }
  Qed.

  Lemma ChangeAlphabet_Terminates2 T :
    projT1 pM ↓ Computes2_T T ->
    projT1 (ChangeAlphabet pM retr) ↓ Computes2_T T.
  Proof.
    intros H. eapply TerminatesIn_monotone.
    { unfold ChangeAlphabet. TM_Correct. apply H. }
    {
      intros t k HComp. cbn in *. destruct HComp as (x&y&HEncX&HEncY&HOut&HInt&Hk).
      exists x, y. simpl_tape. repeat split; simpl_surject; auto.
      now intros i; cbn; simpl_tape; simpl_surject.
    }
  Qed.

End Computes_ChangeAlphabet2.

(** ** Tactic Support *)

(** If you want to use [ChangeAlphabet_Computes], just apply [Id] to the machine, to prevent [TM_Correct] unfolding [ChangeAlphabet] *)

Ltac smpl_TM_ChangeAlphabet :=
  lazymatch goal with
  | [ |- ChangeAlphabet ?pM ?retr ⊨ _ ] => apply LiftAlphabet_Realise
  | [ |- projT1 (ChangeAlphabet ?pM ?retr) ↓ _ ] => apply LiftAlphabet_TerminatesIn
  end.

Smpl Add smpl_TM_ChangeAlphabet : TM_Correct.