(** * Proofs in this file
       are within the Compcert model
       of traces.

       In RSC_DC.v we create our model
       for traces proving the same results
 *)

Require Import Classical.
Require Import Classical_Pred_Type.
Require Import Setoid.

(*********************************************************)
(* Some useful Lemma to handle classical facts *)
Lemma dne : forall P : Prop, P <-> ~ ~ P.
Proof.
 intros P. split.
 - intros p np. apply (np p).
 - apply (NNPP P).
Qed.

Lemma imp_eqiv : forall P Q : Prop,
    (P -> Q) <-> ~P \/ Q.
Proof.
 intros P Q. split.
- apply imply_to_or.
- intros H p. destruct H.
  + exfalso. apply (H p). + apply H.
Qed.

Lemma not_imp : forall P Q : Prop,
    ~(P -> Q) <-> P /\ ~ Q.
Proof.
  intros P Q. split.
  - apply imply_to_and.
  - intros [p nq] i. apply (nq (i p)).
Qed.

Lemma contra : forall P Q : Prop,
    (P -> Q) <-> (~Q -> ~P).
Proof.
  intros P Q. split.
  - intros H nq p. apply (nq (H p)).
  - intros H p. rewrite -> (dne Q).
    intros nq. apply (H nq p).
Qed.

Lemma de_morgan1 : forall P Q : Prop,
    ~ (P /\ Q) <-> ~P \/ ~Q.
Proof.
  intros P Q. split.
  - apply not_and_or.
  - intros [] [p q]. apply (H p). apply (H q).
Qed.

Lemma de_morgan2 : forall P Q : Prop,
    ~ (P \/ Q) <-> ~P /\ ~Q.
Proof.
  intros P Q. split.
  - apply not_or_and.
  - intros [np nq] []. apply np. assumption. apply (nq H).
Qed.

Lemma not_forall_ex_not : forall (U : Type) (P : U -> Prop),
    ~ (forall n : U, P n) <-> exists n : U, ~ P n.
Proof.
  intros U P. split.
  - apply (not_all_ex_not U P).
  - apply (ex_not_not_all U P).
Qed.

Lemma not_ex_forall_not : forall (U :Type) (P : U -> Prop),
    (~ exists n : U, P n) <-> forall n : U, ~ P n.
Proof.
 intros U P. split.
 - apply not_ex_all_not.
 - intros H [n p]. apply (H n p).
Qed.

Lemma and_implies_or : forall P Q : Prop, P /\ Q -> P \/ Q.
Proof.
  intros P Q [p q]. apply (or_introl p).
Qed.

(*********************************************************)

Require Import Events.
Require Import Behaviors.

(*********************************************************)

Definition prop := program_behavior -> Prop.
Local Parameter prg prg' ctx ctx' : Set.

Local Parameter plug : prg -> ctx -> prg.
Local Parameter plug': prg' -> ctx' -> prg'.
Local Parameter sem : prg -> prop.
Local Parameter sem': prg' -> prop.
Local Parameter compile : prg -> prg'.

(* program P *satisfies* property π *)
Definition sat (P:prg) (π:prop) : Prop :=
  forall b, sem P b -> π b.

Definition sat' (P':prg') (π:prop) : Prop :=
  forall b, sem' P' b -> π b.

(* program P *robustly satisfies* property π *)
Definition rsat (P:prg) (π:prop) : Prop :=
  forall C, sat (plug P C) π.

Definition rsat' (P':prg') (π:prop) : Prop :=
  forall C, sat' (plug' P' C) π.

(* robust preservation *)
Definition RP (P : prg) (pi : prop) : Prop :=
  rsat P pi -> rsat' (compile P) pi.

Lemma neg_rsat : forall P π,
       ~ rsat P π <->
       (exists C t,
           sem (plug P C) t /\ ~ π t).
Proof.
  unfold rsat. unfold sat. split.
  - intros r. rewrite not_forall_ex_not in r.
    destruct r as [C r]. rewrite not_forall_ex_not in r.
    destruct r as [t r]. exists C,t. rewrite not_imp in r.
    assumption.
  - intros [C [t r]]. rewrite not_forall_ex_not.
    exists C. rewrite not_forall_ex_not. exists t.
    rewrite not_imp. assumption.
Qed.

Lemma neg_rsat' : forall P π,
       ~ rsat' P π <->
       (exists C t,
           sem' (plug' P C) t /\ ~ π t).
Proof.
   unfold rsat'. unfold sat'. split.
  - intros r. rewrite not_forall_ex_not in r.
    destruct r as [C r]. rewrite not_forall_ex_not in r.
    destruct r as [t r]. exists C,t. rewrite not_imp in r.
    assumption.
  - intros [C [t r]]. rewrite not_forall_ex_not.
    exists C. rewrite not_forall_ex_not. exists t.
    rewrite not_imp. assumption.
Qed.

(* contrapositive form of RP, classically equivalent *)
Lemma contra_RP (P : prg) (pi : prop) : RP P pi <->
     ((exists C' t',
       sem' (plug' (compile P) C') t' /\ ~ pi t') ->
      (exists C t,
       sem (plug P C) t /\ ~ pi t)).
Proof.
  unfold RP. split.
  - intros H. rewrite contra in H.
    rewrite neg_rsat in H. rewrite neg_rsat' in H.
    assumption.
  - intros H. rewrite contra. rewrite neg_rsat. rewrite neg_rsat'.
    assumption.
Qed.

(*********************************************************)
(* SNOC                                                  *)
(*********************************************************)
Fixpoint snoc m e : trace :=
  match m with
  | nil => cons e nil
  | cons x xs => cons x (snoc xs e)
  end.

Lemma snoc_lemma : forall m,
    m = nil \/ (exists e m', m = snoc m' e).
Proof.
  induction m.
  + now left.
  + right. destruct IHm as [Knil | [e [m' K]]];
           [exists a, nil | exists e, (cons a m')]; now subst.
Qed.

Lemma snoc_app : forall m e,
    snoc m e = m ** (cons e nil).
Proof.
  intros m e. induction m; try now auto.
  + simpl. now rewrite IHm.
Qed.

Lemma snoc_append : forall m1 m2 e,
    m1 ** (snoc m2 e) = m1 ** m2 ** (cons e nil).
Proof.
  intros m1 m2 e. induction m2; try now auto.
  + simpl. now rewrite (snoc_app m2 e).
Qed.

Lemma foo_lemma : forall m e, snoc m e = nil -> False.
Proof.
  intros m e H. destruct m; now inversion H.
Qed.

Lemma snoc_eq : forall m1 m2 e1 e2,
    snoc m1 e1 = snoc m2 e2 ->
    m1 = m2 /\ e1 = e2.
Proof.
  intros m1. induction m1; intros m2 e1 e2 H.
  + destruct m2; inversion H; try now auto.
    exfalso. symmetry in H2. now apply (foo_lemma m2 e2).
  + destruct m2; inversion H.
    exfalso. symmetry in H2. now apply (foo_lemma m1 e1).
    specialize (IHm1 m2 e1 e2 H2).
    destruct IHm1 as [k1 k2]. rewrite k1. now auto.
Qed.

Lemma same_length : forall m1 m2 e1 e2,
    m1 ** (cons e1 nil) = m2 ** (cons e2 nil) ->
    m1 = m2 /\ e1 = e2.
Proof.
  intros m1 m2 e1 e2 H.
  rewrite <- (snoc_app m1 e1) in H. rewrite <- (snoc_app m2 e2) in H.
  now apply snoc_eq.
Qed.

Lemma snoc_pref : forall m m1 e1,
    trace_prefix m (snoc m1 e1) ->
    m = snoc m1 e1 \/ trace_prefix m m1.
Proof.
  intros m m1 e1 [[] Hb].
  + rewrite E0_right in Hb. now left.
  + specialize (snoc_lemma (cons e l)).
    intros [H | [e' [l' H]]]; rewrite H in Hb.
    ++ rewrite E0_right in Hb. now left.
    ++ right. exists l'. rewrite snoc_append in Hb.
       rewrite snoc_app in Hb.
       rewrite <- Eapp_assoc in Hb.
       apply (same_length m1 (m ** l') e1 e') in Hb.
       now auto.
Qed.

(*********************************************************)
(*  foall P : prg,                                       *)
(*   RC_dc P  <-> Robust Preservation of Z_p             *)
(*********************************************************)

Local Parameter undef : prg -> event.

Axiom undef_no_extension_behavior : forall P b m,
    behavior_prefix (snoc m (undef P)) b -> b = Goes_wrong (snoc m (undef P)).

Lemma undef_no_extension_trace : forall P t m,
    trace_prefix (snoc m (undef P)) t -> t = (snoc m (undef P)).
Proof.
  intros P t m [t' Ht'].
  specialize (undef_no_extension_behavior P (Goes_wrong t) m).
  intros H. assert (behavior_prefix (snoc m (undef P)) (Goes_wrong t)).
  { exists (Goes_wrong t').  simpl. subst. now auto. }
  specialize (H H0). now inversion H.
Qed.

Lemma no_nested : forall P m,
    snoc (snoc m (undef P)) (undef P) = snoc m (undef P).
Proof.
  intros P m. apply (undef_no_extension_trace P (snoc (snoc m (undef P)) (undef P)) m).
  exists (cons (undef P) nil). now rewrite <- (snoc_app (snoc m (undef P))).
Qed.

Lemma undef_longer : forall P m,
    trace_prefix m (snoc m (undef P)).
Proof.
  intros P m. exists (cons (undef P) nil).
  now rewrite snoc_app.
Qed.

Lemma pref_undef_pref : forall P m m',
    trace_prefix m  (snoc m' (undef P)) ->
    (m = snoc m' (undef P)) \/ (trace_prefix m m').
Proof.
  intros P m m' H. now apply (snoc_pref m m' (undef P)).
Qed.

Definition u_prefix P b m: Prop :=
  exists mb,  trace_prefix mb m  /\
          b = Goes_wrong (snoc mb (undef P)).

Lemma trace_prefix_trans : forall m1 m2 m,
    trace_prefix m1 m2 -> trace_prefix m2 m ->
    trace_prefix m1 m.
Proof.
  intros m1 m2 m [b1 Hb1] [b2 Hb2]. rewrite Hb1 in Hb2.
  rewrite Eapp_assoc in Hb2. now exists (b1 ** b2).
Qed.

Lemma trace_prefix_ref : forall m, trace_prefix m m.
Proof. intros m. exists nil. now rewrite E0_right. Qed.

Lemma behavior_prefix_pseudo_trans : forall m1 m2 b,
    behavior_prefix m1 b -> trace_prefix m2 m1 ->
    behavior_prefix m2 b.
Proof.
  intros m1 m2 b [t1 Ht1] [t2 Ht2].
  unfold behavior_prefix. subst.
  exists (behavior_app t2 t1). now apply behavior_app_assoc.
Qed.

Lemma u_prefix_pseudo_trans: forall P t m1 m2,
    u_prefix P t m1 -> trace_prefix m1 m2 ->
    u_prefix P t m2.
Proof.
  intros P t m1 m2 [ub [Hub1 Hub2]] [t1 Ht1].
  unfold u_prefix. exists ub.
  destruct Hub1 as [tt1 Htt1]. rewrite Htt1 in Ht1.
  rewrite Eapp_assoc in Ht1. split; try now auto.
  now exists (tt1 ** t1).
Qed.

Lemma same_extension_trace : forall m1 m2 t,
    trace_prefix m1 t -> trace_prefix m2 t ->
    (trace_prefix m1 m2 \/ trace_prefix m2 m1).
Proof.
  intros m1. induction m1; intros m2 t [b1 Hb1] [b2 Hb2]; rewrite Hb1 in Hb2.
  + left. exists m2. now rewrite E0_left.
  + destruct m2.
    ++ right. exists (cons a m1). now rewrite E0_left. inversion Hb2. subst.
       destruct (IHm1 m2 (m1 ** b1)) as [[l Hl] | [l Hl]].
       now exists b1. now exists b2.
       +++ left. exists l. simpl. now rewrite Hl.
       +++ right; exists l. simpl. now rewrite Hl.
Qed.

Lemma same_extension_stream : forall m1 m2 t,
    traceinf_prefix m1 t -> traceinf_prefix m2 t ->
    (trace_prefix m1 m2 \/ trace_prefix m2 m1).
Proof.
  intros m1. induction m1; intros m2 t [b1 Hb1] [b2 Hb2]; rewrite Hb1 in Hb2.
  + left. exists m2. now rewrite E0_left.
  + destruct m2.
    ++ right. exists (cons a m1). now rewrite E0_left. inversion Hb2. subst.
       destruct (IHm1 m2 (m1 *** b1)) as [[l Hl] | [l Hl]].
       now exists b1. now exists b2.
       +++ left. exists l. simpl. now rewrite Hl.
       +++ right; exists l. simpl. now rewrite Hl.
Qed.

Lemma same_extension : forall m1 m2 t,
    behavior_prefix m1 t -> behavior_prefix m2 t ->
    (trace_prefix m1 m2 \/ trace_prefix m2 m1).
Proof.
  intros m1 m2 [] [[] Hb1] [[] Hb2]; try (inversion Hb1; inversion Hb2);
    rewrite H0 in H1.
    + assert (trace_prefix m1 (m1 ** t0)) by now exists t0.
      assert (trace_prefix m2 (m1 ** t0)) by now exists t1.
      now apply (same_extension_trace m1 m2 (m1 ** t0)).
    + assert (trace_prefix m1 (m1 ** t0)) by now exists t0.
      assert (trace_prefix m2 (m1 ** t0)) by now exists t1.
      now apply (same_extension_trace m1 m2 (m1 ** t0)).
    + assert (traceinf_prefix m1 (m1 *** t0)) by now exists t0.
      assert (traceinf_prefix m2 (m1 *** t0)) by now exists t1.
      now apply (same_extension_stream m1 m2 (m1 *** t0)).
    + assert (trace_prefix m1 (m1 ** t0)) by now exists t0.
      assert (trace_prefix m2 (m1 ** t0)) by now exists t1.
      now apply (same_extension_trace m1 m2 (m1 ** t0)).
Qed.

Definition RSC_dc (P : prg) : Prop :=
  forall C' t, sem' (plug' (compile P) C') t ->
   (forall m, behavior_prefix m t ->
      exists C t', sem (plug P C) t' /\
              (behavior_prefix m t' \/ u_prefix P t' m)).

Definition Z_class P π : Prop :=
  forall t,  ~ π t ->
   (exists m, behavior_prefix m t /\
         forall t', (behavior_prefix m t' \/ u_prefix P t' m) -> ~ π t').

Theorem RSC_dc_RZP : forall P : prg,
    RSC_dc P -> (forall π, Z_class P π -> RP P π).
Proof.
  intros P r π z. rewrite contra_RP. intros [C' [t [h0 h1]]].
  destruct (z t h1) as [m [pmt H]]. clear z.
  destruct (r C' t h0 m pmt) as [C [ t' [k0 k1]]]. clear r.
  exists C, t'. split. - assumption. - apply (H t' k1).
Qed.

Theorem RZP_RSC_dc : forall P : prg,
    (forall π, Z_class P π -> RP P π) -> RSC_dc P.
Proof.
  unfold RSC_dc. intros P rz C' t H0 m pmt.
  assert (K : Z_class P (fun b => ~ (behavior_prefix m b \/ u_prefix P b m))).
  { unfold Z_class. intros t0 Ht0. rewrite <- dne in Ht0.
    destruct Ht0 as [use_m | Ht0].
    + exists m. split. auto. intros t' Ht'. now rewrite dne in Ht'.
    + destruct Ht0 as [m0 [Hpref Hb]].
      exists (snoc m0 (undef P)). split; auto.
      ++ exists (Goes_wrong nil). simpl.
          now rewrite E0_right. (*TODO : Lemmas for this *)
          intros t' [H | [mb [H1 H2]]]; rewrite <- dne.
          +++ apply undef_no_extension_behavior in H. subst.
          +++ right. now exists m0.
      ++ right. assert ( mb = (snoc m0 (undef P)) \/ trace_prefix mb m0)
                by now apply (pref_undef_pref P mb m0).
         destruct H as [K1 | K2].
         +++ exists m0. subst. split; try now auto. now rewrite no_nested.
         +++ exists mb. split; try now auto.
             now apply (trace_prefix_trans mb m0 m).
   }
  assert (T : ~ (fun b => ~ (behavior_prefix m b \/ u_prefix P b m)) t).
  { rewrite <- dne. left. assumption. }
  specialize (rz (fun b => ~ (behavior_prefix m b \/ u_prefix P b m)) K).
  rewrite contra_RP in rz. destruct rz as [C [t' [k0 k1]]]. exists C',t. split. assumption.
  rewrite <- dne. left. assumption. exists C,t'.
  split. assumption. rewrite <- dne in k1. assumption.
Qed.

Corollary pointwise_equiv' : forall P : prg,
    RSC_dc P <-> (forall pi : prop, Z_class P pi -> RP P pi).
Proof.
  intros P. split.
  - apply RSC_dc_RZP.
  - apply RZP_RSC_dc.
Qed.

Corollary main_thm' :
    (forall P, RSC_dc P) <-> (forall P pi, Z_class P pi -> RP P pi).
   (* ^^^^^^^^^^^^^^^^ *)
   (*      RSC^DC      *)
Proof.
  split. - intros H P. now apply RSC_dc_RZP.
         - intros H P. apply RZP_RSC_dc. now apply H.
Qed.

(*********************************************************)
(*  Relation between Z_p and Safety                      *)
(*********************************************************)

Definition Safety (π : prop) : Prop :=
  forall t, ~ π t -> exists m, behavior_prefix m t /\
        (forall t', behavior_prefix m t' -> ~ π t').

(* Z_class is a sublclass of safety *)
Lemma Z_p_Safety : forall (P : prg) (pi : prop),
    Z_class P pi -> Safety pi.
Proof.
  unfold Safety. intros P pi Z t nt.
  destruct (Z t nt) as [m [pmt H]]. clear Z.
  exists m. split; now auto.
Qed.

(* Class of property closed under refinement
   (undef due to program P)
 *)
Definition ref_cl (P : prg) (π : prop) : Prop :=
  forall t, π t ->
       forall t', (exists m', behavior_prefix m' t' /\
                      u_prefix P t m') -> π t'.

(* classically equivalent formulation for ref_cl *)
Lemma ref_cl' : forall (P : prg) (π : prop),
    ref_cl P π <->
    (forall t', ~ π t' ->
          forall t, (exists m', behavior_prefix m' t' /\
                  u_prefix P t m') -> ~ π t).
Proof.
  intros P π. split.
  - intros r t' nt' t [m' [Hm' Hu']] pit.
    apply nt'. apply (r t pit t'). now exists m'.
  - unfold ref_cl. intros r t pit t' utt'. apply NNPP.
    intros npi'. apply ((r t' npi' t utt') pit).
Qed.

Lemma U_general : forall P t1 t2,
    (exists m2, behavior_prefix m2 t2 /\ u_prefix P t1 m2) ->
    (forall m, behavior_prefix m t2 ->
               (behavior_prefix m t1 \/ u_prefix P t1 m)).
Proof.
  intros P t1 t2 [m2 [H2 Hu]] m pm2.
  destruct Hu as [mm [H0 H1]].
  assert (foo : trace_prefix m mm \/ trace_prefix mm m).
  { apply (same_extension m mm t2); try now auto.
    now apply (behavior_prefix_pseudo_trans m2 mm t2). }
  destruct foo as [k0 | k1].
  + left. assert (trace_prefix m (snoc mm (undef P))).
    { apply (trace_prefix_trans m mm (snoc mm (undef P))); try now auto.
      now apply (undef_longer P mm). }
    destruct H as [l Hl]. exists (Goes_wrong l).
    simpl. now rewrite Hl in *.
  + right. now exists mm.
Qed.

Lemma Z_p_equivalent : forall (P : prg) (π : prop),
    Z_class P π <-> Safety π /\ ref_cl P π.
Proof.
  intros P π. split.
  - intros z. split.
    + now apply (Z_p_Safety P).
    + rewrite ref_cl'. intros t' nt' t utt'.
      destruct (z t' nt') as [m [pmt zz]].
      assert (behavior_prefix m t \/ u_prefix P t m) as use_me by
      apply  (U_general P t t' utt' m pmt).
      apply (zz t use_me).
  -  intros [s r]. unfold Z_class.
     intros t nt. destruct (s t nt) as [m [pmt H]].
     exists m. split; try now auto.
     intros t' [k0 | k1].
     apply (H t' k0).
     assert (use_me : exists m', behavior_prefix m' t /\ u_prefix P t' m').
     { unfold u_prefix. destruct k1 as [m0 [p0 u0]].
       exists m0. split; try now auto.
       now apply (behavior_prefix_pseudo_trans m m0 t).
       exists m0. split; try now auto.
       now apply trace_prefix_ref. }
     rewrite ref_cl' in r. apply (r t nt t' use_me).
Qed.

Lemma easy_lemma0 :
  (forall P π, Z_class P π -> RP P π) <->
  (forall P π, (Safety π /\ ref_cl P π) -> RP P π).
Proof.
  split.
  - intros L P π H. rewrite <- (Z_p_equivalent P π) in H.
    now apply (L P).
  - intros R P π Z. rewrite (Z_p_equivalent P π) in Z.
    now apply (R P π).
Qed.

Lemma easy_lemma1 : forall P : prg,
  (forall  π, Z_class P π -> RP P π) <->
  (forall  π, (Safety π /\ ref_cl P π) -> RP P π).
Proof.
  intros P. split.
  - intros L π H. rewrite <- (Z_p_equivalent P π) in H.
    apply (L π H).
  - intros R π H. rewrite (Z_p_equivalent P π) in H.
    apply (R π H).
Qed.

(* theorem in the paper *)
Corollary main_thm :
  (forall P : prg, RSC_dc P) <->
  (forall P π, (Safety π /\ ref_cl P π) -> RP P π).
Proof. rewrite <- easy_lemma0. apply main_thm'. Qed.

Corollary pointwise_equiv : forall P : prg,
    RSC_dc P <->
    (forall π : prop, (Safety π /\ ref_cl P π) -> RP P π).
Proof.
  intros P.
  rewrite <- (easy_lemma1 P). apply pointwise_equiv'.
Qed.

(*********************************************************)
(*  extracting a Z_class property from a Safety one      *)
(*********************************************************)

Definition u_prefix_b P t1 t2 : Prop :=
  exists m2, behavior_prefix m2 t2 /\ u_prefix P t1 m2.

(* starting from a safety property π we define the following *)
Definition z_plus (π : prop) (S:Safety π) (P : prg) : prop :=
  fun t =>  π t /\
           forall t', u_prefix_b P t t' -> π t'.

(* z_plus is a subproperty of π *)
Lemma sub : forall (π : prop) (S : Safety π)
                   (P : prg) (b : program_behavior),
                    (z_plus π S P b) -> π b.
Proof. intros π S P b [h0 h1]; assumption. Qed.

Lemma sub' : forall (π : prop) (S : Safety π)
                    (P : prg) (b : program_behavior),
                     ~ π b -> ~ (z_plus π S P b).
Proof. intros π S P b. rewrite <- contra.
       apply (sub π S P).
Qed.

(* z_plus is in Z_class *)
Lemma extraction_lemma :  forall (π : prop) (P : prg)
                                 (s : Safety π),
                           Z_class P (z_plus π s P).
Proof.
  intros π P s. unfold Z_class. intros t H.
  unfold z_plus in *. rewrite de_morgan1 in H.
  destruct H as [K | K].
  + destruct (s t K) as [m [Hm1 Hm2]].
    exists m. split; try now auto.
    intros t' [Hpref | Hundef]; rewrite de_morgan1.
    ++ left. now apply (Hm2 t').
    ++ right. intros Hf. apply K.
       apply (Hf t). unfold u_prefix_b.
       now exists m.
  + rewrite not_forall_ex_not in K. destruct K as [t' Ht'].
    rewrite not_imp in Ht'. destruct Ht' as [[b [Hb1 [m [H1 H2]]]] H].
    destruct (s t' H) as [m' [Hm' HHm']].
    exists (snoc m (undef P)). split.
    ++ unfold behavior_prefix. exists (Goes_wrong nil). simpl. now rewrite E0_right.
    ++ intros t'0 [Hpref | Hundef]; rewrite de_morgan1.
       +++ apply undef_no_extension_behavior in Hpref.
           apply (behavior_prefix_pseudo_trans b m t' Hb1) in H1.
           assert (trace_prefix m m' \/ trace_prefix m' m)
             by now apply (same_extension m m' t').
           destruct H0.
           *  right. intros ff. apply H. apply ff.
             unfold u_prefix_b. exists m. split; try now auto.
             unfold u_prefix. exists m. split; try now auto.
             now apply trace_prefix_ref.
           * left. subst. apply HHm'. destruct H0 as [l Hl].
             rewrite Hl. exists (Goes_wrong (snoc l (undef P))).
             simpl. rewrite (snoc_append m' l (undef P)).
             rewrite (snoc_app (m' ** l) (undef P)).
             now rewrite Eapp_assoc.
        +++ destruct Hundef as [b0 [Hb0 Hb00]].
            assert (b0 = (snoc m (undef P)) \/ trace_prefix b0 m) by
                now apply (pref_undef_pref P b0 m).
            destruct H0 as [K | K].
           * rewrite K in Hb00. rewrite no_nested in Hb00. rewrite <- H2 in Hb00.
             rewrite Hb00 in *. right. intros Hf. apply H. apply Hf.
             exists m. split.
             ** now apply (behavior_prefix_pseudo_trans b m t').
             ** exists m. split; try now auto. now apply trace_prefix_ref.
           * right. intros ff. apply H. apply ff.
             unfold u_prefix_b. exists b0. split.
             apply (behavior_prefix_pseudo_trans b m t' Hb1) in H1.
             now apply (behavior_prefix_pseudo_trans m b0 t').
             exists b0. split; try now auto. now apply trace_prefix_ref.
Qed.

(* z_plus is the biggest property in Z_p that is included in π *)
Lemma maximality_lemma : forall (P : prg) (π phi : prop) (S : Safety π)
                                (Zphi : Z_class P phi)
                                (H: forall b, phi b -> π b),

    forall b, phi b -> (z_plus π S P) b.
Proof.
  intros P π phi S Zphi H b phib.
  unfold z_plus. split.
  - apply (H b phib).
  - intros t [m [Hpref Hu]]. rewrite dne. intros nπt.
    assert (nphit : ~ phi t).
    { intros phit. apply (nπt (H t phit)). }
    specialize (Zphi t nphit).
    destruct Zphi as [m' [pmt K]].
    assert (use_me : behavior_prefix m' b \/ u_prefix P b m').
    { apply (U_general P b t); try now auto. now exists m.  }
    apply ((K b use_me) phib).
Qed.

(*********************************************************)
(*  building a Z_class property on a Safety one          *)
(*********************************************************)

(* starting from a safety property π we define the following *)
Definition z_minus (P : prg) (π : prop) : prop :=
  fun b =>
    π b \/ (exists t,  π t /\ (u_prefix_b P t b)).

(* π is included in z_minus *)
Lemma sub_minus : forall (P : prg) (π : prop) (b : program_behavior),
                  π b -> (z_minus P π) b.
Proof. intros P π b H.  unfold z_minus. left. apply H. Qed.

Lemma app_nil : forall m l,
    m = m ** l -> l = nil.
Proof.
  intros m. induction m; intros l H.
  + rewrite E0_left in H. congruence.
  + inversion H. now apply IHm.
Qed.

Lemma trace_prefix_asym : forall m1 m2,
    trace_prefix m1 m2 -> trace_prefix m2 m1 -> m1 = m2.
Proof.
  intros m1 m2 [l1 Hl1] [l2 Hl2]. rewrite Hl1 in Hl2.
  rewrite Eapp_assoc in Hl2. apply (app_nil m1 (l1 ** l2)) in Hl2.
  destruct l1, l2; try (rewrite E0_right in Hl1; congruence);
  try rewrite E0_right in Hl2; inversion Hl2.
Qed.

Lemma u_prefix_b_asym : forall P t1 t2,
    u_prefix_b P t1 t2 -> u_prefix_b P t2 t1 -> t1 = t2.
Proof.
  intros P t1 t2 [b1 [H11 [m1 [Hm1 Hm1']]]]  [b2 [H22 [m2 [Hm2 Hm2']]]].
  assert (behavior_prefix m1 t2) by now apply (behavior_prefix_pseudo_trans b1 m1 t2).
  assert (behavior_prefix m2 t1) by now apply (behavior_prefix_pseudo_trans b2 m2 t1).
  assert (trace_prefix m1 (snoc m2 (undef P))).
  { destruct H as [beh Hbeh]. rewrite Hm2' in Hbeh. destruct beh; inversion Hbeh.
    now exists t. }
  assert (trace_prefix m2 (snoc m1 (undef P))).
  { destruct H0 as [beh Hbeh]. rewrite Hm1' in Hbeh. destruct beh; inversion Hbeh.
    now exists t. }
  apply snoc_pref in H1. apply snoc_pref in H2.
  destruct H1, H2.
  + subst. repeat (rewrite no_nested). reflexivity.
  + rewrite H1 in Hm1'. rewrite no_nested in Hm1'. now subst.
  + rewrite H2 in Hm2'. rewrite no_nested in Hm2'. now subst.
  + apply (trace_prefix_asym m1 m2 H1) in H2. rewrite H2 in *.
    now rewrite Hm2'.
Qed.

Lemma u_prefix_b_trans : forall P t1 t2 t3,
    u_prefix_b P t1 t2 -> u_prefix_b P t2 t3 -> u_prefix_b P t1 t3.
Proof.
  intros P t1 t2 t3 [b1 [H11 [m1 [Hm1 Hm1']]]]  [b2 [H22 [m2 [Hm2 Hm2']]]].
  assert (trace_prefix m1 m2 \/ trace_prefix m2 m1).
  { assert (behavior_prefix m1 t2) by now apply (behavior_prefix_pseudo_trans b1 m1 t2).
    assert (behavior_prefix m2 t2).
    { exists (Goes_wrong (cons (undef P) nil)). simpl. now rewrite <- snoc_app. }
    now apply (same_extension m1 m2 t2). }
  destruct H.
  + exists b2. split; try now auto.
    exists m1. split; try now auto.
    now apply (trace_prefix_trans m1 m2 b2).
  + assert (u_prefix_b P t2 t1).
    { exists m1. split.
      exists (Goes_wrong (cons (undef P) nil)). simpl.
      now rewrite <- snoc_app. now exists m2. }
    assert (t1 = t2).
    { apply (u_prefix_b_asym P t1 t2); try now auto.
      exists b1; split; try now auto. now exists m1. }
    rewrite H1 in *. exists b2. split; try now auto.
    now exists m2.
Qed.

(* z_minus is in Z_p *)
Lemma growth_lemma : forall (P : prg) (π : prop) (S : Safety π),
                     Z_class P (z_minus P π).
Proof.
  intros P π S. unfold Z_class. intros t H.
  unfold z_minus in *. rewrite de_morgan2 in H.
  destruct H as [H1 H2].
  rewrite not_ex_forall_not in H2. destruct (S t H1) as [m [Hm1 Hm2]].
  exists m. split; try now auto.
  intros t' [Hpref | Hundef]; rewrite de_morgan2.
  + split.
    ++ now apply Hm2.
    ++ intros [t0 [Hf1 Hf2]]. specialize (H2 t0). rewrite de_morgan1 in H2.
       destruct H2; try now auto.
       destruct Hf2 as  [b [Hb [m0 [Hm0 Hm00]]]].
       apply (behavior_prefix_pseudo_trans b m0 t' Hb) in Hm0.
       assert (trace_prefix m0 m \/ trace_prefix m m0) by
           now apply (same_extension m0 m t').
       destruct H0.
       +++ apply H. exists m0. split; try now auto.
           now apply (behavior_prefix_pseudo_trans m m0 t).
           exists m0. split; try now auto. now apply trace_prefix_ref.
       +++ apply (Hm2 t0); try now auto.
           apply (behavior_prefix_pseudo_trans m0 m t0); try now auto.
           exists (Goes_wrong (cons (undef P) nil)). simpl. now rewrite <- snoc_app.
  + split.
    ++ specialize (H2 t'). rewrite de_morgan1 in H2. destruct H2 as [K | K]; try now auto.
       exfalso. apply K. now exists m.
    ++ intros [t0 [H0 H00]]. specialize (H2 t0). rewrite de_morgan1 in H2.
       destruct H2; try now auto.
       assert (u_prefix_b P t' t) by now exists m.
       apply H. now apply (u_prefix_b_trans P t0 t' t).
Qed.

(* and is the smallest property in Z_p including π *)
Lemma minimality_lemma : forall (P : prg) (π phi : prop) (S: Safety π) (Z: Z_class P phi),
                                (forall b, π b -> phi b) ->
                                (forall b', z_minus P π b' -> phi b').
Proof. intros P pi phi S Z H b' zb'.
       unfold z_minus in zb'. rewrite Z_p_equivalent in Z. destruct Z as [Sphi ref_phi].
       destruct zb' as [k0 | [t [k1 k2]]].
       + apply (H b' k0).
       + destruct k2 as [m [Hm Hmm]]. unfold ref_cl in ref_phi. apply (H t) in k1.
         apply (ref_phi t k1 b'). now exists m.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* 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 Lesser General Public License for more details.                *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************
    Proof of Huffman algorithm: CoverMin.v

    Definition of a minimal tree for a cover

    Defintion: cover_min
                                    Laurent.Thery@inria.fr (2003)
 **********************************************************************)

From Huffman Require Export Cover.
From Huffman Require Export WeightTree.

Section CoverMin.
Variable A : Type.
Variable f : A -> nat.

(* To be a tree of minimum weight for a cover *)
Definition cover_min (l : list (btree A)) (t1 : btree A) : Prop :=
  cover l t1 /\
  (forall t2 : btree A, cover l t2 -> weight_tree f t1 <= weight_tree f t2).

(* Minimum tree for a singleton cover *)
Theorem cover_min_one : forall t : btree A, cover_min (t :: nil) t.
Proof using.
intros t; split; auto.
intros t2 H; inversion H; auto.
generalize (permutation_length _ _ _ H0); simpl in |- *; intros; discriminate.
Qed.
Hint Resolve cover_min_one : core.

(* Minimum trees are preserved by permutation *)
Theorem cover_min_permutation :
 forall (t : btree A) (l1 l2 : list (btree A)),
 cover_min l1 t -> permutation l1 l2 -> cover_min l2 t.
Proof using.
intros t l1 l2 H H0; split.
apply cover_permutation with (2 := H0); auto.
inversion H; auto.
intros t2 H1.
assert (cover l1 t2).
inversion H; auto.
apply cover_permutation with (2 := permutation_sym _ _ _ H0); auto.
inversion H; auto.
Qed.

(* For all covers, there is a minimum tree *)
Theorem cover_min_ex :
 forall l : list (btree A), l <> nil -> exists t : btree A, cover_min l t.
Proof using.
intros l H;
 generalize (find_min_correct (btree A) (weight_tree f) (all_cover _ l)).
case (find_min (weight_tree f) (all_cover _ l)).
intros p; case p.
intros n b ((H1, H2), H3); exists b; auto.
split; auto.
apply all_cover_cover; auto.
intros t2 H4; apply H3.
apply cover_all_cover; auto.
intros H0.
case (one_cover_ex _ l); auto.
intros x H1; absurd (In x (all_cover A l)).
rewrite H0; simpl in |- *; red in |- *; intros H2; case H2.
apply cover_all_cover; auto.
Qed.

End CoverMin.
Hint Resolve cover_min_one : core.


From Undecidability.Shared.Libs.PSL Require Export BasicDefinitions.
From Undecidability.Shared.Libs.PSL Require Import Bijection.

(* ** Formalisation of finite types using canonical structures and type classes *)

(* * Definition of finite Types *)

Class finTypeC  (type:eqType) : Type :=
  FinTypeC {
      enum: list type;
      enum_ok: forall x: type, count enum x = 1
    }.

Structure finType : Type :=
  FinType
    {
      type:> eqType;
      class: finTypeC type
    }.

Arguments FinType type {class}.
Existing Instance class | 0.

(* This is a hack to work-around a problem with a class of hacks *)
Hint Extern 5 (finTypeC (EqType ?x)) => unfold x : typeclass_instances.

Canonical Structure finType_CS (X : Type) {p : eq_dec X} {class : finTypeC (EqType X)} : finType := FinType (EqType X).

(* Print the base type of [finType] in the Canonical Structure. *)
Arguments finType_CS (X) {_ _}.

Definition elem (F: finType) := @enum (type F) (class F).
Hint Unfold elem : core.
Hint Unfold class : core.

Lemma elem_spec (X: finType) (x:X) : x el (elem X).
Proof.
  apply countIn.  pose proof (enum_ok x) as H. unfold elem. lia.
Qed.

Hint Resolve elem_spec : core.
Hint Resolve enum_ok : core.

Lemma allSub (X: finType) (A:list X) : A <<= elem X.
Proof.
  intros x _. apply elem_spec.
Qed.
Hint Resolve allSub : core.

(* A properties that hold on every element of (elem X) hold for every element of the finType X *)
Theorem Equivalence_property_all (X: finType) (p: X -> Prop) :
  (forall x, p x) <-> forall x, x el (elem X) -> p x.
Proof.
  split; auto.
Qed.

Theorem Equivalence_property_exists (X: finType) (p:X -> Prop):
  (exists x, p x) <-> exists x, x el (elem X) /\ p x.
Proof.
  split.
  - intros [x P]. eauto.
  - intros [x [E P]]. eauto.
Qed.

Instance finType_forall_dec (X: finType) (p: X -> Prop): (forall x, dec (p x)) -> dec (forall x, p x).
Proof.
  intros D. eapply dec_transfer.
  - symmetry. exact (Equivalence_property_all p).
  - auto.
Qed.

Instance finType_exists_dec (X:finType) (p: X -> Prop) : (forall x, dec (p x)) -> dec (exists x, p x).
Proof.
  intros D. eapply dec_transfer.
  - symmetry. exact (Equivalence_property_exists p).
  - auto.
Qed.

Definition finType_cc (X: finType) (p: X -> Prop) (D: forall x, dec (p x)) : (exists x, p x) -> {x | p x}.
Proof.
  intro H.
  assert(exists x, x el (elem X) /\ p x) as E by firstorder.
  pose proof (list_cc D E) as [x G].
  now exists x.
Defined.

Definition pickx (X: finType): X + (X -> False).
Proof.
  destruct X as [X [enum ok]]. induction enum.
  - right. intro x. discriminate (ok x).
  - tauto.
Defined.

(* * Properties of decidable Propositions *)

Lemma DM_notAll (X: finType) (p: X -> Prop) (D:forall x, dec (p x)): (~ (forall x, p x)) <-> exists x, ~ (p x).
Proof.
  decide (exists x,~ p x); firstorder.
Qed.

Lemma DM_exists (X: finType) (p: X -> Prop) (D: forall x, dec (p x)):
  (exists x, p x) <->  ~(forall x, ~ p x).
Proof.
  split.
  - firstorder.
  - decide (exists x, p x); firstorder.
Qed.

(* Index is an injective function *)

Fixpoint  getPosition {E: eqType} (A: list E) x := match A with
                                                   | nil => 0
                                                   | cons x' A' => if Dec (x=x') then 0 else 1 + getPosition A' x end.

Lemma getPosition_correct {E: eqType} (x:E) A: if Dec (x el A) then forall z, (nth (getPosition A x) A z) = x else getPosition A x = |A |.
Proof.
  induction A;cbn.
  -repeat destruct Dec;tauto.
  -repeat destruct Dec;intuition; congruence.
Qed.

Lemma getPosition_nth (X:eqType) k (d :X) xs:
  Dupfree.dupfree xs ->
  k < length xs ->
  getPosition xs (nth k xs d) = k.
Proof.
  induction xs in k|-*. now cbn.
  intros H1 H2. inv H1.
  cbn. destruct k.
  -decide _. all:easy.
  -decide _.
   +subst a. cbn in H2. edestruct H3. eapply nth_In. lia.
   + cbn in H2. rewrite IHxs. all:try easy;lia.
Qed.

Definition pos_def (X : eqType) (x : X) A n :=  match pos x A with None => n | Some n => n end.

Definition index {F: finType} (x:F) := getPosition (elem F) x.

Lemma index_nth {F : finType} (x:F) y: nth (index x) (elem F) y = x.
Proof.
  unfold index, elem, enum.
  destruct F as [[X E] [A all_A]];cbn.
  pose proof (getPosition_correct x A) as H.
  destruct Dec. auto. apply notInZero in n. now setoid_rewrite all_A in n.
Qed.

Lemma injective_index (A: finType) (x1 x2 : A) : index x1 = index x2 -> x1 = x2.
Proof.
  destruct (elem A) eqn:E.
  - hnf. intros. assert (x1 el elem A) by eauto using elem_spec. rewrite E in H0. auto.
  - clear E. eapply (left_inv_inj (g := (fun y => nth y (elem A) e))).
    hnf. intros. now rewrite index_nth.
Qed.

Lemma index_le (A:finType) (x:A): index x < length (elem A).
Proof.
  unfold index.
  assert (H:x el elem A) by apply elem_spec.
  revert H.
  generalize (elem A). intros l H.
  induction l;cbn;[|decide _].
  -easy.
  -lia.
  -destruct H. congruence. apply IHl in H. lia.
Qed.

Lemma index_leq (A:finType) (x:A): index x <= length (elem A).
Proof.
  eapply Nat.lt_le_incl,index_le.
Qed.


(** Typeclass for decidable propositions *)

Require Import Coq.Logic.Eqdep_dec.
Require Import Crypto.Util.FixCoqMistakes.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.HProp.
Require Import Crypto.Util.Equality.
Require Import Coq.ZArith.BinInt.
Require Import Coq.NArith.BinNat.

Local Open Scope type_scope.

Class Decidable (P : Prop) := dec : {P} + {~P}.
Arguments dec _%type_scope {_}.

Notation DecidableRel R := (forall x y, Decidable (R x y)).

Global Instance hprop_eq_dec {A} `{DecidableRel (@eq A)} : IsHPropRel (@eq A) | 10.
Proof. repeat intro; apply UIP_dec; trivial with nocore. Qed.

Global Instance eq_dec_hprop {A} {x y : A} `{hp : IsHProp A} : Decidable (@eq A x y) | 5.
Proof. left; apply hp. Qed.

Ltac no_equalities_about x0 y0 :=
  lazymatch goal with
  | [ H' : x0 = y0 |- _ ] => fail
  | [ H' : y0 = x0 |- _ ] => fail
  | [ H' : x0 <> y0 |- _ ] => fail
  | [ H' : y0 <> x0 |- _ ] => fail
  | _ => idtac
  end.

Ltac destruct_decidable_step :=
  match goal with
  | [ H : Decidable _ |- _ ] => destruct H
  | [ H : forall x y : ?A, Decidable (x = y), x0 : ?A, y0 : ?A  |- _ ]
    => no_equalities_about x0 y0; destruct (H x0 y0)
  | [ H : forall a0 (x y : _), Decidable (x = y), x0 : ?A, y0 : ?A  |- _ ]
    => no_equalities_about x0 y0; destruct (H _ x0 y0)
  end.
Ltac destruct_decidable := repeat destruct_decidable_step.

Ltac pre_decide_destruct_sigma_step :=
  match goal with
  | [ H : sigT _ |- _ ] => destruct H
  | [ H : sig _ |- _ ] => destruct H
  | [ H : ex _ |- _ ] => destruct H
  end.
Ltac pre_decide_destruct_sigma := repeat pre_decide_destruct_sigma_step.

Ltac pre_decide :=
  repeat (intros
          || destruct_decidable
          || split
          || pre_decide_destruct_sigma
          || unfold Decidable in *
          || hnf).

(** Put the [subst] and reasoning about equalities after the [left]
    and [right]; opaque equality proofs should not block decidability
    proofs. *)
Ltac post_decide :=
  repeat (intros
          || subst
          || pre_hprop).

Ltac solve_decidable_transparent_with tac :=
  pre_decide;
  try solve [ left; abstract (post_decide; tac)
            | right; abstract (post_decide; tac)
            | decide equality; eauto with nocore ].

Ltac solve_decidable_transparent := solve_decidable_transparent_with firstorder.

Local Hint Extern 0 => solve [ solve_decidable_transparent ] : typeclass_instances.
Local Hint Extern 1 => progress inversion_sigma : core.

Global Instance dec_True : Decidable True | 10 := left I.
Global Instance dec_False : Decidable False | 10 := right (fun x => x).
Global Instance dec_or {A B} `{Decidable A, Decidable B} : Decidable (A \/ B) | 10. exact _. Defined.
Global Instance dec_and {A B} `{Decidable A, Decidable B} : Decidable (A /\ B) | 10. exact _. Defined.
Global Instance dec_impl {A B} `{Decidable (B \/ ~A)} : Decidable (A -> B) | 10. exact _. Defined.
Global Instance dec_impl_simple {A B} `{Decidable A, Decidable B} : Decidable (A -> B) | 10. exact _. Defined.
Global Instance dec_iff {A B} `{Decidable A, Decidable B} : Decidable (A <-> B) | 10. exact _. Defined.
Lemma dec_not {A} `{Decidable A} : Decidable (~A).
Proof. solve_decidable_transparent. Defined.
(** Disallow infinite loops of dec_not *)
Hint Extern 0 (Decidable (~?A)) => apply (@dec_not A) : typeclass_instances.

Global Instance dec_eq_unit : DecidableRel (@eq unit) | 10. exact _. Defined.
Global Instance dec_eq_bool : DecidableRel (@eq bool) | 10. exact _. Defined.
Global Instance dec_eq_Empty_set : DecidableRel (@eq Empty_set) | 10. exact _. Defined.
Global Instance dec_eq_prod {A B} `{DecidableRel (@eq A), DecidableRel (@eq B)} : DecidableRel (@eq (A * B)) | 10. exact _. Defined.
Global Instance dec_eq_option {A} `{DecidableRel (@eq A)} : DecidableRel (@eq (option A)) | 10. exact _. Defined.
Global Instance dec_eq_list {A} `{DecidableRel (@eq A)} : DecidableRel (@eq (list A)) | 10. exact _. Defined.
Global Instance dec_eq_sum {A B} `{DecidableRel (@eq A), DecidableRel (@eq B)} : DecidableRel (@eq (A + B)) | 10. exact _. Defined.
Global Instance dec_eq_sigT_hprop {A P} `{DecidableRel (@eq A), forall a : A, IsHProp (P a)} : DecidableRel (@eq (@sigT A P)) | 10. exact _. Defined.
Global Instance dec_eq_sig_hprop {A} {P : A -> Prop} `{DecidableRel (@eq A), forall a : A, IsHProp (P a)} : DecidableRel (@eq (@sig A P)) | 10. exact _. Defined.
Global Instance dec_eq_nat : DecidableRel (@eq nat) | 10. exact _. Defined.
Global Instance dec_eq_N : DecidableRel (@eq N) | 10 := N.eq_dec.
Global Instance dec_eq_Z : DecidableRel (@eq Z) | 10 := Z.eq_dec.

Lemma not_not P {d:Decidable P} : not (not P) <-> P.
Proof. destruct (dec P); intuition. Qed.

Global Instance dec_ex_forall_not T (P:T->Prop) {d:Decidable (exists b, P b)} : Decidable (forall b, ~ P b).
Proof.
  destruct (dec (~ exists b, P b)) as [Hd|Hd]; [left|right];
    [abstract eauto | abstract (rewrite not_not in Hd by eauto; destruct Hd; eauto) ].
Defined.

Lemma eqsig_eq {T} {U} {Udec:DecidableRel (@eq U)} (f g:T->U) (x x':T) pf pf' :
  (exist (fun x => f x = g x) x pf) = (exist (fun x => f x = g x) x' pf') <-> (x = x').
Proof. apply path_sig_hprop_iff; auto using UIP_dec, Udec. Qed.

Lemma Decidable_respects_iff A B (H : A <-> B) : (Decidable A -> Decidable B) * (Decidable B -> Decidable A).
Proof. solve_decidable_transparent. Defined.

Lemma Decidable_iff_to_impl A B (H : A <-> B) : Decidable A -> Decidable B.
Proof. solve_decidable_transparent. Defined.

Lemma Decidable_iff_to_flip_impl A B (H : A <-> B) : Decidable B -> Decidable A.
Proof. solve_decidable_transparent. Defined.

Lemma dec_of_semidec {P : Prop} (H : option P) (H_complete : H = None -> ~P) : Decidable P.
Proof. destruct H; [ left; assumption | right; apply H_complete, eq_refl ]. Defined.

Lemma dec_rel_of_semidec_rel {A} {R : A -> A -> Prop} (H : forall x y, option (R x y))
      (H_complete : forall x y, H x y = None -> ~R x y) : DecidableRel R.
Proof. eauto using dec_of_semidec. Defined.

Lemma dec_bool : forall {P} {Pdec:Decidable P}, (if dec P then true else false) = true -> P.
Proof. intros. destruct dec; solve [ auto | discriminate ]. Qed.

Ltac vm_decide := apply dec_bool; vm_compute; reflexivity.
Ltac lazy_decide := apply dec_bool; lazy; reflexivity.

Ltac vm_decide_no_check := apply dec_bool; vm_cast_no_check (eq_refl true).
Ltac lazy_decide_no_check := apply dec_bool; exact_no_check (eq_refl true).

(** For dubious compatibility with [eauto using]. *)
Hint Extern 2 (Decidable _) => progress unfold Decidable : typeclass_instances core.


(* File: Derivable.v  (last edited on 1/1/2000) (c) Klaus Weich  *)

From IPC Require Export Derivable_Def.

Lemma derivable_eq :
 forall (context context' : flist) (a a' : form),
 context = context' -> a = a' -> Derivable context a -> Derivable context' a'.
intros context context' a a' eq_context eq_a.
 rewrite eq_context.
 rewrite eq_a.
intros; assumption.
Qed.

Lemma derivable_subst :
 forall (i : Int) (g : form) (context : flist) (a : form),
 Derivable context a -> Derivable (subst_list i g context) (subst_form i g a).
intros i g context a der.
elim der; clear der.
intros t der.
elim der; clear der a t context.

intros context n a nth.
apply Derivable_Intro with (Var n).
apply ByAssumption.
apply subst_nth; assumption.

intros context t a der ih.
elim ih; clear ih.
intros t1 der1.
apply Derivable_Intro with (Efq t1 (subst_form i g a)).
apply ByAbsurdity; assumption.

intros context a t b der ih.
elim ih; clear ih.
intros t1 der1.
apply Derivable_Intro with (Abs (subst_form i g a) t1).
simpl in |- *.
apply ImpIntro; assumption.

intros context r s a b der_r ih_r der_s ih_s.
elim ih_r; clear ih_r.
intros r1 der_r1.
elim ih_s; clear ih_s.
intros s1 der_s1.
apply Derivable_Intro with (App (subst_form i g a) r1 s1).
apply ImpElim; assumption.

intros context r s a b der_r ih_r der_s ih_s.
elim ih_r; clear ih_r.
intros r1 der_r1.
elim ih_s; clear ih_s.
intros s1 der_s1.
apply Derivable_Intro with (Pair r1 s1).
simpl in |- *; apply AndFIntro; assumption.

intros context r a b der_r ih.
elim ih; clear ih; intros r1 der_r1.
apply Derivable_Intro with (PrL (subst_form i g b) r1).
apply AndFElimL; assumption.

intros context r a b der_r ih.
elim ih; clear ih; intros r1 der_r1.
apply Derivable_Intro with (PrR (subst_form i g a) r1).
apply AndFElimR; assumption.

intros context r a b der_r ih.
elim ih; clear ih; intros r1 der_r1.
apply Derivable_Intro with (OrFL r1 (subst_form i g b)).
simpl in |- *; apply OrFIntroL; assumption.

intros context r a b der_r ih.
elim ih; clear ih; intros r1 der_r1.
apply Derivable_Intro with (OrFR r1 (subst_form i g a)).
simpl in |- *; apply OrFIntroR; assumption.

intros context r s t a b c der_r ih_r der_s ih_s der_t ih_t.
elim ih_r; clear ih_r; intros r1 der_r1.
elim ih_s; clear ih_s; intros s1 der_s1.
elim ih_t; clear ih_t; intros t1 der_t1.
apply
 Derivable_Intro with (Cas (subst_form i g a) (subst_form i g b) r1 s1 t1).
apply OrFElim; assumption.

intros context r a b der_r ih_r.
elim ih_r; clear ih_r; intros r1 der_r1.
apply Derivable_Intro with (Shift r1).
simpl in |- *; apply ShiftIntro; assumption.
Qed.

Lemma snd_order_inst :
 forall (context : flist) (i : Int),
 Derivable context (Atom i) ->
 below_list context i -> forall b : form, Derivable context b.
intros context i der below b.
cut (subst_form i b (Atom i) = b).
intro eq_b.
 rewrite <- eq_b.
 rewrite <- (subst_list_below i b context).
apply derivable_subst; assumption.
assumption.
simpl in |- *.
apply equal_dec_refl.
Qed.

Lemma derivable_weak :
 forall (context : flist) (a b : form),
 Derivable context a -> Derivable (b :: context) a.
intros context a b der_a.
elim der_a; clear der_a.
intros t der_t.
apply Derivable_Intro with (Shift t).
apply ShiftIntro; assumption.
Qed.

Lemma derivable_weak_list :
 forall (context1 context2 : flist) (a : form),
 Derivable context1 a -> Derivable (context2 ++ context1) a.
intros context1 context2 a der1.
elim context2; clear context2.
assumption.
intros b context2 ih.
simpl in |- *; apply derivable_weak; assumption.
Qed.

Lemma derivable_cut_aux :
 forall (context : flist) (t : proof_term) (b : form),
 derives context t b ->
 forall (a : form) (l1 l2 : flist),
 context = l1 ++ a :: l2 -> Derivable fnil a -> Derivable (l1 ++ l2) b.
intros context t b der_t.
elim der_t; clear der_t context t b.

intros context n a nth b l1 l2 eq_context.
 rewrite eq_context in nth.
elim (inv_nth_app form n l1 (b :: l2) a nth); clear nth.
intros nth0 der_b.
apply Derivable_Intro with (Var n).
apply ByAssumption.
apply nth_app0; assumption.
clear n; intros n; case n; clear n.
intros nth_eq.
 rewrite (inv_nthO form b l2 a nth_eq).
intros der_a.
 rewrite (app_nil_end (l1 ++ l2)).
apply derivable_weak_list.
assumption.
intros n nth1 der_b.
apply Derivable_Intro with (Var (length l1 + n)).
apply ByAssumption.
apply nth_app1.
inversion_clear nth1; assumption.

intros context t a der_t ih b l1 l2 eq_context der_b.
elim (ih b l1 l2); try assumption.
intros t0 der_t0.
apply Derivable_Intro with (Efq t0 a).
apply ByAbsurdity; assumption.

intros context a t b der_t ih c l1 l2 eq_context der_c.
elim (ih c (a :: l1) l2); clear ih.
intros t0 der_t0.
apply Derivable_Intro with (Abs a t0).
apply ImpIntro; assumption.
 rewrite eq_context.
trivial.
assumption.

intros context r s a b der_r ih_r der_s ih_s c l1 l2 eq_context der_c.
elim (ih_r c l1 l2); clear ih_r; try assumption.
intros r0 der_r0.
elim (ih_s c l1 l2); clear ih_s; try assumption.
intros s0 der_s0.
apply Derivable_Intro with (App a r0 s0).
apply ImpElim; assumption.

intros context r s a b der_r ih_r der_s ih_s c l1 l2 eq_context der_c.
elim (ih_r c l1 l2); clear ih_r; try assumption.
intros r0 der_r0.
elim (ih_s c l1 l2); clear ih_s; try assumption.
intros s0 der_s0.
apply Derivable_Intro with (Pair r0 s0).
apply AndFIntro; assumption.

intros context r a b der_r ih_r c l1 l2 eq_context der_c.
elim (ih_r c l1 l2); clear ih_r; try assumption.
intros r0 der_r0.
apply Derivable_Intro with (PrL b r0).
apply AndFElimL; assumption.

intros context r a b der_r ih_r c l1 l2 eq_context der_c.
elim (ih_r c l1 l2); clear ih_r; try assumption.
intros r0 der_r0.
apply Derivable_Intro with (PrR a r0).
apply AndFElimR; assumption.

intros context r a b der_r ih_r c l1 l2 eq_context der_c.
elim (ih_r c l1 l2); clear ih_r; try assumption.
intros r0 der_r0.
apply Derivable_Intro with (OrFL r0 b).
apply OrFIntroL; assumption.

intros context r a b der_r ih_r c l1 l2 eq_context der_c.
elim (ih_r c l1 l2); clear ih_r; try assumption.
intros r0 der_r0.
apply Derivable_Intro with (OrFR r0 a).
apply OrFIntroR; assumption.

intros context r s t a b c der_r ih_r der_s ih_s der_t ih_t d l1 l2
 eq_context der_d; clear der_r der_s der_t.
elim (ih_r d l1 l2); try assumption; clear ih_r.
intros r0 der_r0.
elim (ih_s d (a :: l1) l2); clear ih_s.
intros s0 der_s0.
elim (ih_t d (b :: l1) l2); clear ih_t.
intros t0 der_t0.
apply Derivable_Intro with (Cas a b r0 s0 t0).
apply OrFElim; assumption.
 rewrite eq_context; trivial.
assumption.
 rewrite eq_context; trivial.
assumption.

intros context r a b der_r ih_r c l1.
case l1; clear l1.
simpl in |- *; intros l2 eq_context der_c.
apply Derivable_Intro with r.
 injection eq_context; intros H1 H2.
 rewrite <- H1; assumption.
simpl in |- *; intros d l1 l2 eq_context der_c.
elim (ih_r c l1 l2); clear ih_r; try assumption.
intros r0 der_r0.
apply derivable_weak.
apply Derivable_Intro with r0; assumption.

 injection eq_context.
intros; assumption.
Qed.

Lemma derivable_cut :
 forall (context : flist) (a b : form),
 Derivable fnil a -> Derivable (a :: context) b -> Derivable context b.
intros context a b der_a der_b.
elim der_b; clear der_b.
intros t der_b.
apply (derivable_cut_aux (a :: context) t b der_b a fnil context).
trivial.
assumption.
Qed.

Lemma derivable_cut_merge :
 forall (context : flist) (a b : form),
 Derivable context a -> Derivable (a :: context) b -> Derivable context b.
intros context; elim context; clear context.

intros; apply derivable_cut with a; assumption.

intros c context ih a b der_a der_b.
elim (ih (Imp c a) (Imp c b)); clear ih.
intros t der_t.
apply Derivable_Intro with (App c (Shift t) (Var 0)).
apply ImpElim.
apply ShiftIntro; assumption.
apply ByAssumption.
apply My_NthO.
elim der_a; clear der_a; intros t der_t.
apply Derivable_Intro with (Abs c t).
apply ImpIntro; assumption.
elim der_b; clear der_b; intros t der_t.
apply
 Derivable_Intro
  with
    (Abs c
       (App a (App c (Shift (Shift (Abs c (Abs a t)))) (Var 0))
          (App c (Var 1) (Var 0)))).
apply ImpIntro.
apply ImpElim.
apply ImpElim.
apply ShiftIntro.
apply ShiftIntro.
apply ImpIntro.
apply ImpIntro.
assumption.
apply ByAssumption.
apply My_NthO.
apply ImpElim.
apply ByAssumption.
apply My_NthS.
apply My_NthO.
apply ByAssumption.
apply My_NthO.
Qed.

(************************************************************************)

Lemma derivable_a_imp_a : forall a : form, Derivable fnil (Imp a a).
intros a.
apply Derivable_Intro with (Abs a (Var 0)).
apply ImpIntro.
apply ByAssumption.
apply My_NthO.
Qed.

Lemma derivable_a_and_b__derivable_a :
 forall (a b : form) (context : flist),
 Derivable context (AndF a b) -> Derivable context a.
intros a b context der.
elim der; clear der.
intros t der_t.
apply Derivable_Intro with (PrL b t).
apply AndFElimL; assumption.
Qed.

Lemma derivable_a_and_b__derivable_b :
 forall (a b : form) (context : flist),
 Derivable context (AndF a b) -> Derivable context b.
intros a b context der.
elim der; clear der.
intros t der_t.
apply Derivable_Intro with (PrR a t).
apply AndFElimR; assumption.
Qed.

Lemma derivable_falsum_or_a__derivable_a :
 forall (a : form) (context : flist),
 Derivable context (OrF Falsum a) -> Derivable context a.
intros a context der.
elim der; clear der.
intros t der_t.
apply Derivable_Intro with (Cas Falsum a t (Efq (Var 0) a) (Var 0)).
apply OrFElim.
assumption.
apply ByAbsurdity.
apply ByAssumption.
apply My_NthO.
apply ByAssumption.
apply My_NthO.
Qed.

Lemma derivable_a_or_falsum__derivable_a :
 forall (a : form) (context : flist),
 Derivable context (OrF a Falsum) -> Derivable context a.
intros a context der.
elim der; clear der.
intros t der_t.
apply Derivable_Intro with (Cas a Falsum t (Var 0) (Efq (Var 0) a)).
apply OrFElim.
assumption.
apply ByAssumption.
apply My_NthO.
apply ByAbsurdity.
apply ByAssumption.
apply My_NthO.
Qed.

Lemma derivable_a_imp_falsum_or_b__derivable_a_imp_b :
 forall (context : flist) (a b : form),
 Derivable context (Imp a (OrF Falsum b)) -> Derivable context (Imp a b).
intros context a b der.
elim der; clear der.
intros t der_t.
apply
 Derivable_Intro
  with
    (Abs a (Cas Falsum b (App a (Shift t) (Var 0)) (Efq (Var 0) b) (Var 0))).
apply ImpIntro.
apply OrFElim.
apply ImpElim.
apply ShiftIntro; assumption.
apply ByAssumption; apply My_NthO.
apply ByAbsurdity.
apply ByAssumption; apply My_NthO.
apply ByAssumption; apply My_NthO.
Qed.

Lemma derivable_a_imp_b_or_falsum__derivable_a_imp_b :
 forall (context : flist) (a b : form),
 Derivable context (Imp a (OrF b Falsum)) -> Derivable context (Imp a b).
intros context a b der.
elim der; clear der.
intros t der_t.
apply
 Derivable_Intro
  with
    (Abs a (Cas b Falsum (App a (Shift t) (Var 0)) (Var 0) (Efq (Var 0) b))).
apply ImpIntro.
apply OrFElim.
apply ImpElim.
apply ShiftIntro; assumption.
apply ByAssumption; apply My_NthO.
apply ByAssumption; apply My_NthO.
apply ByAbsurdity.
apply ByAssumption; apply My_NthO.
Qed.

Lemma derivable_a0_and_a1_imp_b__derivable_a0_imp_a1_imp_b :
 forall (a0 a1 b : form) (context : flist),
 Derivable context (Imp (AndF a0 a1) b) ->
 Derivable context (Imp a0 (Imp a1 b)).
intros a0 a1 b context der.
elim der; clear der.
intros t der.
apply
 Derivable_Intro
  with
    (Abs a0
       (Abs a1 (App (AndF a0 a1) (Shift (Shift t)) (Pair (Var 1) (Var 0))))).
apply ImpIntro.
apply ImpIntro.
apply ImpElim.
apply ShiftIntro.
apply ShiftIntro.
assumption.
apply AndFIntro.
apply ByAssumption.
apply My_NthS; apply My_NthO.
apply ByAssumption.
apply My_NthO.
Qed.

Lemma derivable_a0_or_a1_imp_b__derivable_a0_imp_b :
 forall (context : flist) (a0 a1 b : form),
 Derivable context (Imp (OrF a0 a1) b) -> Derivable context (Imp a0 b).
intros context a0 a1 b der.
elim der; clear der.
intros t der_t.
apply
 Derivable_Intro with (Abs a0 (App (OrF a0 a1) (Shift t) (OrFL (Var 0) a1))).
apply ImpIntro.
apply ImpElim.
apply ShiftIntro; assumption.
apply OrFIntroL.
apply ByAssumption; apply My_NthO.
Qed.

Lemma derivable_a0_or_a1_imp_b__derivable_a1_imp_b :
 forall (context : flist) (a0 a1 b : form),
 Derivable context (Imp (OrF a0 a1) b) -> Derivable context (Imp a1 b).
intros context a0 a1 b der.
elim der; clear der.
intros t der_t.
apply
 Derivable_Intro with (Abs a1 (App (OrF a0 a1) (Shift t) (OrFR (Var 0) a0))).
apply ImpIntro.
apply ImpElim.
apply ShiftIntro; assumption.
apply OrFIntroR.
apply ByAssumption; apply My_NthO.
Qed.

Lemma derivable_falsum_imp_b_imp_c__derivable_c :
 forall (context : flist) (b c : form),
 Derivable context (Imp (Imp Falsum b) c) -> Derivable context c.
intros context b c der.
elim der; clear der.
intros t der_t.
apply
 Derivable_Intro with (App (Imp Falsum b) t (Abs Falsum (Efq (Var 0) b))).
apply ImpElim.
assumption.
apply ImpIntro.
apply ByAbsurdity.
apply ByAssumption; apply My_NthO.
Qed.

Lemma derivable_b__derivable_a_imp_b :
 forall (a b : form) (context : flist),
 Derivable context b -> Derivable context (Imp a b).
intros a b context der.
elim der; clear der.
intros t der_t.
apply Derivable_Intro with (Abs a (Shift t)).
apply ImpIntro.
apply ShiftIntro; assumption.
Qed.

Lemma derivable_a_a_imp_b__derivable_b :
 forall (a b : form) (context : flist),
 Derivable context a -> Derivable context (Imp a b) -> Derivable context b.
intros a b context der_a der_ab.
elim der_a; clear der_a.
intros t der_t.
elim der_ab; clear der_ab.
intros s der_s.
apply Derivable_Intro with (App a s t).
apply ImpElim; assumption.
Qed.

Lemma derivable_a_context_b__derivable_a_imp_b :
 forall (a b : form) (context : flist),
 Derivable (a :: context) b -> Derivable context (Imp a b).
intros a b context der.
elim der; clear der.
intros t der_t.
apply Derivable_Intro with (Abs a t).
apply ImpIntro; assumption.
Qed.

Lemma derivable_vimp :
 forall (context : flist) (l : list Int) (a b : form),
 (forall context : flist, Derivable context a -> Derivable context b) ->
 Derivable context (vimp l a) -> Derivable context (vimp l b).
intros context l.
elim l; clear l.
intros a b der_ab der_a.
apply der_ab; assumption.
simpl in |- *; intros i l ih a b der_ab der_a.
apply ih with (a := Imp (Atom i) a); try assumption.
intros context' der_ia.
elim der_ia; clear der_ia; intros t der_ia.
elim (der_ab (Atom i :: context')).
intros s der_b.
apply Derivable_Intro with (Abs (Atom i) s).
apply ImpIntro; assumption.
apply Derivable_Intro with (App (Atom i) (Shift t) (Var 0)).
apply ImpElim.
apply ShiftIntro; assumption.
apply ByAssumption.
apply My_NthO.
Qed.

Lemma derivable_vimp2 :
 forall (context : flist) (l : list Int) (a b c : form),
 (forall context : flist,
  Derivable context a -> Derivable context b -> Derivable context c) ->
 Derivable context (vimp l a) ->
 Derivable context (vimp l b) -> Derivable context (vimp l c).
intros context l.
elim l; clear l.
intros a b c der_abc der_a der_b.
apply der_abc; assumption.
simpl in |- *; intros i l ih a b c der_abc der_a der_b.
apply ih with (a := Imp (Atom i) a) (b := Imp (Atom i) b); try assumption.
clear ih.
intros context' der_ia der_ib.
elim der_ia; clear der_ia; intros t der_ia.
elim der_ib; clear der_ib; intros s der_ib.
elim (der_abc (Atom i :: context')).
intros r der_r.
apply Derivable_Intro with (Abs (Atom i) r).
apply ImpIntro; assumption.
apply Derivable_Intro with (App (Atom i) (Shift t) (Var 0)).
apply ImpElim.
apply ShiftIntro; assumption.
apply ByAssumption.
apply My_NthO.
apply Derivable_Intro with (App (Atom i) (Shift s) (Var 0)).
apply ImpElim.
apply ShiftIntro; assumption.
apply ByAssumption.
apply My_NthO.
Qed.

Lemma derivable_vimp0 :
 forall (context : flist) (l : list Int) (a : form),
 (forall context : flist, Derivable context a) ->
 Derivable context (vimp l a).
intros context l.
elim l; clear l.
intros a der_a.
apply der_a; assumption.
simpl in |- *; intros i l ih a der_a.
apply ih.
intros context'.
elim der_a with (Atom i :: context'); clear der_a; intros t der_a.
apply Derivable_Intro with (Abs (Atom i) t).
apply ImpIntro; assumption.
Qed.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* This is all of the LN infrastructure packed in a module for types. *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax.

(* Substituting a type into a type for a type variable. *)

Module T. (* T = Types *)
Fixpoint subst  (tau : Tau) (alpha : var) (t : Tau) {struct t} : Tau :=
  match t with
    | btvar i      => btvar i
    | ftvar beta   => If (alpha = beta) then tau else (ftvar beta)
    | cint         => cint
    | cross t0 t1  => cross (subst tau alpha t0) (subst tau alpha t1)
    | arrow t0 t1  => arrow (subst tau alpha t0) (subst tau alpha t1)
    | ptype t0     => ptype (subst tau alpha t0)
    | utype k t0   => utype k (subst tau alpha t0)
    | etype p k t0 => etype p k (subst tau alpha t0)
end.

Hint Resolve subst.

Notation "[ t 'T>' alpha ] tm" := (subst t alpha tm) (at level 68) : cyclone_scope.

Fixpoint open_rec  (k : nat) (t : Tau) (tau : Tau)  {struct tau}  : Tau :=
 match tau with
   | btvar i       => If k = i then t else btvar i
   | ftvar i       => ftvar i
   | cint          => cint
   | cross t0 t1   => cross (open_rec k t t0) (open_rec k t t1)
   | arrow t0 t1   => arrow (open_rec k t t0) (open_rec k t t1)
   | ptype t0      => ptype (open_rec k t t0)
   | utype kp t0   => utype kp (open_rec (S k) t t0)
   | etype p kp t0 => etype p kp (open_rec (S k) t t0)
  end.

Definition open t tau := open_rec 0 t tau.

Notation "{ k T> u } t" := (open_rec k u t)        (at level 67) : cyclone_scope.
Notation "t 'T^^' u"    := (open u t)              (at level 67) : cyclone_scope.
Notation "t 'T^' alpha" := (open (ftvar alpha) t)  (at level 67) : cyclone_scope.

(** Closing a type. *)

Fixpoint close_rec (k : nat) (v : var) (t : Tau) : Tau :=
  match t with
    | btvar i       => t
    | ftvar x       => If x = v then (btvar k) else t
    | cint          => cint
    | cross t0 t1   => cross (close_rec k v t0) (close_rec k v t1)
    | arrow t0 t1   => arrow (close_rec k v t0) (close_rec k v t1)
    | ptype t0      => ptype (close_rec k v t0)
    | utype k' t0   => utype k' (close_rec (S k) v t0)
    | etype p k' t0 => etype p k' (close_rec (S k) v t0)
end.

Definition close v t := close_rec 0 v t.

Notation "{ k <T u } t" := (close_rec k u t) (at level 67) : cyclone_scope.

(* Free variables of types. *)

Fixpoint fv (tau : Tau) {struct tau} : vars :=
 match tau with
    | btvar i      => \{}
    | ftvar x      => \{x}
    | cint         => \{}
    | cross t0 t1  => (fv t0) \u (fv t1)
    | arrow t0 t1  => (fv t0) \u (fv t1)
    | ptype t0     => (fv t0)
    | utype k t0   => (fv t0)
    | etype _ _ t0 => (fv t0)
end.

Hint Extern 1 (_ \notin fv _) => simpl; notin_solve.

Definition closed t := fv t = \{}.

Fixpoint size (tau : Tau) {struct tau} : nat :=
  match tau with
    | btvar i      => 1
    | ftvar x      => 1
    | cint         => 1
    | cross t0 t1  => 1 + (size t0) + (size t1)
    | arrow t0 t1  => 1 + (size t0) + (size t1)
    | ptype t0     => 1 + (size t0)
    | utype k t0   => 1 + (size t0)
    | etype p k t0 => 1 + (size t0)
  end.

(* Is a type locally closed? *)

Inductive lc : Tau -> Prop :=
 | lc_ftvar : forall x, lc (ftvar x)
 | lc_cint  : lc cint
 | lc_cross : forall t0 t1, lc t0 -> lc t1 -> lc (cross t0 t1)
 | lc_arrow : forall t0 t1, lc t0 -> lc t1 -> lc (arrow t0 t1)
 | lc_ptype : forall t0, lc t0 -> lc (ptype t0)
 | lc_utype : forall L' t0 k,
                    (forall (alpha : var) , alpha \notin L' ->
                       lc (open_rec 0 (ftvar alpha) t0)) ->
                    lc (utype k t0)
 | lc_etype : forall L' t0 p k,
                  (forall (alpha : var), alpha \notin L' ->
                  lc (open_rec 0 (ftvar alpha) t0)) ->
                  lc (etype p k t0).

Definition body t :=
  exists L, forall alpha, alpha \notin L -> lc (open (ftvar alpha) t).

Hint Constructors lc.

(* Tactics for building L, our finite set for cofinite induction. *)
(* One bad consequence of this is having to triple the gather_vars/pick_fresh
 tacticals. *)

(* TODO this will have to be upgraded with functions. *)

Ltac gather_vars :=
  let A' := gather_vars_with (fun x : vars => x) in
  let B' := gather_vars_with (fun x : var  => \{x}) in
  let C' := gather_vars_with (fun x : Tau => fv x) in
  constr:(A' \u (B' \u C')).

Ltac pick_fresh X :=
  let L := gather_vars in (pick_fresh_gen L X).

Tactic Notation "pick_fresh" ident(x) :=
  let L := gather_vars in pick_fresh_gen (L) x.

Tactic Notation "pick_fresh" ident(x) "from" constr(E) :=
  let L := gather_vars in pick_fresh_gen (L \u E) x.

Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base T gather_vars ltac_no_arg.

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto_star.

Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; auto_star.

Tactic Notation "exists_fresh" :=
  let y := fresh "y" in let Fry := fresh "Fr" y in
  exists_fresh_gen gather_vars y Fry.
End T.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
Proof.  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    *
      rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_Cons.
      induction l.
      - rewrite IHx1. reflexivity.
      -
        rewrite 3 drop_Nil. reflexivity.
    * simpl. rewrite 2 drop_Nil. reflexivity.
  + intros. simpl. destruct (drop x1 l); reflexivity.
  + intros. simpl. destruct (drop x2 l); reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  +
    rewrite 2 drop_Cons_assoc. reflexivity.
  +
 lfind. Admitted.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj25eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus Zero lv0))).
Admitted.
QuickChick conj25eqsynthconj4.


Require Import Bool.
Require Import Metalib.Metatheory.
Require Import List.
Require Import syntaxb_ott.

Inductive exp : Set :=  (*r expressions *)
 | e_var_b (_:nat) (*r variables *)
 | e_var_f (x:var) (*r variables *)
 | e_lit (i5:i) (*r lit *)
 | e_abs (A:typ) (e:exp) (B:typ) (*r abstractions *)
 | e_app (e1:exp) (e2:exp) (*r applications *)
 | e_anno (e:exp) (A:typ) (*r annotation *)
 | e_add : exp (*r addition *)
 | e_addl (i5:i) (*r addl *).

Inductive dirflag : Set :=  (*r checking direction *)
 | Inf : dirflag
 | Chk : dirflag.

Definition ctx : Set := list ( atom * typ ).

Definition ls : Set := list st.

(** opening up abstractions *)
Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (e_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => e_var_b nat
        | inleft (right _) => e_5
        | inright _ => e_var_b (nat - 1)
      end
  | (e_var_f x) => e_var_f x
  | (e_lit i5) => e_lit i5
  | (e_abs A e B) => e_abs A (open_exp_wrt_exp_rec (S k) e_5 e) B
  | (e_app e1 e2) => e_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_anno e A) => e_anno (open_exp_wrt_exp_rec k e_5 e) A
  | e_add => e_add
  | (e_addl i5) => e_addl i5
end.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:var),
     (lc_exp (e_var_f x))
 | lc_e_lit : forall (i5:i),
     (lc_exp (e_lit i5))
 | lc_e_abs : forall (A:typ) (e:exp) (B:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_abs A e B))
 | lc_e_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_app e1 e2))
 | lc_e_anno : forall (e:exp) (A:typ),
     (lc_exp e) ->
     (lc_exp (e_anno e A))
 | lc_e_add :
     (lc_exp e_add)
 | lc_e_addl : forall (i5:i),
     (lc_exp (e_addl i5)).
(** free variables *)
Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x) => {{x}}
  | (e_lit i5) => {}
  | (e_abs A e B) => (fv_exp e)
  | (e_app e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_anno e A) => (fv_exp e)
  | e_add => {}
  | (e_addl i5) => {}
end.

(** substitutions *)
Fixpoint subst_exp (e_5:exp) (x5:var) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => (if eq_var x x5 then e_5 else (e_var_f x))
  | (e_lit i5) => e_lit i5
  | (e_abs A e B) => e_abs A (subst_exp e_5 x5 e) B
  | (e_app e1 e2) => e_app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_anno e A) => e_anno (subst_exp e_5 x5 e) A
  | e_add => e_add
  | (e_addl i5) => e_addl i5
end.

(* principal types for values*)
Fixpoint principal_type (v:exp) : typ :=
  match v with
  | (e_lit i5) => t_int
  | (e_abs A e B) => (t_arrow A B)
  | (e_anno e A) => A
  | (e_add) => (t_arrow t_int (t_arrow t_int t_int))
  | (e_addl i5) => (t_arrow t_int t_int)
  | _ => t_dyn
  end.

(* defns Values *)
Inductive value : exp -> Prop :=    (* defn value *)
 | value_lit : forall (i5:i),
     value (e_lit i5)
 | value_add :
     value e_add
 | value_addl : forall (i5:i),
     value  ( (e_addl i5) )
 | value_anno : forall (A:typ) (e:exp) (B:typ),
     lc_exp (e_abs A e B) ->
     value (e_abs A e B)
 | value_fanno : forall (v:exp) (A B C D:typ),
     value v ->
      (t_arrow C D)  =   (principal_type   ( v )  )   ->
     value (e_anno v (t_arrow A B))
 | value_dyn : forall (v:exp),
     Ground   (principal_type  v )   ->
     value v ->
     value  ( (e_anno v t_dyn) ) .

Definition FLike A := not (A = t_dyn) /\ not (A = (t_arrow t_dyn t_dyn)) /\ (sim A (t_arrow t_dyn t_dyn)).

(* defns Typing *)
Inductive Typing : ctx -> exp -> dirflag -> typ -> Prop :=    (* defn Typing *)
 | Typ_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     Typing G (e_lit i5) Inf t_int
 | Typ_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     Typing G (e_var_f x) Inf A
 | Typ_abs : forall (L:vars) (G:ctx) (A:typ) (e:exp) (B:typ),
      ( forall x , x \notin  L  -> Typing  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk B )  ->
     Typing G (e_abs A e B) Inf (t_arrow A B)
 | Typ_app : forall (G:ctx) (e1 e2:exp) (B A:typ),
     Typing G e1 Inf (t_arrow A B) ->
     Typing G e2 Chk A ->
     Typing G (e_app e1 e2) Inf B
 | Typ_add : forall (G:ctx),
     uniq  G  ->
     Typing G e_add Inf (t_arrow t_int  (t_arrow t_int t_int) )
 | Typ_addl : forall (G:ctx) (i1:i),
     uniq  G  ->
     Typing G (e_addl i1) Inf (t_arrow t_int t_int)
 | Typ_anno : forall (G:ctx) (e:exp) (A:typ),
     Typing G e Chk A ->
     Typing G  ( (e_anno e A) )  Inf A
 | Typ_sim : forall (G:ctx) (e:exp) (B A:typ),
     Typing G e Inf A ->
     sim A B ->
     Typing G e Chk B.

Inductive ttyping : ctx -> exp -> dirflag -> typ -> term -> Prop :=    (* defn Typing *)
 | ttyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     ttyping G (e_lit i5) Inf t_int (trm_lit i5)
 | ttyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     ttyping G (e_var_f x) Inf A (trm_var_f x)
 | ttyp_abs : forall (L:vars) (G:ctx) (A:typ) (e:exp) (B:typ) (t:term),
      ( forall x , x \notin  L  -> ttyping  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk B ( open_term_wrt_term t (trm_var_f x) ))  ->
     ttyping G (e_abs A e B) Inf (t_arrow A B) (trm_abs A t)
 | ttyp_app : forall (G:ctx) (e1 e2:exp) (B A:typ) (t1 t2:term),
     ttyping G e1 Inf (t_arrow A B) t1 ->
     ttyping G e2 Chk A t2 ->
     ttyping G (e_app e1 e2) Inf B (trm_app t1 t2)
 | ttyp_add : forall (G:ctx),
      uniq  G  ->
     ttyping G e_add Inf (t_arrow t_int  (t_arrow t_int t_int) ) trm_add
 | ttyp_addl : forall (G:ctx) (i1:i),
      uniq  G  ->
     ttyping G (e_addl i1) Inf (t_arrow t_int t_int) (trm_addl i1)
 | ttyp_anno : forall (G:ctx) (e:exp) (A:typ) (t:term),
     ttyping G e Chk A t ->
     ttyping G  ( (e_anno e A) )  Inf A t
 | ttyp_sim : forall (G:ctx) (e:exp) (B A:typ) (t:term),
     ttyping G e Inf A t ->
     sim A B ->
     ttyping G e Chk B (trm_cast t A B).

Inductive ctx_item : Type :=
     | appCtxL : exp -> ctx_item
     | appCtxR : exp -> ctx_item
     | annoCtx : typ -> ctx_item.

Inductive wellformed : ctx_item -> Prop :=
     | wf_appCtxL : forall (e : exp),
                   lc_exp e ->
                    wellformed (appCtxL e)
     | wf_appCtxR : forall (v : exp),
                    value v ->
                    wellformed (appCtxR v)
     | wf_annoCtx : forall (A : typ),
                    wellformed (annoCtx A).

Definition fill (E : ctx_item) (e : exp) : exp :=
     match E with
     | appCtxL e2 => e_app e e2
     | appCtxR v1 => e_app v1 e
     | annoCtx A => e_anno e A
     end.

Inductive res : Type :=
     | e_exp  : exp -> res
     | e_blame : res.

(* defns Semantics *)
Inductive TypedReduce : exp -> typ -> res -> Prop :=    (* defn TypedReduce *)
 | TReduce_abs: forall v A B C D,
   sim (t_arrow C D) (t_arrow A B) ->
   principal_type v = (t_arrow C D) ->
   TypedReduce v (t_arrow A B) (e_exp (e_anno v (t_arrow A B)))
  | TReduce_v : forall (v:exp),
   Ground(principal_type v) ->
   TypedReduce v t_dyn (e_exp (e_anno v t_dyn))
 | TReduce_lit : forall (i5:i),
     TypedReduce (e_lit i5) t_int (e_exp (e_lit i5))
 | TReduce_dd : forall (v:exp),
     lc_exp v ->
     TypedReduce  ( (e_anno v t_dyn) )  t_dyn  (e_exp  (e_anno v t_dyn) )
 | TReduce_anyd : forall (v:exp),
      FLike (principal_type  v )  ->
     TypedReduce v t_dyn  (e_exp (e_anno  ( (e_anno v (t_arrow t_dyn t_dyn)) )  t_dyn) )
 | TReduce_dyna : forall (v:exp) (A:typ),
      FLike A ->
     sim (principal_type v) A ->
    TypedReduce  ( (e_anno v t_dyn) )  A  (e_exp (e_anno v A) )
 | TReduce_vany : forall (v:exp),
   TypedReduce (e_anno v t_dyn) (principal_type  v) (e_exp v)
 | TReduce_blame : forall (v:exp) (A:typ),
      not (sim A (principal_type  v ))  ->
     TypedReduce (e_anno v t_dyn) A e_blame.

Inductive step : exp -> res -> Prop :=    (* defn step *)
  | do_step E e1 e2 :
       wellformed E ->
       step e1 (e_exp e2 ) ->
      step (fill E e1) (e_exp (fill E e2))
  | blame_step E e1:
      wellformed E ->
      step e1 e_blame ->
      step (fill E e1) e_blame
 | Step_beta : forall (A:typ) (e:exp) (B:typ) (v v' : exp),
    lc_exp (e_abs A e B) ->
    value v ->
    TypedReduce v A (e_exp v') ->
    step (e_app  ( (e_abs A e B) )  v)  (e_exp (e_anno  (  (open_exp_wrt_exp  e v' )  )  B) )
 | Step_betap : forall (A:typ) (e:exp) (B:typ) (v v':exp),
    lc_exp (e_abs A e B) ->
    value v ->
    TypedReduce v A e_blame ->
    step (e_app  ( (e_abs A e B) )  v)  e_blame
 | Step_annov : forall (v:exp) (A:typ) (v':res),
     value v ->
     TypedReduce v A v' ->
     not (value (e_anno v A)) ->
     step (e_anno v A) v'
 | Step_add : forall (v1:exp) (i1:i),
     value v1 ->
     TypedReduce v1 t_int (e_exp (e_lit i1)) ->
     step (e_app e_add v1) (e_exp (e_addl i1))
 | Step_addp : forall (v1:exp),
     value v1 ->
     TypedReduce v1 t_int e_blame ->
     step (e_app e_add v1) e_blame
 | Step_addl : forall (i1:i) (v2:exp) (i2:i),
     value v2 ->
     TypedReduce v2 t_int (e_exp (e_lit i2)) ->
     step (e_app  ( (e_addl i1) )  v2)  (e_exp (e_lit ( i1  +  i2 )))
 | Step_addlp : forall (i1:i) (v2:exp),
     value v2 ->
     TypedReduce v2 t_int e_blame ->
     step (e_app  ( (e_addl i1) )  v2)  e_blame
 | Step_abeta : forall (v1:exp) (A B:typ) (v2 v2':exp),
     value  ( (e_anno v1 (t_arrow A B)) )  ->
     TypedReduce v2 A (e_exp v2') ->
     value v2 ->
     step (e_app  ( (e_anno v1 (t_arrow A B)) )  v2) (e_exp (e_anno  ( (e_app v1 v2') )  B))
 | Step_abetap : forall (v1:exp) (A B:typ) (v2 v2':exp),
     value  ( (e_anno v1 (t_arrow A B)) )  ->
     TypedReduce v2 A e_blame ->
     value v2 ->
     step (e_app  ( (e_anno v1 (t_arrow A B)) )  v2) e_blame.

Inductive steps : exp -> res -> Prop :=
  | step_refl e:
    steps e (e_exp e)

  | step_n e t' e':
    step e (e_exp e') ->
    steps e' (e_exp t') ->
    steps e  (e_exp t')

  | step_nb e e':
    step e (e_exp e') ->
    steps e' e_blame ->
    steps e  e_blame

  | step_b e:
    step e (e_blame) ->
    steps e (e_blame).

(** infrastructure *)
Hint Constructors Ground value sim TypedReduce step steps wellformed Typing ttyping lc_exp : core.