(** ** Operations & Properties of FOL* *)

From Equations Require Import Equations.
Require Import Equations.Prop.DepElim.
From FOL Require Export DecidableEnumerable.
From FOL Require Export Syntax.
Require Export Lia.
Import Vector.

(* **** Notation *)

Notation "phi --> psi" := (Impl phi psi) (right associativity, at level 55).
Notation "∀ phi" := (All phi) (at level 56, right associativity).
Notation "⊥" := (Fal).
Notation "¬ phi" := (phi --> ⊥) (at level 20).
Notation "∃ phi" := (¬ ∀ ¬ phi) (at level 56, right associativity).

Section FOL.
  Context {Sigma : Signature}.

  (* **** Subformula *)

  Inductive sf : form -> form -> Prop :=
  | SImplL phi psi : sf phi (phi --> psi)
  | SImplR phi psi : sf psi (phi --> psi)
  | SAll phi t : sf (phi [t .: ids]) (∀ phi).
  Hint Constructors sf.

  Lemma sf_acc phi rho :
    Acc sf (phi [rho]).
  Proof.
    revert rho; induction phi; intros rho; constructor; intros psi Hpsi; asimpl in *; inversion Hpsi;
      subst; asimpl in *; eauto.
  Qed.

  Lemma sf_well_founded :
    well_founded sf.
  Proof.
    intros phi. pose proof (sf_acc phi ids) as H. now asimpl in H.
  Qed.

  (* **** Formula size *)

  Fixpoint size (phi : form ) :=
    match phi with
    | Pred _ _ => 0
    | Fal => 0
    | Impl phi psi => S (size phi + size psi)
    | All phi => S (size phi)
    end.

  Lemma size_ind {X : Type} (f : X -> nat) (P : X -> Prop) :
    (forall x, (forall y, f y < f x -> P y) -> P x) -> forall x, P x.
  Proof.
    intros H x. apply H.
    induction (f x).
    - intros y. omega.
    - intros y. intros [] % le_lt_or_eq.
      + apply IHn; omega.
      + apply H. injection H0. now intros ->.
  Qed.

  Lemma subst_size rho phi :
    size (subst_form rho phi) = size phi.
  Proof.
    revert rho; induction phi; intros rho; cbn; asimpl; try congruence.
  Qed.

  Lemma form_ind_subst (P : form -> Prop) :
    P ⊥ -> (forall p v, P (Pred p v)) ->
    (forall phi psi, P phi -> P psi -> P (phi --> psi)) ->
    (forall phi, (forall t, P phi[t..]) -> P (∀ phi)) ->
    forall phi, P phi.
  Proof.
    intros H0 H1 H2 H3 phi.
    induction phi using (@size_ind _ size).
    destruct phi; trivial.
    - apply H2; apply H; cbn; lia.
    - apply H3. intros t. apply H.
      cbn. unfold subst1. rewrite subst_size. lia.
  Qed.

  (* **** Unused variable **)

  Inductive unused (n : nat) : form -> Prop :=
  | uf_Fal : unused n Fal
  | uf_Pred P v : (forall t, vec_in t v -> unused_term n t) -> unused n (Pred P v)
  | uf_Impl phi psi : unused n phi -> unused n psi -> unused n (Impl phi psi)
  | uf_All phi : unused (S n) phi -> unused n (All phi).

  Definition unused_L n A := forall phi, phi el A -> unused n phi.
  Definition closed phi := forall n, unused n phi.

  Lemma find_unused phi :
    { n | forall m, n <= m -> unused m phi }.
  Proof with eauto using unused.
    induction phi.
    - exists 0...
    - destruct (@vec_unused _ _ t) as [k H]. 1: eauto using find_unused_term. exists k. eauto using unused.
    - destruct IHphi1, IHphi2. exists (x + x0). intros m Hm. constructor; [ apply u | apply u0 ]; omega.
    - destruct IHphi. exists x. intros m Hm. constructor. apply u. omega.
  Qed.

  Lemma find_unused_L A :
    { n | forall m, n <= m -> unused_L m A }.
  Proof.
    induction A.
    - exists 0. unfold unused_L. cbn. intuition.
    - destruct IHA. destruct (find_unused a).
      exists (x + x0). intros m Hm. intros phi []; subst.
      + apply u0. omega.
      + apply u. omega. auto.
  Qed.

  Definition capture n phi := nat_rect _ phi (fun _ => All) n.

  Lemma capture_captures n m phi :
    (forall i, n <= i -> unused i phi) -> (forall i, n - m <= i -> unused i (capture m phi)).
  Proof.
    intros H. induction m; cbn; intros i Hi.
    - rewrite <- minus_n_O in *. intuition.
    - constructor. apply IHm. omega.
  Qed.

  Definition close phi := capture (proj1_sig (find_unused phi)) phi.

  Lemma close_closed phi :
    closed (close phi).
  Proof.
    intros n. unfold close. destruct (find_unused phi) as [m Hm]; cbn.
    apply (capture_captures Hm). omega.
  Qed.

  Fixpoint big_imp A phi :=
    match A with
    | List.nil => phi
    | a :: A' => a --> (big_imp A' phi)
    end.

  (* **** Substituting unused variables *)

  Definition shift_P P n :=
    match n with
    | O => False
    | S n' => P n'
    end.

  Lemma vec_map_ext X Y (f g : X -> Y) n (v : vector X n) :
    (forall x, vec_in x v -> f x = g x) -> map f v = map g v.
  Proof.
    intros Hext; induction v in Hext |-*; cbn.
    - reflexivity.
    - rewrite IHv, (Hext h). 1: reflexivity. all: eauto.
  Qed.

  Context {Funcs_eq_dec : eq_dec Funcs}.

  Lemma subst_unused_term xi sigma P t :
    (forall x, dec (P x)) -> (forall m, ~ P m -> xi m = sigma m) -> (forall m, P m -> unused_term m t) ->
    subst_term xi t = subst_term sigma t.
  Proof.
    intros Hdec Hext Hunused. induction t using strong_term_ind; cbn; asimpl.
    - destruct (Hdec x) as [H % Hunused | H % Hext].
      + inversion H; subst; congruence.
      + congruence.
    - f_equal. apply vec_map_ext. intros t H'. apply (H t H'). intros n H2 % Hunused. inv H2. eauto.
  Qed.

  Context {Preds_eq_dec : eq_dec Preds}.

  Lemma subst_unused_form xi sigma P phi :
    (forall x, dec (P x)) -> (forall m, ~ P m -> xi m = sigma m) -> (forall m, P m -> unused m phi) ->
    subst_form xi phi = subst_form sigma phi.
  Proof.
    induction phi in xi,sigma,P |-*; intros Hdec Hext Hunused; cbn; asimpl.
    - reflexivity.
    - f_equal. apply vec_map_ext. intros s H. apply (subst_unused_term Hdec Hext).
      intros m H' % Hunused. inv H'. eauto.
    - rewrite IHphi1 with (sigma := sigma) (P := P). rewrite IHphi2 with (sigma := sigma) (P := P).
      all: try tauto. all: intros m H % Hunused; now inversion H.
    - erewrite IHphi with (P := shift_P P). 1: reflexivity.
      + intros [| x]; [now right| now apply Hdec].
      + intros [| m]; [reflexivity|]. intros Heq % Hext; unfold ">>"; cbn; congruence.
      + intros [| m]; [destruct 1| ]. intros H % Hunused; now inversion H.
  Qed.

  Lemma subst_unused_single xi sigma n phi :
    unused n phi -> (forall m, n <> m -> xi m = sigma m) -> subst_form xi phi = subst_form sigma phi.
  Proof.
    intros Hext Hunused. apply subst_unused_form with (P := fun m => n = m). all: intuition.
    now subst.
  Qed.

  Lemma subst_unused_range xi sigma phi n :
    (forall m, n <= m -> unused m phi) -> (forall x, x < n -> xi x = sigma x) -> subst_form xi phi = subst_form sigma phi.
  Proof.
    intros Hle Hext. apply subst_unused_form with (P := fun x => n <= x); [apply le_dec| |assumption].
    intros ? ? % not_le; intuition.
  Qed.

  Lemma subst_unused_closed xi sigma phi :
    closed phi -> subst_form xi phi = subst_form sigma phi.
  Proof.
    intros Hcl. apply subst_unused_range with (n := 0); intuition. omega.
  Qed.

  Lemma subst_unused_closed' xi phi :
    closed phi -> subst_form xi phi = phi.
  Proof.
    intros Hcl. rewrite <- idSubst_form with (sigmaterm := ids).
    apply subst_unused_range with (n := 0). all: intuition; omega.
  Qed.

  Lemma vec_forall_map X Y (f : X -> Y) n (v : vector X n) (p : Y -> Type) :
    (forall x, vec_in x v -> p (f x)) -> forall y, vec_in y (map f v) -> p y.
  Proof.
    intros H y Hmap. induction v; cbn; inv Hmap; eauto.
  Qed.

  Lemma unused_after_subst_term t sigma y :
    (forall x, unused_term x t \/ unused_term y (sigma x)) -> unused_term y (subst_term sigma t).
  Proof.
    induction t using strong_term_ind; intros Hvars; asimpl.
    - destruct (Hvars x) as [H | H]; [inv H; congruence | assumption].
    - constructor. apply vec_forall_map. intros t H'. apply (H t H'). intros x. destruct (Hvars x). 2: tauto.
      left. inv H0. eauto.
  Qed.

  Lemma unused_after_subst phi sigma y :
    (forall x, unused x phi \/ unused_term y (sigma x)) -> unused y (subst_form sigma phi).
  Proof.
    intros Hvars. induction phi in Hvars, sigma, y |-*; asimpl; constructor.
    1: apply vec_forall_map; intros s H; apply unused_after_subst_term. 2: apply IHphi1. 3: apply IHphi2.
    1-3: intros x; destruct (Hvars x) as [H' | H']; [left; inv H'; eauto | tauto].
    apply IHphi. intros [].
    - right. cbn; constructor. congruence.
    - destruct (Hvars n). 1: left; now inv H. right. cbn. unfold ">>".
      apply unused_after_subst_term. intros x. decide (x = y).
      * subst. tauto.
      * right. constructor. unfold "↑". congruence.
  Qed.

  (* **** Theories *)

  Definition theory := form -> Prop.
  Definition contains phi (T : theory) := T phi.
  Definition contains_L (A : list form) (T : theory) := forall f, f el A -> contains f T.
  Definition subset_T (T1 T2 : theory) := forall (phi : form), contains phi T1 -> contains phi T2.
  Definition list_T A : theory := fun phi => phi el A.

  Infix "⊏" := contains_L (at level 20).
  Infix "⊑" := subset_T (at level 20).
  Infix "∈" := contains (at level 70).

  Hint Unfold contains.
  Hint Unfold contains_L.
  Hint Unfold subset_T.

  Global Instance subset_T_trans : Transitive subset_T.
  Proof.
    intros T1 T2 T3. intuition.
  Qed.

  Definition extend T (phi : form) := fun psi => T psi \/ psi = phi.
  Infix "⋄" := extend (at level 20).

  Definition closed_T (T : theory) := forall phi n, contains phi T -> unused n phi.
  Lemma closed_T_extend T phi :
    closed_T T -> closed phi -> closed_T (T ⋄ phi).
  Proof.
    intros ? ? ? ? []; subst; intuition.
  Qed.

  Section ContainsAutomation.
    Lemma contains_nil T :
      List.nil ⊏ T.
    Proof. intuition. Qed.

    Lemma contains_cons a A T :
      a ∈ T -> A ⊏ T -> (a :: A) ⊏ T.
    Proof. intros ? ? ? []; subst; intuition. Qed.

    Lemma contains_cons2 a A T :
      (a :: A) ⊏ T -> A ⊏ T.
    Proof. firstorder. Qed.

    Lemma contains_app A B T :
      A ⊏ T -> B ⊏ T -> (A ++ B) ⊏ T.
    Proof. intros ? ? ? [] % in_app_or; intuition. Qed.

    Lemma contains_extend1 phi T :
      phi ∈ (T ⋄ phi).
    Proof. now right. Qed.

    Lemma contains_extend2 phi psi T :
      phi ∈ T -> phi ∈ (T ⋄ psi).
    Proof. intros ?. now left. Qed.

    Lemma contains_extend3 A T phi :
      A ⊏ T -> A ⊏ (T ⋄ phi).
    Proof.
      intros ? ? ?. left. intuition.
    Qed.
  End ContainsAutomation.
End FOL.

Definition tmap {S1 S2 : Signature} (f : @form S1 -> @form S2) (T : @theory S1) : @theory S2 :=
  fun phi => exists psi, T psi /\ f psi = phi.

Lemma enum_tmap {S1 S2 : Signature} (f : @form S1 -> @form S2) (T : @theory S1) L :
  enum T L -> enum (tmap f T) (L >> List.map f).
Proof.
  intros []. split; unfold ">>".
  - intros n. destruct (H n) as [A ->]. exists (List.map f A). apply map_app.
  - intros x; split.
    + intros (phi & [m Hin] % H0 & <-). exists m. apply in_map_iff. firstorder.
    + intros (m & (phi & <- & Hphi) % in_map_iff). firstorder.
Qed.

Lemma tmap_contains_L {S1 S2 : Signature} (f : @form S1 -> @form S2) T A :
  contains_L A (tmap f T) -> exists B, A = List.map f B /\ contains_L B T.
Proof.
  induction A.
  - intros. now exists List.nil.
  - intros H. destruct IHA as (B & -> & HB). 1: firstorder.
    destruct (H a (or_introl eq_refl)) as (b & Hb & <-).
    exists (b :: B). split. 1: auto. intros ? []; subst; auto.
Qed.

Hint Constructors vec_in.

Infix "⊏" := contains_L (at level 20).
Infix "⊑" := subset_T (at level 20).
Infix "∈" := contains (at level 70).
Infix "⋄" := extend (at level 20).

Hint Resolve contains_nil contains_cons contains_cons2 contains_app : contains_theory.
Hint Resolve contains_extend1 contains_extend2 contains_extend3 : contains_theory.
Ltac use_theory A := exists A; split; [eauto 15 with contains_theory|].

(* **** Enumerability *)

Fixpoint vecs_from X (A : list X) (n : nat) : list (vector X n) :=
  match n with
  | 0 => [nil]
  | S n => [ cons x v | (x,  v) ∈ (A × vecs_from A n) ]
  end.

Lemma list_prod_in X Y (x : X * Y) A B :
  x el (A × B) -> exists a b, x = (a , b) /\ a el A /\ b el B.
Proof.
  induction A; cbn.
  - intros [].
  - intros [H | H] % in_app_or. 2: firstorder.
    apply in_map_iff in H as (y & <- & Hel). exists a, y. tauto.
Qed.

Lemma vecs_from_correct X (A : list X) (n : nat) (v : vector X n) :
  (forall x, vec_in x v -> x el A) <-> v el vecs_from A n.
Proof.
  induction n; cbn.
  - split.
    + intros. left. now dependent destruction v.
    + intros [<- | []] x H. inv H.
  - split.
    + intros. dependent destruction v. in_collect (pair h v); destruct (IHn v). all: eauto using vec_inB.
    + intros Hv. apply in_map_iff in Hv as ([h v'] & <- & (? & ? & [= <- <-] & ? & ?) % list_prod_in).
      intros x H. inv H; destruct (IHn v'); eauto.
Qed.

Lemma vec_forall_cml X (L : nat -> list X) n (v : vector X n) :
  cumulative L -> (forall x, vec_in x v -> exists m, x el L m) -> exists m, v el vecs_from (L m) n.
Proof.
  intros HL Hv. induction v; cbn.
  - exists 0. tauto.
  - destruct IHv as [m H], (Hv h) as [m' H']. 1-3: eauto using vec_inB. exists (m + m').
    in_collect (pair h v). 1: apply cum_ge' with m'; intuition omega.
    apply vecs_from_correct. rewrite <- vecs_from_correct in H. intros x Hx.
    apply cum_ge' with m. all: eauto. omega.
Qed.

Fixpoint L_vec X (L : nat -> list X) n m : list (vector X n) :=
  match m with
  | 0 => []
  | S m => L_vec L n m ++ vecs_from (L m) n
  end.

Instance enumT_vec X {HX : enumT X} n : enumT (vector X n).
Proof with try (eapply cum_ge'; eauto; omega).
  exists (L_vec L_T n).
  - eauto.
  - intros v. enough (exists m, forall x, vec_in x v -> x el L_T m) as [m Hm].
    { exists (S m). cbn. in_app 2. now apply vecs_from_correct. }
    induction v.
    + exists 0. intros x H. inv H.
    + destruct (el_T h) as [m Hm], IHv as [m' Hm']. exists (m + m').
      intros x Hx. inv Hx...
Defined.

Section Enumerability.
  Context {Sigma : Signature}.

  Hypothesis enum_Funcs : enumT Funcs.
  Hypothesis enum_Preds : enumT Preds.

  Fixpoint L_term n : list term :=
    match n with
    | 0 => []
    | S n => L_term n ++ var_term n :: concat ([ [ Func F v | v ∈ vecs_from (L_term n) (fun_ar F) ] | F ∈ L_T n])
    end.

  Lemma L_term_cml :
    cumulative L_term.
  Proof.
    intros ?; cbn; eauto.
  Qed.

  Global Instance enumT_term : enumT term.
  Proof with try (eapply cum_ge'; eauto; omega).
    exists L_term.
    - exact L_term_cml.
    - intros t. induction t using strong_term_ind.
      + exists (S x); cbn; eauto.
      + apply vec_forall_cml in H as [m H]. 2: exact L_term_cml. destruct (el_T F) as [m' H'].
        exists (S (m + m')); cbn. in_app 3. eapply in_concat_iff. eexists. split. 2: in_collect F...
        apply in_map. rewrite <- vecs_from_correct in H |-*. intros x H''. specialize (H x H'')...
  Defined.

  Fixpoint L_form n : list form :=
    match n with
    | 0 => [Fal]
    | S n => L_form n
              ++ [Fal]
              ++ concat ([ [ Pred P v | v ∈ L_T n ] | P ∈ L_T n])
              ++ [ phi1 --> phi2 | (phi1, phi2) ∈ (L_form n × L_form n) ]
              ++ [ ∀ phi | phi ∈ L_form n ]
    end.

  Lemma L_form_cml :
    cumulative L_form.
  Proof.
    intros ?; cbn; eauto.
  Qed.

  Global Instance enumT_form : enumT form.
  Proof with (try eapply cum_ge'; eauto; omega).
    exists L_form.
    - exact L_form_cml.
    - intros phi. induction phi.
      + exists 1. cbn; eauto.
      + destruct (el_T P) as [m Hm], (el_T t) as [m' Hm']. exists (S (m + m')); cbn.
        in_app 3. eapply in_concat_iff. eexists. split. 2: in_collect P... apply in_map...
      + destruct IHphi1 as [m1], IHphi2 as [m2]. exists (1 + m1 + m2). cbn.
        in_app 4. in_collect (pair phi1 phi2)...
      + destruct IHphi as [m]. exists (S m). cbn -[L_T].
        in_app 5. in_collect phi...
  Defined.
End Enumerability.

(* **** Equality deciders *)

Lemma dec_vec_in X n (v : vector X n) :
  (forall x, vec_in x v -> forall y, dec (x = y)) -> forall v', dec (v = v').
Proof with subst; try (now left + (right; intros[=]; resolve_existT; congruence)).
  intros Hv. induction v; intros v'; dependent destruction v'...
  destruct (Hv h (vec_inB h v) h0)... destruct (IHv (fun x H => Hv x (vec_inS h0 H)) v')...
Qed.

Instance dec_vec X {HX : eq_dec X} n : eq_dec (vector X n).
Proof.
  intros v. refine (dec_vec_in _).
Qed.

Section EqDec.
  Context {Sigma : Signature}.

  Hypothesis eq_dec_Funcs : eq_dec Funcs.
  Hypothesis eq_dec_Preds : eq_dec Preds.

  Global Instance dec_term : eq_dec term.
  Proof with subst; try (now left + (right; intros[=]; resolve_existT; congruence)).
    intros t. induction t using strong_term_ind; intros []...
    - decide (x = n)...
    - decide (F = f)... destruct (dec_vec_in X t)...
  Qed.

  Global Instance dec_form : eq_dec form.
  Proof with subst; try (now left + (right; intros[=]; resolve_existT; congruence)).
    intros phi. induction phi; intros []...
    - decide (P = P0)... decide (t = t0)...
    - decide (phi1 = f)... decide (phi2 = f0)...
    - decide (phi = f)...
  Qed.
End EqDec.

(* **** Subterm relation *)

Section Subterm.
  Context {Sigma : Signature}.

  Definition form_shift n := var_term (S n).
  Notation "↑" := form_shift.

  Inductive subterm t : term -> Prop :=
  | stB : subterm t t
  | stF F v s : vec_in s v -> subterm t s -> subterm t (Func F v).

  Inductive subterm_form t : form -> Prop :=
  | stP P v s : vec_in s v -> subterm t s -> subterm_form t (Pred P v)
  | stIL phi psi : subterm_form t phi -> subterm_form t (phi --> psi)
  | stIR phi psi : subterm_form t psi -> subterm_form t (phi --> psi)
  | stA phi : subterm_form t[↑] phi -> subterm_form t (∀ phi).
End Subterm.

(* **** Signature extension *)

Section SigExt.
  Hint Unfold axioms.funcomp.

  Definition sig_ext (Sigma : Signature) : Signature :=
    match Sigma with
      B_S Funcs fun_ar Preds pred_ar =>
      B_S (Funcs + nat)
          (fun f => match f with inl f' => fun_ar f' | inr _ => 0 end)
          Preds
          pred_ar
    end.

  Global Instance dec_sig_ext_Funcs {Sigma : Signature} (H : eq_dec Funcs) : eq_dec (@Funcs (sig_ext Sigma)).
  Proof with subst; try (now left + (right; intros[=]; resolve_existT; congruence)).
    destruct Sigma. intros [] []...
    - decide (f = f0)...
    - decide (n = n0)...
  Qed.

  Global Instance dec_sig_ext_Preds {Sigma : Signature} (H : eq_dec Preds) : eq_dec (@Preds (sig_ext Sigma)).
  Proof with subst; try (now left + (right; intros[=]; resolve_existT; congruence)).
    destruct Sigma. exact H.
  Qed.

  Global Instance enumT_sig_ext_Funcs {Sigma : Signature} (H : enumT Funcs) : enumT (@Funcs (sig_ext Sigma)).
  Proof with (try eapply cum_ge'; eauto; omega).
    destruct Sigma. destruct H. exists (fix f n := match n with 0 => List.map inl (L_T 0) | S n' => f n' ++ (inr n') :: List.map inl (L_T n') end).
    1: eauto. intros []. 2: exists (S n); in_app 2... destruct (el_T f) as [m Hin]. exists (S m). in_app 3. in_collect f...
  Qed.

  Global Instance enumT_sig_ext_Preds {Sigma : Signature} (H : enumT Preds) : enumT (@Preds (sig_ext Sigma)).
  Proof.
    destruct Sigma. exact H.
  Qed.

  Fixpoint sig_lift_term' F F_ar P P_ar (t : @term (B_S F F_ar P P_ar)) :
    (@term (sig_ext (B_S F F_ar P P_ar))) :=
      match t with
      | var_term x => var_term x
      | Func f v => @Func (sig_ext (B_S F F_ar P P_ar)) (inl f) (map (fun x => sig_lift_term' x) v)
      end.

  Definition sig_lift_term {Sigma : Signature} : @term Sigma -> @term (sig_ext Sigma) :=
    match Sigma return @term Sigma -> @term (sig_ext Sigma) with
      B_S Funcs fun_ar Preds pred_ar as S => fun t => sig_lift_term' t
    end.
  Hint Unfold sig_lift_term.

  Fixpoint sig_lift' F F_ar P P_ar (phi : @form (B_S F F_ar P P_ar)) :
    (@form (sig_ext (B_S F F_ar P P_ar))) :=
      match phi with
      | Fal => Fal
      | Pred p v => @Pred (sig_ext (B_S F F_ar P P_ar)) p (map sig_lift_term v)
      | Impl phi psi => Impl (sig_lift' phi) (sig_lift' psi)
      | All phi => All (sig_lift' phi)
      end.

  Definition sig_lift {Sigma : Signature} : @form Sigma -> @form (sig_ext Sigma) :=
    match Sigma return @form Sigma -> @form (sig_ext Sigma) with
      B_S Funcs fun_ar Preds pred_ar as Sig => fun phi => sig_lift' phi
    end.
  Hint Unfold sig_lift.

  Lemma sig_lift_subst_term {Sigma : Signature} xi t :
    sig_lift_term (subst_term xi t) = subst_term (xi >> sig_lift_term) (sig_lift_term t).
  Proof.
    destruct Sigma. induction t using strong_term_ind; comp.
    - reflexivity.
    - f_equal. erewrite! vec_comp. 2,3: reflexivity. now apply vec_map_ext.
  Qed.

  Lemma sig_lift_subst {Sigma : Signature} xi phi :
    sig_lift (subst_form xi phi) = subst_form (xi >> sig_lift_term) (sig_lift phi).
  Proof.
    destruct Sigma. induction phi in xi |-*; comp; try congruence.
    - f_equal. erewrite! vec_comp. 2,3: reflexivity. apply vec_map_ext. intros x.
      specialize (sig_lift_subst_term xi x) as ?. now comp.
    - f_equal. rewrite IHphi. comp. apply ext_form. intros []. 1: reflexivity.
      comp. unfold ">>". specialize (sig_lift_subst_term (fun x => var_term (shift x)) (xi n)) as H.
      comp. now rewrite H.
  Qed.

  Fixpoint fin_minus (n m : nat) : (n < m) + {x | x = n - m} :=
    match n, m with
    | n', 0 => inr (exist (fun x => x = n' - 0) n' eq_refl)
    | 0, S m' => inl (le_n_S 0 m' (Nat.le_0_l m'))
    | S n', S m' =>
      match fin_minus n' m' with
      | inr (exist _ x H) => inr (exist _ x H)
      | inl H => inl (le_n_S (S n') m' H)
      end
    end.

  Definition vsubs {Sigma : Signature} (n m : nat) (v : vector term n) (x : nat) : term :=
    match fin_minus x n with
    | inl i => nth_order v i
    | inr (exist _ y _) => var_term (y + m)
    end.
  Hint Unfold vsubs.

  Lemma up_term_term_vsubs {Sigma : Signature }n (v : vector term n) i x :
    up_term_term (vsubs i v) x = vsubs (S i) (cons (var_term 0) (map (subst_term (vsubs 1 nil)) v)) x.
  Proof.
    destruct x; comp. 1: reflexivity. destruct (fin_minus x n); comp.
    - rewrite nth_map with (p2 := Fin.of_nat_lt l). 2: apply Fin.of_nat_ext. apply ext_term. intros y.
      destruct (fin_minus y 0). 1: omega. destruct s; subst. unfold ">>", shift. f_equal; omega.
    - destruct s. comp. now rewrite <- (plus_n_Sm x0 i).
  Qed.

  Fixpoint sig_drop_term' F F_ar P P_ar (n : nat) (t : @term (sig_ext (B_S F F_ar P P_ar))) :
    @term (B_S F F_ar P P_ar) :=
    match t with
    | var_term x => var_term x
    | Func (inl f') v => @Func (B_S F F_ar P P_ar) f' (map (fun x => sig_drop_term' n x) v)
    | Func (inr y) _ => var_term (n + y)
    end.

  Definition sig_drop_term {Sigma : Signature} (n : nat) : @term (sig_ext Sigma) -> @term Sigma :=
    match Sigma return @term (sig_ext Sigma) -> @term Sigma with
      B_S Funcs fun_ar Preds pred_ar as S => sig_drop_term' n
    end.
  Hint Unfold sig_drop_term.

  Fixpoint sig_drop' F F_ar P P_ar (n : nat) (phi : @form (sig_ext (B_S F F_ar P P_ar))) :
    @form (B_S F F_ar P P_ar) :=
      match phi with
      | Fal => Fal
      | Pred p v => @Pred (B_S F F_ar P P_ar) p (map (sig_drop_term n) v)
      | Impl phi psi => Impl (sig_drop' n phi) (sig_drop' n psi)
      | All phi => All (sig_drop' (S n) phi)
      end.

  Definition sig_drop {Sigma : Signature} (n : nat) : @form (sig_ext Sigma) -> @form Sigma :=
    match Sigma return @form (sig_ext Sigma) -> @form Sigma with
      B_S Funcs fun_ar Preds pred_ar as Sig => sig_drop' n
    end.
  Hint Unfold sig_drop.

  Lemma nth_order_map X Y (f : X -> Y) n (v : vector X n) i (H : i < n) :
    nth_order (map f v) H = f (nth_order v H).
  Proof.
    now apply nth_map.
  Qed.

  Lemma sig_drop_subst_term' f f_ar P P_ar t n m i (v : vector (@term (sig_ext (B_S f f_ar P P_ar))) m) :
    sig_drop_term' (n + i) (t [vsubs i v]) = (sig_drop_term' (n + m) t)[vsubs i (map (sig_drop_term' (n + i)) v)].
  Proof.
    induction t using strong_term_ind; comp.
    - destruct (fin_minus x m); comp; [now rewrite nth_order_map | now destruct s].
    - destruct F; comp. 2: destruct (fin_minus (n + m + n0) m); [| destruct s; subst; f_equal]; omega.
      f_equal. erewrite! vec_comp. 2,3 : reflexivity. apply vec_map_ext. intros t Ht. now apply H.
  Qed.

  Lemma sig_drop_subst' f f_ar P P_ar phi n m i (v : vector (@term (sig_ext (B_S f f_ar P P_ar))) m) :
    sig_drop' (n + i) (subst_form (vsubs i v) phi) = subst_form (vsubs i (map (sig_drop_term' (n + i)) v)) (sig_drop' (n + m) phi).
  Proof.
    induction phi in i, m, v |-*. 1,2,3: comp.
    - reflexivity.
    - f_equal. erewrite! vec_comp. 2,3 : reflexivity. apply vec_ext. intros s. now apply sig_drop_subst_term'.
    - now rewrite IHphi1, IHphi2.
    - cbn. f_equal. erewrite ext_form with (s := phi). 2: apply up_term_term_vsubs.
      erewrite ext_form with (s := (sig_drop' (S (n + m)) phi)). 2: apply up_term_term_vsubs.
      specialize (IHphi (S m) (S i) (cons (var_term 0) (map (subst_term (vsubs 1 nil)) v))).
      replace (S (n + i)) with (n + S i) by omega. rewrite IHphi.
      replace (n + S m) with (S (n + m)) by omega. apply ext_form. intros []. 1: reflexivity.
      cbn. unfold vsubs at 1 3. cbn. destruct (fin_minus n0 m); cbn. 2: now destruct s.
      f_equal. erewrite! vec_comp. 2,3: reflexivity. apply vec_ext. intros t. unfold axioms.funcomp.
      replace (n + S i) with (n + i + 1) by omega. replace (n + i) with (n + i + 0) at 2 by omega.
      change nil with (map (@sig_drop_term' f f_ar P P_ar (n + i + 1)) nil) at 2.
      apply sig_drop_subst_term' with (v := nil) (m := 0) (i := 1) (n := n + i) (t0 := t).
  Qed.

  Definition ext_c' f f_ar P P_ar (n : nat) : term := @Func (sig_ext (B_S f f_ar P P_ar)) (inr n) Vector.nil.
  Definition ext_c {Sigma : Signature} (n : nat) : @term (sig_ext Sigma) :=
    match Sigma with
      B_S f f_ar P P_ar => ext_c' f_ar P_ar n
    end.

  Definition pref {Sigma : Signature} (n : nat) (rho : nat -> term) (x : nat) : term :=
    match fin_minus x n with
    | inl i => var_term x
    | inr (exist _ y _) => rho y
    end.
  Definition raise {Sigma : Signature} (n : nat) (x : nat) : term := var_term (n + x).

  Hint Unfold ext_c' pref raise.

  Lemma up_term_term_pref_ext_c' f (f_ar : f -> nat) P (P_ar : P -> nat) n x :
    up_term_term (pref n (ext_c' f_ar P_ar)) x = pref (S n) (ext_c' f_ar P_ar) x.
  Proof.
    destruct x. 1: reflexivity. comp. destruct (fin_minus x n). 1: now comp; unfold ">>", shift.
    destruct s. now comp.
  Qed.

  Lemma up_term_term_pref_raise {Sigma : Signature} n m x :
    up_term_term (pref n (raise m)) x = pref (S n) (raise (S m)) x.
  Proof.
    destruct x. 1: reflexivity. comp. destruct (fin_minus x n). 1: now comp; unfold ">>", shift.
    destruct s. unfold ">>", shift; now comp.
  Qed.

  Lemma lift_drop_inverse_term' f f_ar P P_ar n (t : @term (B_S f f_ar P P_ar)) :
    sig_drop_term' n (sig_lift_term' t)[pref n (ext_c' f_ar P_ar)] = t[pref n (@raise (B_S f f_ar P P_ar) n)].
  Proof.
    induction t using strong_term_ind; cbn.
    - comp. destruct (fin_minus x n). 1: reflexivity. now destruct s.
    - f_equal. erewrite! vec_comp. 2,3: reflexivity. apply vec_map_ext. intros t Ht. now apply H.
  Qed.

  Lemma lift_drop_inverse' f f_ar P P_ar n (phi : @form (B_S f f_ar P P_ar)) :
    sig_drop' n (subst_form (pref n (ext_c' f_ar P_ar)) (sig_lift' phi)) = subst_form (pref n (@raise (B_S f f_ar P P_ar) n)) phi.
  Proof.
    induction phi in n |-*. 1,2,3: comp.
    - reflexivity.
    - f_equal. erewrite! vec_comp. 2,3: reflexivity. apply vec_ext, lift_drop_inverse_term'.
    - now rewrite IHphi1, IHphi2.
    - cbn. f_equal. erewrite ext_form with (s := phi). 2: apply up_term_term_pref_raise.
      erewrite ext_form with (s := (sig_lift' phi)). 2: apply up_term_term_pref_ext_c'.
      apply IHphi.
  Qed.

  Lemma lift_drop_inverse {Sigma : Signature} phi :
    sig_drop 0 (subst_form ext_c (sig_lift phi)) = phi.
  Proof.
    destruct Sigma. erewrite ext_form with (s := sig_lift phi) (tauterm := @pref (sig_ext (B_S Funcs fun_ar Preds pred_ar)) 0 (ext_c' fun_ar pred_ar)).
    1: comp; rewrite lift_drop_inverse'; apply idSubst_form; now intros [].
    intros x. comp. destruct (fin_minus x 0). 1: omega. destruct s; subst. now replace (x - 0) with x by omega.
  Qed.

  Lemma ext_c'_unused_term f f_ar P P_ar (n : nat) (t : @term (sig_ext (B_S f f_ar P P_ar))) m :
    n <= m -> @unused_term (sig_ext (B_S f f_ar P P_ar)) m t[pref n (ext_c' f_ar P_ar)].
  Proof.
    intros Hm; induction t using strong_term_ind; comp.
    - destruct (fin_minus x n); comp. 1: constructor; omega.
      destruct s. constructor. intros ?. inversion 1.
    - constructor. apply vec_forall_map, H.
  Qed.

  Lemma ext_c'_unused f f_ar P P_ar (n : nat) (phi : @form (sig_ext (B_S f f_ar P P_ar))) m :
    n <= m -> @unused (sig_ext (B_S f f_ar P P_ar)) m phi[pref n (ext_c' f_ar P_ar)].
  Proof.
    intros Hm; induction phi in n, m, Hm |-*. 1,2,3 : comp; constructor; auto.
    - apply vec_forall_map. intros. capply ext_c'_unused_term.
    - cbn. auto_unfold. erewrite ext_form with (s := phi). 2: apply up_term_term_pref_ext_c'.
      constructor. apply IHphi. omega.
  Qed.

  Lemma lift_ext_c_closes {Sigma : Signature} phi :
    @closed (sig_ext Sigma) (sig_lift phi)[ext_c].
  Proof.
    destruct Sigma. unfold ext_c. intros n. auto_unfold; erewrite ext_form. apply ext_c'_unused with (n := 0) (m := n).
    1: omega. now intros [].
  Qed.

  Lemma lift_ext_c_closes_T {Sigma : Signature} (T : theory) :
    @closed_T (sig_ext Sigma) (tmap (fun psi => (sig_lift psi)[@ext_c Sigma]) T).
  Proof.
    intros ? n [phi [_ <-]]. apply lift_ext_c_closes.
  Qed.
End SigExt.

Notation "↑" := form_shift.
Notation "A ⟹ phi" := (big_imp A phi) (at level 60, right associativity).


(** * PrettyBounds for Machines in TM/Code *)

From Complexity Require Export TM.PrettyBounds.PrettyBounds.
From Undecidability Require Export TM.Code.ProgrammingTools.
From Undecidability Require Export TM.Code.ListTM TM.Code.CaseList TM.Code.CaseNat TM.Code.CaseSum.

(** We want to give proofs without building constants/the need to manually unfold "_ <=( _ ) _" *)
(** So every intermediate goal shall have the shape "x <=(?c) y", and we use lemmas to simplify this depending on the shape of x *)
(* Sadly, this approach works only for non-recursive functions*)

Section CaseList_nice.

  Implicit Types (sigX X : Type).

  Lemma CaseList_steps_nice :
    { c | forall sigX X (cX:codable sigX X) (xs:list X),
    CaseList_steps xs  <=(c) match xs with
                             | nil => 1
                             | x :: _ => size x + 1
                             end }.
  Proof. eexists. intros. unfold CaseList_steps, CaseList_steps_nil,CaseList_steps_cons. domWith_approx. Qed.

  Lemma CaseList_steps_nil_nice :
    { c | CaseList_steps_nil <=(c) 1 }.
  Proof. eexists. apply dominatedWith_const. lia. Qed.

  Lemma CaseList_steps_cons_nice :
    { c | forall  sigX X (cX:codable sigX X) (x : X), CaseList_steps_cons x <=(c) size x + 1 }.
  Proof. eexists. intros. unfold CaseList_steps_cons. domWith_approx. Qed.

  Lemma Constr_nil_steps_nice :
    { c | Constr_nil_steps <=(c) 1 }.
  Proof. eexists. domWith_approx. Qed.

  Lemma Constr_cons_steps_nice :
    { c | forall  sigX X (cX:codable sigX X) (x : X), Constr_cons_steps x <=(c) size x + 1 }.
  Proof. eexists. intros. unfold Constr_cons_steps. domWith_approx. Qed.

End CaseList_nice.

Section CaseNat_steps_nice.

  Lemma CaseNat_steps_nice :
    { c | CaseNat_steps <=(c) 1 }.
  Proof. eexists. apply dominatedWith_const. lia. Qed.

  Lemma Constr_O_steps_nice :
    { c | Constr_O_steps <=(c) 1 }.
  Proof. eexists. apply dominatedWith_const. lia. Qed.

  Lemma Constr_S_steps_nice :
    { c | Constr_S_steps <=(c) 1 }.
  Proof. eexists. apply dominatedWith_const. lia. Qed.

End CaseNat_steps_nice.

(** Sadly, we need more ugly approach for recursive functions: *)

Section encodeList_size_eq.
  Variable X : Type.
  Variable sigX : Type.
  Context {cX : codable sigX X}.

  Lemma encodeList_size_app (l1 l2 : list X) :
    size (l1 ++ l2) <= size l1 + size l2.
  Proof.
    rewrite !Encode_list_hasSize in *.
    cbn. induction l1;cbn. eauto. cbn. cbn. autorewrite with list. lia.
  Qed.

  Lemma encodeList_size_app_eq (l1 l2 : list X) :
    size (l1 ++ l2) = size l1 + size l2 - 1.
  Proof.
    rewrite !Encode_list_hasSize in *.
    cbn. induction l1;cbn. lia. autorewrite with list. rewrite IHl1.
    assert ((Encode_list_size cX l2) > 0) by (induction l2;cbn;lia). lia.
  Qed.

  Lemma encodeList_size_cons  x (l : list X) :
    size (x::l) = 1 + size x + size l.
  Proof.
    rewrite !Encode_list_hasSize in *.
    cbn. unfold size. autorewrite with list. lia.
  Qed.

  Lemma encodeList_size_nil:
    size (@nil X) = 1.
  Proof.
    rewrite !Encode_list_hasSize in *.
    reflexivity.
  Qed.

End encodeList_size_eq.

Create HintDb size_eqs.
#[export]
Hint Rewrite encodeList_size_app encodeList_size_cons encodeList_size_nil encodeList_size_app: size_eqs.

Ltac rewrite_sizes := rewrite_strat (innermost (hints size_eqs)).

(** ** Copy steps functions *)

(* Copy steps functions are very nice! *)
Section Copy_very_nice.
  Implicit Types (sigX X : Type).

  Lemma CopyValue_steps_nice :
    { c | forall sigX X (cX : codable sigX X) (x:X), CopyValue_steps x <=(c) size x + 1 }.
  Proof.
    eexists. intros ? ? ? x. unfold CopyValue_steps. domWith_approx.
    (*
    - apply dominatedWith_const; auto.
    - apply dominatedWith_refl. instantiate (1 := 1). lia.
*)
  Qed.

  Lemma Reset_steps_nice :
    { c | forall sigX X (cX : codable sigX X) (x:X), Reset_steps x <=(c) size x + 1 }.
  Proof.
    eexists. intros ? ? ? x. unfold Reset_steps. domWith_approx.
    (*
    - apply dominatedWith_const; auto.
    - apply dominatedWith_refl. instantiate (1 := 1). lia.
*)
  Qed.

  Lemma Translate_steps_nice :
    { c | forall  sigX X (cX : codable sigX X) (x:X), Translate_steps x <=(c) size x + 1 }.
  Proof. eexists. intros. unfold Translate_steps. domWith_approx. Qed.

  Lemma MoveValue_steps_nice :
    { c | forall sigX X (cX : codable sigX X) (sigY Y : Type) (cY : codable sigY Y) (x : X) (y : Y),
        MoveValue_steps x y <=(c) size x + size y + 1 }.
  Proof.
    eexists. intros. unfold MoveValue_steps. domWith_approx.
  Qed.

  (* "Better" version *)
  Lemma MoveValue_steps_nice' :
    { c | forall sigX X (cX : codable sigX X) (sizeGt1 : forall (x : X), 1 <= size x)  (sigY Y : Type) (cY : codable sigY Y) (x : X) (y : Y) (sizeGt1' : forall (y : Y), 1 <= size y), MoveValue_steps x y <=(c) size x + size y }.
  Proof.
    eexists. intros ?  ? ? ? ? ? ? x y ?. unfold MoveValue_steps.
    rewrite <- Nat.add_assoc. eapply dominatedWith_add_l.
    - apply dominatedWith_add.
      + apply dominatedWith_mult_l. apply dominatedWith_solve.
        enough (1 <= size y) by lia. apply sizeGt1'.
      + apply dominatedWith_mult_l. apply dominatedWith_solve.
        enough (1 <= size x) by lia. apply sizeGt1.
    - enough (1 <= size x) by lia. apply sizeGt1.
  Qed.

End Copy_very_nice.

(** With this set-up, we can tackle recursive functions. *)

Arguments size {sig X cX} : simpl never.

Section Nth'_nice.
  Variable (sigX X : Type) (cX : codable sigX X).

  (*
  Lemma Nth'_Step_steps_nice :
    { c | forall (xs : list X) (n : nat), Nth'_Step_steps xs n <=(c) size _ xs }.
  Proof.
    evar (c:nat). exists c.
    intros. unfold Nth'_Step_steps.
    apply dominatedWith_match_nat.
    - intros ->. apply dominatedWith_match_list.
      + intros ->. cbn. unfold dominatedWith. unfold CaseList_steps_nil. do 11 instantiate (1 := S _). instantiate (1 := 0). lia.
      + intros x xs' ->. unfold CaseNat_steps, CaseList_steps_cons. hnf. rewrite Encode_list_hasSize. cbn [Encode_list_size].
        ring_simplify. instantiate (1 := 48). lia.
    - intros x ->. apply dominatedWith_match_list.
      + intros ->. ring_simplify. rewrite Encode_list_hasSize; cbn [Encode_list_size].
        apply dominatedWith_const. lia.
      + intros x' xs' ->. rewrite Encode_list_hasSize; cbn [Encode_list_size].
        unfold CaseList_steps_cons, Reset_steps, CaseNat_steps. ring_simplify. instantiate (1 := 100). hnf. ring_simplify. nia.
  Qed.
*)

  Lemma Nth'_Step_steps_nice_nil :
    { c | forall (n : nat), Nth'_Step_steps (X:=X) nil n <=(c) 1 }.
  Proof.
    evar (c:nat). exists c.
    intros. unfold Nth'_Step_steps. apply dominatedWith_match_nat.
    - intros ->. unfold CaseNat_steps, CaseList_steps_cons. ring_simplify. hnf. apply dominatedWith_const. lia.
    - intros n' ->. unfold CaseNat_steps, CaseList_steps_cons. ring_simplify. hnf. apply dominatedWith_const. lia.
  Qed.

  Lemma Nth'_Step_steps_nice_cons :
    { c | forall (x : X) (xs : list X) (n : nat), Nth'_Step_steps (x :: xs) n <=(c) size x+1 }.
  Proof.
    evar (c:nat). exists c.
    intros. unfold Nth'_Step_steps. apply dominatedWith_match_nat.
    - intros ->. unfold CaseNat_steps, CaseList_steps_cons. ring_simplify. hnf. instantiate (1 := 57). nia.
    - intros n' ->. unfold CaseNat_steps, CaseList_steps_cons, Reset_steps. ring_simplify. hnf. instantiate (1 := 57). ring_simplify. nia.
  Qed.

  Lemma max_plus_l a b c :
    max a (c + max b a) <= c + max b a.
  Proof.
    assert (a <= b \/ b <= a) as [H | H] by lia.
    - replace (max b a) with b.
      rewrite max_r by lia. lia.
      now rewrite max_l by lia.
    - replace (max b a) with a.
      rewrite max_r by lia. lia.
      now rewrite max_r by lia.
  Qed.

  Lemma Nth'_Loop_steps_nice :
    { c | forall (xs : list X) (n : nat), Nth'_Loop_steps xs n <=(c) size xs }.
  Proof.
    pose_nice Nth'_Step_steps_nice_nil  HStep_nil  c_nil.
    pose_nice Nth'_Step_steps_nice_cons HStep_cons c_cons.
    pose (c := 1 + max c_nil c_cons).
    exists c.
    intros xs. induction xs as [ | x xs' IH]; intros.
    - eapply dominatedWith_mono_c. cbn [Nth'_Loop_steps].
      destruct n; apply HStep_nil. constructor; apply Nat.le_max_l || auto with arith. (* Why is [rewrite Nat.le_max_l] not working? *)
    - cbn [Nth'_Loop_steps]. eapply dominatedWith_mono_c; [..|shelve]. eapply dominatedWith_match_nat.
      + intros ->. hnf.
        specialize (HStep_cons x xs' 0).
        instantiate (1 := c_cons). rewrite Encode_list_hasSize; cbn [Encode_list_size]. ring_simplify. lia.
      + intros n' ->. hnf.
        specialize (HStep_cons x xs' (S n')).
        instantiate (1 := c). rewrite Encode_list_hasSize; cbn [Encode_list_size].
        rewrite HStep_cons. specialize (IH n'). hnf in IH. rewrite IH. ring_simplify. rewrite Encode_list_hasSize; cbn [Encode_list_size].
        ring_simplify. subst c. nia.
    Unshelve.
    apply max_plus_l.
  Qed.

  (* Three different proofs! I consider only the third compositional, because we don't unfold any constants. *)
  Lemma Nth'_steps_nice :
    { c | forall (xs : list X) (n : nat), Nth'_steps xs n <=(c) size xs + n + 1 }.
  Proof.
  (*   pose_nice Nth'_Loop_steps_nice H c. *)
  (*   eexists. intros xs n. specialize (H xs n). *)
  (*   hnf. unfold Nth'_steps. ring_simplify. *)
  (*   (* At this point, ultimate domination would be better, because we would not have to look in the values of [CopyValue_steps] and [Reset_steps], because we already know that they are Θ(size _ xs). Below, [28] has been chosen in dependence of these constants. *) *)
  (*   unfold CopyValue_steps, Reset_steps. *)
  (*   instantiate (1 := 12 + c + 4 + 4 + _). *)
  (*   rewrite !Encode_list_hasSize. rewrite Encode_list_hasSize_skipn. *)
  (*   rewrite Encode_nat_hasSize. rewrite H, Encode_list_hasSize. *)
  (*   ring_simplify. *)
  (*   assert (n - (1 + |xs|) <= n) as H' by lia; rewrite H'; clear H'. *)
  (*   (* Encode_list_size cX xs * c + 16 * Encode_list_size cX xs + 4 * n + 48 <= *)
  (*      Encode_list_size cX xs * c + Encode_list_size cX xs * ?m + 20 * Encode_list_size cX xs + c * n + c + ?m * n + ?m + 20 * n + 20 *) *)
  (*   instantiate (1 := 28). *)
  (*   nia. *)
  (* Restart. *)
  (*   (* Another proof with more automation *) *)
  (*   pose_nice Nth'_Loop_steps_nice H c. *)
  (*   eexists. intros xs n. specialize (H xs n). *)
  (*   hnf. unfold Nth'_steps. *)
  (*   repeat eapply dominatedWith_add. *)
  (*   (* Compositional part is more or less automatic *) *)
  (*   all: ring_simplify. *)
  (*   (* The second tactic can solve more and is faster *) *)
  (*   all: domWith_approx. *)
  (*   all: try solve [ eauto | apply dominatedWith_const; lia | apply dominatedWith_solve; lia *)
  (*                  | eapply dominatedWith_trans; eauto; apply dominatedWith_solve; lia ]. *)
  (*   (* Specific part for [Nth'] *) *)
  (*   1-4: apply dominatedWith_solve; rewrite !Encode_list_hasSize; etransitivity; [ apply (Encode_list_hasSize_skipn _ xs (1+n)) | lia ]. *)
  (*   1-4: assert (1 <= size xs) by (rewrite Encode_list_hasSize; apply Encode_list_hasSize_ge1); *)
  (*     apply dominatedWith_solve; rewrite Encode_nat_hasSize; lia. *)
  (* Restart. *)
    (* Another proof with more automation *)
    pose_nice Nth'_Loop_steps_nice H c.
    eexists. intros xs n. specialize (H xs n).
    hnf. unfold Nth'_steps.
    (* Automated Compositionality! *)
    domWith_approx.
    - eapply dominatedWith_trans.
      apply (proj2_sig CopyValue_steps_nice).
      domWith_approx.
    - eapply dominatedWith_trans.
      eauto. domWith_approx.
    - eapply dominatedWith_trans.
      apply (proj2_sig Reset_steps_nice).
      apply dominatedWith_S''.
      2:lia.
      2:{ apply dominatedWith_solve. rewrite !Encode_list_hasSize.
           hnf. rewrite Encode_list_hasSize_skipn. lia. }
      pose proof (Encode_list_hasSize_ge1 _ xs). rewrite Encode_list_hasSize. lia.
    - eapply dominatedWith_trans.
      apply (proj2_sig Reset_steps_nice).
      (* This is the [Nth']-specific complication *)
      apply dominatedWith_S''.
      2: lia.
      2: { apply dominatedWith_solve. rewrite !Encode_list_hasSize. rewrite Encode_nat_hasSize.
           pose proof (Encode_list_hasSize_ge1 _ xs). lia. }
      pose proof (Encode_list_hasSize_ge1 _ xs). rewrite Encode_list_hasSize. lia.
  Qed.

End Nth'_nice.

(* Print Assumptions Nth'_steps_nice. *)

Section Length_steps_nice.

  Variable (sigX X : Type) (cX : codable sigX X).

  (* Print Length_Step_steps. *)

  Lemma Length_Step_steps_nice_nil :
    {c | Length_Step_steps (X:=X)nil <=(c) 1 }.
  Proof. eexists. cbn. intros. apply dominatedWith_const. lia. Qed.

  Lemma Length_Step_steps_nice_cons :
    {c | forall (xs : list X) (x : X), Length_Step_steps (x :: xs) <=(c) size x + 1 }.
  Proof.
    pose_nice CaseList_steps_nice Hc_CaseList c_CaseList.
    pose_nice Reset_steps_nice Hc_Reset c_Reset.
    eexists. intros. cbn.
    ring_simplify. domWith_approx.
    - apply (Hc_CaseList _ _ _ [x]).
    - apply Hc_Reset.
  Qed.

  Lemma Length_Loop_steps_nice :
    { c | forall (xs : list X), Length_Loop_steps xs <=(c) size xs }.
  Proof.
    pose_nice Length_Step_steps_nice_nil Hc_nil c_nil.
    pose_nice Length_Step_steps_nice_cons Hc_cons c_cons.
    pose (c := 1 + max c_nil c_cons). exists c.
    setoid_rewrite Encode_list_hasSize; cbn [Encode_list_size].
    induction xs as [ | x xs' IH].
    - eapply dominatedWith_mono_c. apply Hc_nil. subst c. lia.
    - specialize Hc_cons with (xs := xs').
      (* eapply dominatedWith_mono_c; [..|shelve]. *)
      hnf. cbn [Length_Loop_steps]. rewrite (Hc_cons x). ring_simplify.
      (* instantiate (1 := c). *) subst c. ring_simplify.
      hnf in IH. cbn. rewrite IH. ring_simplify.
      enough (c_cons * size x + c_cons <=
              size x * Init.Nat.max c_nil c_cons + size x +
              Init.Nat.max c_nil c_cons) by lia.
      enough (c_cons * size x <=
              size x * Init.Nat.max c_nil c_cons + size x) by lia.
      enough (c_cons * size x <= size x * max c_nil c_cons) by lia.
      Fail enough (c_cons <= max c_nil c_cons) by lia.
      rewrite Nat.mul_comm.
      apply Nat.mul_le_mono_l.
      auto with arith.
      (* TODO: This needs to be more automated! *)
  Qed.

  Lemma Length_steps_nice :
    { c | forall (xs : list X), Length_steps xs <=(c) size xs }.
  Proof.
    pose_nice Length_Loop_steps_nice Hc_loop c_loop.
    eexists. intros.
    unfold Length_steps. (* ring_simplify. *)
    (* This OUGHT to be easy! https://xkcd.com/1349/ *)
    (* 36 + 12 * size (Encode_list cX) xs + Length_Loop_steps xs <=(?c)
       size (Encode_list cX) xs *)
    rewrite <- Nat.add_assoc. eapply dominatedWith_add_l.
    2:{ rewrite Encode_list_hasSize. apply Encode_list_hasSize_ge1. }
    domWith_approx.
    - hnf. apply Hc_loop.
  Qed.

End Length_steps_nice.

Section App_nice.
  Variable (sigX X : Type) (cX : codable sigX X).

  Lemma App'_steps_nice :
    { c | forall (xs : list X), App'_steps xs <=(c) size xs }.
  Proof.
    eexists. intros xs. unfold App'_steps.
    eapply dominatedWith_add_l.
    - domWith_approx.
    - rewrite Encode_list_hasSize. apply Encode_list_hasSize_ge1.
  Qed.

  (* [App] is not used *)
End App_nice.

Lemma Encode_pair_hasSize_ge1 (sigX sigY X Y : Type) (cX : codable sigX X) (cY : codable sigY Y) (p : X * Y) :
  1 <= size (fst p) \/ 1 <= size (snd p) ->
  1 <= Encode_pair_size _ _ p.
Proof. destruct p as (x,y). cbn in *. intros [H|H]; cbn; rewrite H; lia. Qed.

Lemma Encode_nat_hasSize_ge1 (n : nat) :
  1 <= size n.
Proof. rewrite Encode_nat_hasSize. lia. Qed.

Lemma Encode_option_hasSize_ge1 (sigX X : Type) (cX : codable sigX X) (o : option X) :
  1 <= Encode_option_size _ o.
Proof. destruct o; cbn; lia. Qed.

(** *** CasePair *)

From Undecidability Require Import CasePair.

Section CasePair_steps_nice.
  Implicit Types (sigX X : Type).

  Lemma CasePair_steps_nice :
    { c | forall sigX X (cX : codable sigX X) (x : X), CasePair_steps x <=(c) size x + 1 }.
  Proof. eexists. intros. unfold CasePair_steps. domWith_approx. Qed.

  Lemma Constr_pair_steps_nice :
    { c | forall sigX X (cX : codable sigX X) (x : X), Constr_pair_steps x <=(c) size x + 1 }.
  Proof. eexists. intros. unfold Constr_pair_steps. domWith_approx. Qed.

End CasePair_steps_nice.

(** *** CaseSum and CaseOption *)

From Undecidability Require Import CaseSum.

Section CaseSum_steps_nice.

  Lemma CaseSum_steps_nice :
    { c | CaseSum_steps <=(c) 1 }.
  Proof. eexists. unfold CaseSum_steps. domWith_approx. Qed.

  Lemma Constr_inl_steps_nice :
    { c | Constr_inl_steps <=(c) 1 }.
  Proof. eexists. unfold Constr_inl_steps. domWith_approx. Qed.

  Lemma Constr_inr_steps_nice :
    { c | Constr_inr_steps <=(c) 1 }.
  Proof. eexists. unfold Constr_inr_steps. domWith_approx. Qed.

  Lemma CaseOption_steps_nice :
    { c | CaseOption_steps <=(c) 1 }.
  Proof. eexists. unfold CaseOption_steps. domWith_approx. Qed.

  Lemma Constr_Some_steps_nice :
    { c | Constr_Some_steps <=(c) 1 }.
  Proof. eexists. unfold Constr_Some_steps. domWith_approx. Qed.

  Lemma Constr_None_steps_nice :
    { c | Constr_None_steps <=(c) 1 }.
  Proof. eexists. unfold Constr_None_steps. domWith_approx. Qed.

End CaseSum_steps_nice.

Lemma Encode_list_hasSize_el (sigX X : Type) (cX : codable sigX X) (xs : list X) (x : X) :
  In x xs ->
  size x < Encode_list_size _ xs.
Proof.
  induction xs as [ | x' xs' IH].
  - intros [].
  - intros [<- | H].
    + cbn. lia.
    + specialize IH with (1 := H). cbn. lia.
Qed.

(** *** CompareValue(s) *)
From Undecidability Require Import Code.CompareValue.

Section CompareValues_nice.

  Lemma CompareValues_steps_nice :
    { c | forall (sigX X : Type) (cX : codable sigX X) (x1 x2 : X), CompareValues_steps x1 x2 <=(c) size x1 + size x2 + 1 }.
  Proof. eexists. intros. unfold CompareValues_steps. domWith_approx. Qed.

End CompareValues_nice.


Section LP1.
Variables P Q R S T U: Prop.
(*1*)
(*Si el ejercito marcha contra el enemigo, tiene posibilidades de exito; y
arrasara la capital enemiga, si tiene posibilidades de exito. El ejercito marcha
contra el enemigo o se repliega rapidamente. Si se repliega rapidamente,
el enemigo atacara su retaguardia; y perdera la guerra, si el enemigo ataca
su retaguardia. Por lo tanto, si no arrasa la capital enemiga, perdera la
guerra.*)

(*P: el ejercito marcha contra el enemigo*)
(*Q: el ejrcito tiene posibilidades de exito*)
(*R: el ejercito arrasara la capital enemiga*)
(*S: el ejercito se repliega rapidamente*)
(*T: el enemigo atacara la retaguardia del ejercito*)
(*U: el ejercito perdera la guerra*)
Hypothesis H0 : P -> Q.
Hypothesis H1 : Q -> R.
Hypothesis H2 : P \/ S.
Hypothesis H3 : S -> T.
Hypothesis H4 : T -> U.
Lemma conclusion : ~R -> U.
Proof.
destruct H2.
intro.
apply H5 in H1.
contradiction.
apply H0.
assumption.
intro.
apply H4.
apply H3.
assumption.
Qed.
End LP1.
Section LP2.
(*2*)
(*La fısica describe la naturaleza a base de observables clasicos o a base
de estados abstractos. Si la describe mediante los primeros, entonces nos
permite representar las cosas intuitivamente, pero nos exige renunciar a la
causalidad. En cambio, si la describe mediante los segundos, nos impide
la representacion intuitiva, pero nos permite conservar la causalidad. La
fısica nos permitira representar las cosas intuitivamente, a no ser que nos
exija renunciar a la causalidad. Por lo tanto, no es cierto que nos permita
representar las cosas intuitivamente solo si no renuncia a la causalidad.*)

(*P: La fisica describe la naturaleza a base de observables clasicos*)
(*Q: La fisica describe la naturaleza a base de estados abstractos*)
(*R: La fisica nos permite representar las cosas intuitivamente*)
(*S: La fisica nos permite conservar la causalidad*)
Variables P Q R S T U : Prop.

Hypothesis H0 : P \/ Q.
Hypothesis H1 : (P -> R) /\ ~S.
Hypothesis H2 : (Q -> ~R) /\ S.
Hypothesis H3 : R \/ ~S.
Lemma conclusion2 : ~(~S -> R).
Proof.
intro.
destruct H1.
apply H5.
destruct H3.
destruct H2.
assumption.
destruct H2.
assumption.
Qed.
End LP2.
Section LP3.
(*3*)
(* Si Mariana estaba borracha, entonces Simon es el asesino o Mariana esta
mintiendo. Simon es el asesino o Mariana no estaba borracha y el crimen
ocurrio despues de la media noche. Si el crimen tuvo lugar despues de
la media noche, entonces Simon es el asesino o Mariana Miente. Ademas
sabemos que Mariana no miente cuando esta sobria.*)

(*P: Mariana estaba borracha*)
(*Q: Simon es el asesino*)
(*R: Mariana esta mintiendo*)
(*S: El crimen ocurrio despues de la media noche*)
Variables P Q R S : Prop.
Hypothesis H  : P -> (Q \/ R).
Hypothesis H0 : (Q \/ ~P ) /\ S.
Hypothesis H1 : S -> (Q \/ R).
Hypothesis H2 : ~P -> ~R.
Theorem assassin : Q.
Proof.
destruct H0.
destruct H1.
assumption.
assumption.
destruct H3.
assumption.
destruct H.
apply H2 in H3.
elim H3.
assumption.
assumption.
apply H2 in H3.
elim H3.
assumption.
Qed.
End LP3.
Section LP4.
(*4*)
(*Sabemos que alguien en el equipo consumio drogas. Cuando le preguntamos
a Sam, dijo que Michael o Bill consumieron drogas, pero que no es
posible que los dos. En cambio Michael dijo que o Richard o Sam consumieron
drogas, pero no ambos. Pero si le preguntamos a Bill, el afirma
que Michael y Matt son los mas probables a consumir drogas, pero no los
dos. Richard por su parte cree que Bill o Matt consumieron drogas, pero
no los dos. Por ultimo, Matt esta seguro que Bill o Richard consumieron
drogas, pero no los dos. Entre todos, Tom es el unico que dice que si
Richard consumio drogas, entonces Bill lo hizo tambien. En conclusion,
Matt o Michael consumieron drogas.*)

(*Q: Michael consumio drogas*)
(*R: Bill consumio drogas*)
(*S: Richard consumio drogas*)
(*T: Sam consumio drogas*)
(*U: Matt consumio drogas*)
Variables Q R S T U : Prop.
Hypothesis H  : Q \/ R \/ S \/ T \/ U.
Hypothesis H1 : (Q /\ ~R) \/ (~Q /\ R).
Hypothesis H2 : (S /\ ~T) \/ (~S /\ T).
Hypothesis H3 : (Q /\ ~U) \/ (~Q /\ U).
Hypothesis H4 : (R /\ ~U) \/ (~R /\ U).
Hypothesis H5 : (R /\ ~S) \/ (~R /\ S).
Hypothesis H6 : S -> R.
Lemma drugs : Q \/ U.
Proof.
destruct H.
left.
assumption.
destruct H0.
destruct H3.
destruct H7.
left.
assumption.
destruct H7.
right.
assumption.
destruct H0.
apply H6 in H0.
destruct H4.
destruct H7.
destruct H1.
destruct H9.
left.
assumption.
destruct H9.
destruct H3.
destruct H11.
left.
assumption.
destruct H11.
right.
assumption.
destruct H7.
right.
assumption.
destruct H0.
destruct H2.
destruct H7.
apply H6 in H7.
destruct H4.
destruct H9.
elim H8.
assumption.
destruct H9.
right.
assumption.
destruct H7.
destruct H4.
destruct H9.
destruct H3.
destruct H11.
left.
assumption.
right.
destruct H11.
assumption.
destruct H9.
right.
assumption.
right.
assumption.
Qed.
End LP4.
Section LP5.
(*5*)
(*Si el euro esta fuerte, el petroleo esta barato pero las exportaciones
resultan caras. Si Europa se endeuda o la economıa no crece, el petroleo no
estara barato. La economıa crece si y solo si ni las exportaciones resultan
caras ni la inflacion aumenta. Por tanto, si la inflacion aumenta, el euro
no esta fuerte*)

(*P: El euro esta fuerte*)
(*Q: El petroleo esta barato*)
(*R: Las exportaciones resultan caras*)
(*S: Europa se endeuda*)
(*T: La economia crece*)
(*U: La inflacion aumenta*)
Variables P Q R S T U : Prop.
Hypothesis H  : P -> (Q /\ R).
Hypothesis H0 : (S \/ ~T) -> ~Q.
Hypothesis H1 : T <-> (~R /\ ~U).
Theorem euro : U -> ~P.
Proof.
intro.
intro.
destruct H.
assumption.
apply H0.
destruct H1.
destruct H6.
apply H7.
split.
intro.
apply H0.
right.
intro.
apply H1.
assumption.
assumption.
assumption.
intro.
apply H0.
right.
intro.
apply H1.
assumption.
assumption.
assumption.
elim H6.
assumption.
assumption.
Qed.
End LP5.
Section LP6.
(*6*)
(*Un bar tiene las siguientes reglas para sus miembros:
I. Todo miembro que no sea escoces tiene medias.
II. Todo miembro o usa falda o no usa medias.
III. Las personas casadas no van los domingos.
IV. Una persona va el domingo si y solamente si es escoces.
V. Toda persona que usa falda es escoces y esta casado.
VI. Todo escoces usa falda.
Se puede concluir entonces que a este bar no viene nadie*)

(*P: Es escoces*)
(*Q: Tiene medias*)
(*R: Usa falda*)
(*S: Es casado*)
(*T: Va el domingo*)
Variables P Q R S T : Prop.
Hypothesis H  : ~P -> Q.
Hypothesis H0 : R \/ ~Q.
Hypothesis H1 : S -> ~T.
Hypothesis H2 : T <-> P.
Hypothesis H3 : R -> (P /\ S).
Hypothesis H4 : P -> R.
Theorem empty : False.
Proof.
apply H1.
destruct H3.
destruct H0.
apply H3 in H5.
destruct H5.
apply H4.
assumption.
elim H5.
apply H.
intro.
apply H4 in H6.
apply H3 in H6.
destruct H6.
apply H1.
assumption.
apply H2.
assumption.
assumption.
destruct H0.
apply H3 in H5.
destruct H5.
apply H2.
assumption.
elim H5.
apply H.
intro.
apply H1.
apply H3.
apply H4.
assumption.
apply H2.
assumption.
Qed.
End LP6.


Require Import Arith.
Require Import Omega.
Require Import List.
Require Import ott_list_support.
Require Import ott_list_base.

Section Lists.

Variables A B C : Set.
Implicit Types x : A.
Implicit Types y : B.
Implicit Types z : C.
Implicit Types xs l : list A.
Implicit Types ys : list B.
Implicit Types zs : list C.
Implicit Types f : A -> B.
Implicit Types g : B -> C.
Implicit Types m n : nat.
Set Implicit Arguments.

Ltac case_eq foo :=
  generalize (refl_equal foo);
  pattern foo at -1;
  case foo.

(*** Nth element ***)

Unset Implicit Arguments.

Fixpoint nth_safe l n {struct l} : n < length l -> A :=
  match l as l1, n as n1 return n1 < length l1 -> A with
    | h::t, 0 => fun H => h
    | h::t, S m => fun H => nth_safe t m (le_S_n _ _ H)
    | nil, _ => fun H => match le_Sn_O _ H with end
  end.
Implicit Arguments nth_safe [].

Lemma nth_safe_eq_nth_error :
  forall l n H, value (nth_safe l n H) = nth_error l n.
Proof.
  induction l; intro n; pose (F := le_Sn_O n); destruct n; try (contradiction || tauto).
  simpl length; intro H.
  simpl nth_error; rewrite <- (IHl n (le_S_n _ _ H)).
  reflexivity.
Qed.

Lemma nth_safe_proof_irrelevance :
  forall l n H H', nth_safe l n H = nth_safe l n H'.
Proof.
  intros. assert (value (nth_safe l n H) = value (nth_safe l n H')).
  transitivity (nth_error l n);
    apply nth_safe_eq_nth_error || (symmetry; apply nth_safe_eq_nth_error).
  injection H0; trivial.
Qed.

Lemma nth_safe_cons :
  forall x l n H,
    nth_safe (x::l) (S n) H = nth_safe l n (le_S_n (S n) (length l) H).
Proof. intros. reflexivity. Qed.

Lemma nth_safe_app :
  forall l l' n (H:n<length l),
    exists H', nth_safe l n H = nth_safe (l++l') n H'.
Proof.
  induction l; intros. solve [contradiction (le_Sn_O n H)].
  destruct n.
  simpl length. assert (H' : 0 < S (length (l ++ l')));
                  [solve [auto with arith] | exists H'; reflexivity].
  simpl app. simpl length.
  elim (IHl l' n (le_S_n (S n) (length l) H)); intros. rename x into H'.
  exists (le_n_S (S n) (length (l ++ l')) H').
  rewrite (nth_safe_cons a l n H). rewrite H0.
  pose (H'' := le_S_n _ _ (le_n_S _ _ H')).
  rewrite (nth_safe_proof_irrelevance (l++l') n H' H'').
  unfold H''. rewrite <- (nth_safe_cons a (l++l') n (le_n_S _ _ H')).
  reflexivity.
Qed.

Set Implicit Arguments.

Lemma nth_error_in :
  forall l n H, nth_error l n = value (nth_safe l n H).
Proof. symmetry. apply nth_safe_eq_nth_error. Qed.

Lemma nth_error_nil : forall n, nth_error (@nil A) n = error.
Proof. destruct n; reflexivity. Qed.

Lemma nth_error_out :
  forall l n, length l <= n -> nth_error l n = error.
Proof.
  induction l; intros n H. solve [apply nth_error_nil].
  simpl in H. destruct n. assert False; [omega | intuition].
  simpl. apply IHl. omega.
Qed.

Lemma nth_error_app_prefix :
  forall l l' n H, nth_error (l++l') n = value (nth_safe l n H).
Proof.
  intros.
  assert (H' : n < length (l ++ l')).
  rewrite (length_app l l'). solve [auto with arith].
  transitivity (value (nth_safe (l++l') n H')).
  solve [apply nth_error_in].
  assert ((nth_safe l n H) = (nth_safe (l ++ l') n H')).
  elim (nth_safe_app l l' n H). intros.
  rewrite H0. apply nth_safe_proof_irrelevance.
  rewrite H0. reflexivity.
Qed.

Lemma nth_error_app_suffix :
  forall l l' n, nth_error (l++l') (length l + n) = nth_error l' n.
Proof.
  induction l; intros; simpl; auto.
Qed.

Lemma nth_error_dec :
  forall l n, nth_error l n = match le_lt_dec (length l) n with
                                | left _ => error
                                | right H => value (nth_safe l n H)
                              end.
Proof.
  intros l n; generalize l; clear l. induction n; destruct l; try reflexivity.
  simpl nth_error. simpl length. rewrite (IHn l); clear IHn.
  decompose sum (lt_eq_lt_dec (length l) n);
    destruct (le_lt_dec (length l) n);
    destruct (le_lt_dec (S (length l)) (S n));
    reflexivity ||
    (assert False; [omega | intuition]) ||
    simpl.
  match match goal with |- ?g => g end with value ?lhs = value ?rhs =>
    assert (Eq : lhs=rhs)
  end. apply nth_safe_proof_irrelevance. rewrite Eq; reflexivity.
Qed.

Lemma nth_error_length :
  forall l n, match nth_error l n with
                | value _ => n < length l
                | error => n >= length l
              end.
Proof.
  induction l; intros; destruct n; try solve [compute; auto with arith].
  simpl. pose (H := IHl n).
  case_eq (nth_error l n); intros;
    rewrite H0 in H; auto with arith.
Qed.

Lemma nth_error_value :
  forall l n x, nth_error l n = value x -> n < length l.
Proof. intros; assert (L := nth_error_length l n). rewrite H in L; exact L. Qed.
Lemma nth_error_error :
  forall l n, nth_error l n = error -> n >= length l.
Proof. intros; assert (L := nth_error_length l n). rewrite H in L; exact L. Qed.

Lemma nth_eq_nth_safe :
  forall l n default,
    nth n l default = match le_lt_dec (length l) n with
                        | left _ => default
                        | right H => nth_safe l n H
                      end.
Proof.
  induction l; destruct n; reflexivity || intros. simpl nth; simpl length.
  destruct (le_lt_dec (S (length l)) (S n));
    case_eq (le_lt_dec (length l) n); intros;
    [idtac | elimtype False; omega | elimtype False; omega | idtac];
    pose (H' := IHl n default); rewrite H in H'; rewrite H'.
  reflexivity. simpl; apply nth_safe_proof_irrelevance.
Qed.

Lemma nth_eq_nth_error :
  forall l n default,
    nth n l default = match nth_error l n with
                        | value x => x
                        | error => default
                      end.
Proof.
  induction l; destruct n; intros; try reflexivity. simpl; apply IHl.
Qed.

End Lists.

Implicit Arguments nth_safe [A].
Implicit Arguments nth_safe_eq_nth_error [A].
Implicit Arguments nth_safe_proof_irrelevance [A].
Implicit Arguments nth_safe_cons [A].
Implicit Arguments nth_safe_app [A].

Hint Rewrite nth_map nth_ok_map nth_error_map : lists.
Hint Rewrite nth_error_nil : lists.
Hint Rewrite nth_error_in nth_error_out using omega : list_nth_error.
Hint Rewrite nth_error_dec : list_nth_dec.
Hint Resolve nth_error_value nth_error_error : datatypes.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Modus_Tollens.

Coq < Goal forall p q:Prop, ((p -> q) /\ ~(q)) -> ~p.
1 subgoal

  ============================
   forall p q : Prop, (p -> q) /\ ~ q -> ~ p

Unnamed_thm < intros.
1 subgoal

  p : Prop
  q : Prop
  H : (p -> q) /\ ~ q
  ============================
   ~ p

Unnamed_thm < elim H.
1 subgoal

  p : Prop
  q : Prop
  H : (p -> q) /\ ~ q
  ============================
   (p -> q) -> ~ q -> ~ p

Unnamed_thm < intro.
1 subgoal

  p : Prop
  q : Prop
  H : (p -> q) /\ ~ q
  H0 : p -> q
  ============================
   ~ q -> ~ p

Unnamed_thm < intro.
1 subgoal

  p : Prop
  q : Prop
  H : (p -> q) /\ ~ q
  H0 : p -> q
  H1 : ~ q
  ============================
   ~ p

Unnamed_thm < unfold not.
1 subgoal

  p : Prop
  q : Prop
  H : (p -> q) /\ ~ q
  H0 : p -> q
  H1 : ~ q
  ============================
   p -> False

Unnamed_thm < intro.
1 subgoal

  p : Prop
  q : Prop
  H : (p -> q) /\ ~ q
  H0 : p -> q
  H1 : ~ q
  H2 : p
  ============================
   False

Unnamed_thm < apply H1.
1 subgoal

  p : Prop
  q : Prop
  H : (p -> q) /\ ~ q
  H0 : p -> q
  H1 : ~ q
  H2 : p
  ============================
   q

Unnamed_thm < apply H0.
1 subgoal

  p : Prop
  q : Prop
  H : (p -> q) /\ ~ q
  H0 : p -> q
  H1 : ~ q
  H2 : p
  ============================
   p

Unnamed_thm < exact H2.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
unfold not.
intro.
apply H1.
apply H0.
exact H2.

Unnamed_thm is defined

Coq <

*)

Section Modus_Tollens.
Goal forall p q:Prop, ((p -> q) /\ ~(q)) -> ~p.
intros.
elim H.
intro.
intro.
unfold not.
intro.
apply H1.
apply H0.
exact H2.
Qed.


Require Import Coq.Lists.List NArith Lia. Import ListNotations.
From SyDPaCC.Core Require Import Bmf Diffusion.
Require Import SyDPaCC.Support.NList.
Set Implicit Arguments.
Generalizable All Variables.

Open Scope N_scope.

(* ---------------------------------------------------- *)

(** * BM: Bracket Matching *)

(** The bracket matching algorithm determines whether the brackets
    (possibly of several kind) in a given string are correctly
    matched.  For example it is the case in [(3-2)*3]*{8} but not in
    {2+1]. *)

(** ** A Module Type for Characters *)

(** We consider that strings are lists of characters and we consider a
    module type for characters. We need three operations on
    characters:
    - is_open that indicates whether a character is an opening
      bracket,
    - is_close that indicates whether a character is a closing
      bracket,
    - are_matched that indicates whether two characters are matching
      brackets. *)

Module Type CHAR.
  Parameter t : Type.
  Parameter is_open: t->bool.
  Parameter is_close: t->bool.
  Parameter are_matched: t->t->bool.
  Axiom not_open_close:
    forall c, is_open c = true -> is_close c = false.
  Axiom not_close_open:
    forall c, is_close c = true -> is_open c = false.
  Axiom matched_open_close:
    forall c c', are_matched c c' = true ->
            is_open c = true /\ is_close c' = true.
End CHAR.

(** ** An Efficient Bracket Matching Algorithm *)

Module Make(Import Char: CHAR).

  Definition is_empty `(xs:list A) : bool :=
    match xs with
    | [] => true
    | _  => false
    end.

  Fixpoint bm_spec (s:list Char.t)(cs: list Char.t) : bool :=
    match cs with
    | [ ] => is_empty s
    | c::cs =>
      if is_open c
      then bm_spec (c::s) cs
      else if is_close c
           then match s with
                | [] => false
                | c'::s' => if are_matched c' c then bm_spec s' cs else false
                end
           else bm_spec s cs
    end.

  Definition g1 c s : bool  :=
    if is_open c
    then true
    else if is_close c
         then match s with
              | [] => false
              | c'::s => are_matched c' c
              end
         else true.

  Definition g2 c s :=
    if is_open c
    then c::s
    else if is_close c
         then List.tl s
         else s.

  Fixpoint bm1 s cs : bool :=
    match cs with
    | [] => is_empty s
    | c::cs => (g1 c s) && (bm1 (g2 c s) cs)
    end.

  #[export] Instance opt_bm1 s : Opt (bm_spec s)(bm1 s).
  Proof.
    constructor; intros cs; generalize s; clear s; induction cs as [ | c cs IH ]; intro s.
    - trivial.
    - simpl; unfold g1, g2.
      destruct (is_open c); destruct(is_close c); try now rewrite IH.
      destruct s as [ | c' s' ]; auto; now rewrite IH.
  Qed.

  Module Stack.

    Unset Implicit Arguments.

    Record t := mk
      { data: list Char.t;
        pu: N;
        po: N;
        inv: pu = length data }.

    Set Implicit Arguments.

    Fact stack_eq:
      forall s1 s2 pu1 pu2 po1 po2 inv1 inv2,
        s1 = s2 ->
        pu1 = pu2 ->
        po1 = po2 ->
        mk s1 pu1 po1 inv1 = mk s2 pu2 po2 inv2.
    Proof.
      intros s1 s2 pu1 pu2 po1 po2 inv1 inv2 Hs Hu Ho.
      now subst.
    Qed.

    Definition empty : t := mk [] 0 0 eq_refl.

    Definition is_empty (s:t) : bool :=
      match s with
      | mk [] 0 0 _ => true
      | _ => false
      end.

    Fact length_cons_eq:
      forall A (x:A) xs n,
        n = length xs -> N.succ n = length(x::xs).
      intros A x xs n H; simpl; rewrite H; lia.
    Qed.

    Definition push c s : t :=
      match s with
      | mk cs npush npop H => mk (c::cs) (N.succ npush) npop (length_cons_eq _ _ H)
      end.

    Definition pop (s:t) : t.
      refine(
          match s with
          |mk [] 0 npop H => mk [] 0 (N.succ npop) H
          |mk (c::cs) npush  npop H => mk cs (npush-1) (N.succ npop) _
          | _ => _
          end).
      - discriminate.
      - simpl in H; rewrite H; lia.
    Defined.

    Definition of_list cs : t :=
      mk cs (length cs) 0 eq_refl.

  End Stack.

  Definition g1' c (s:Stack.t) : bool  :=
    if is_open c
    then true
    else if is_close c
         then match s with
              | Stack.mk []  _  _ _ => false
              | Stack.mk (c'::s) _ _ _ => are_matched c' c
              end
         else true.

  Definition otimes (s s': Stack.t) : Stack.t.
    refine(
        match (s', s) with
        | (Stack.mk cs1 n1 m1 inv1, Stack.mk cs2 n2 m2 inv2) =>
          Stack.mk
            (if n2 <=? m1 then cs1 else cs1++(skipn m1 cs2))
            (if n2 <=? m1 then n1 else n1+(n2-m1))
            (if n2 <=? m1 then (m1 - n2) + m2 else m2)
            _
        end).
    destruct(n2 <=? m1) eqn:Hle; auto.
    autorewrite with length.
    rewrite <- inv1, <- inv2.
    lia.
  Defined.

  Infix "⊗" := otimes (at level 70).

  #[export] Instance otimes_monoid: Monoid otimes Stack.empty.
  Proof.
    repeat constructor.
    - intros [s1 pu1 po1 inv1] [s2 pu2 po2 inv2] [s3 pu3 po3 inv3]; unfold otimes; simpl.
      apply Stack.stack_eq; destruct(pu1 <=? po2) eqn:H1;destruct(pu2 <=? po3) eqn:H2;
        destruct( pu2 + (pu1 - po2) <=? po3) eqn:H3; destruct(pu1 <=? po3 - pu2 + po2) eqn:H4;
          simpl; try rewrite H1; try rewrite H2; simpl; trivial;
            repeat match goal with
                   | [ H: _ <=? _ = true   |- _] => apply N.leb_le in H
                   | [ H: _ <=? _ = false  |- _] => apply N.leb_nle in H; apply N.nle_gt in H
                   end;
            try (lia); subst.
      + now rewrite skipn_app2, skipn_skipn by (lia).
      + now rewrite skipn_app1, List.app_assoc by (lia).
    - intros [s1 pu1 po1 inv1]; unfold otimes; simpl.
      assert(0 <=? po1 = true) as Hcond
          by (apply N.leb_le; lia).
      rewrite Hcond; f_equal; lia.
    - intros [ [ | c1 s1 ] pu1 po1 inv1].
      + unfold otimes, Stack.empty; now rewrite inv1.
      + unfold otimes, Stack.empty; subst.
        assert(length(c1::s1) <=? 0 = false) as Hcond
            by (apply N.leb_nle; apply N.nle_gt; autorewrite with length; lia).
        rewrite Hcond; simpl; apply Stack.stack_eq; trivial; lia.
  Qed.

  Definition g3 c : Stack.t :=
    if is_open c
    then Stack.push c Stack.empty
    else if is_close c
         then Stack.pop Stack.empty
         else Stack.empty.

  Definition g2' c s :=
    s ⊗ (g3 c).

  Fixpoint bm2 (s:Stack.t) cs :=
    match cs with
    | [] => Stack.is_empty s
    | c::cs => andb (g1' c s) (bm2 (g2' c s) cs)
    end.

  Fact bm2_pi:
    forall cs s s' pu pu' po po' H H',
      s = s' ->
      pu = pu' ->
      po = po' ->
      bm2 (Stack.mk s pu po H)  cs =
      bm2 (Stack.mk s' pu' po' H') cs.
  Proof.
    intros cs s s' pu pu' po po' H H' H0 H1 H2; now subst.
  Qed.

  Lemma bm1_bm2_eq:
    forall cs s,
      bm1 s cs = bm2 (Stack.of_list s) cs.
  Proof.
    induction cs as [ | c cs' IHcs ]; destruct s as [ | c' s' ]; trivial.
    - simpl; rewrite IHcs; unfold g1, g1', g2, g2', g3, otimes.
      destruct (is_open c) eqn:HO; destruct(is_close c) eqn:HC; simpl; trivial.
      + apply Char.not_open_close in HO; rewrite HO in HC; discriminate.
      + now apply bm2_pi.
    - simpl; rewrite IHcs; unfold g1, g1', g2, g2', g3, otimes; simpl.
      destruct (is_open c) eqn:HO; destruct(is_close c) eqn:HC; trivial.
      + apply Char.not_open_close in HO; rewrite HO in HC; discriminate.
      + apply bm2_pi;
        destruct(N.succ(length s') <=? 0) eqn:H; auto;
          try apply N.leb_le in H; try (lia).
        autorewrite with length. lia.
      + assert(forall n, N.succ(N.succ n) <=? 1 = false) as Hcond
            by (intro;apply N.leb_nle; apply N.nle_gt; lia).
        f_equal; unfold Stack.of_list; apply bm2_pi;
          destruct s'; auto; simpl; rewrite Hcond; trivial.
        lia.
      + f_equal; simpl; unfold Stack.of_list.
        assert(forall n, N.succ n <=? 0 = false) as Hcond
            by (intro;apply N.leb_nle; apply N.nle_gt; lia).
        rewrite Hcond; apply bm2_pi; trivial; autorewrite with length.
        lia.
  Qed.

  #[export] Instance opt_bm2 s:
    Opt (bm1 s)(bm2 (Stack.of_list s)).
  Proof.
    constructor; intro; apply bm1_bm2_eq.
  Qed.

  #[export] Instance bm2_accumulate s:
    Opt (bm2 s)(accumulate Stack.is_empty (prod_curry g1') g3 andb otimes s).
  Proof.
    constructor; intro cs; generalize s; clear s;
      induction cs as [ | c cs IH]; intro s.
    - trivial.
    - simpl; f_equal; now rewrite IH.
  Qed.

End Make.

Close Scope N_scope.


Require Import Coq.Setoids.Setoid Coq.Lists.List Coq.Sorting.Permutation
        Fiat.Common.List.FlattenList
        Fiat.Common.SetEq.

Definition IsSetEqSafe {A B: Type} (proc: list A -> list B) :=
  forall (seq1 seq2: list A),
    SetEq seq1 seq2 ->
    SetEq (proc seq1) (proc seq2).

Lemma SetEq_modulo_SetEqSafe_fun :
  forall {A B: Type},
  forall (seq1: list B) (seq2 seq3: list A),
  forall (proc: list A -> list B),
    SetEq seq2 seq3 ->
    IsSetEqSafe proc ->
    (SetEq seq1 (proc seq2) <-> SetEq seq1 (proc seq3)).
Proof.
  intros; eauto using SetEq_trans_iff_2.
Qed.

Lemma SetEq_after_map :
  forall {A B: Type} (seq1 seq2: list A),
  forall (proc: A -> B),
    SetEq seq1 seq2 -> SetEq (map proc seq1) (map proc seq2).
Proof.
  intros ? ? ? ? ? set_eq;
  unfold SetEq in *;
  intro x;
  split;
  intros in_map;
  rewrite in_map_iff in in_map;
  destruct in_map as [pred (is_pred, pred_in_list)];
  specialize (set_eq pred);
  subst;
  intuition;
  eauto using in_map.
Qed.

Lemma map_modulo_SetEq :
  forall {A B: Type} (seq1 seq1': list A) (seq2: list B),
  forall (proc: A -> B),
    SetEq seq1 seq1' ->
    (SetEq (map proc seq1) (seq2) <-> SetEq (map proc seq1') (seq2)).
Proof.
  intros;
  simpl;
  apply SetEq_trans_iff;
  apply SetEq_after_map;
  trivial.
Qed.

Lemma IsSetEqSafe_map :
  forall {A B: Type} (proc: A -> B),
    IsSetEqSafe (fun x => List.map proc x).
Proof.
  unfold IsSetEqSafe;
  eauto using SetEq_after_map.
Qed.

Lemma IsSetEqSafe_filter :
  forall {A: Type} (pred: A -> bool),
    IsSetEqSafe (fun x => List.filter pred x).
Proof.
  unfold IsSetEqSafe, SetEq;
  intros;
  repeat rewrite filter_In;
  specialize (H x);
  intuition.
Qed.

(** TODO FIXME: These instances take priority when they should not! *)
Add Parametric Relation (A: Type) : (list A) (@SetEq A)
    reflexivity proved by SetEq_Reflexive
    symmetry proved by SetEq_Symmetric
    transitivity proved by SetEq_Transitive
      as set_eq.

Add Parametric Morphism {A: Type} (x: A) :
  (List.In x)
    with signature (@SetEq A ==> iff)
      as in_morphism.
Proof.
  intros s1 s2;
  unfold SetEq;
  intros;
  eauto.
Qed.

Add Parametric Morphism {A B: Type} (proc: A -> B) :
  (List.map proc)
    with signature (@SetEq A ==> @SetEq B)
      as map_morphism.
Proof.
  apply IsSetEqSafe_map.
Qed.

Add Parametric Morphism {A: Type} (pred: A -> bool) :
  (List.filter pred)
    with signature (@SetEq A ==> @SetEq A)
      as filter_morphism.
Proof.
  apply IsSetEqSafe_filter.
Qed.

Add Parametric Morphism {A: Type} :
  flatten
    with signature (@SetEq (list A) ==> @SetEq A)
      as concat_right_morphism.
Proof.
  unfold SetEq;
  setoid_rewrite in_flatten_iff;
  firstorder.
Qed.

Add Parametric Morphism {A: Type} : (@SetUnion A)
    with signature (@SetEq A ==> @SetEq A ==> @SetEq A)
      as union_morphism.
Proof.
  unfold SetEq, SetUnion;
  intros;
  rewrite ! in_app_iff;
  intuition;
  repeat match goal with
           | [ H: List.In ?x _, H': forall _, _ |- _ ] => try specialize (H' x)
         end;
  tauto.
Qed.

Lemma SetEq_append : (* TODO: Rename to cons *)
  forall {A: Type} (seq1 seq2: list A) (x: A),
    SetEq seq1 seq2 -> SetEq (x :: seq1) (x :: seq2).
Proof.
  intros A s1 s2 x s_eq;
  unfold SetEq;
  split; intro H;
  simpl in *;
  [rewrite s_eq in H | rewrite <- s_eq in H];
  intuition.
Qed.

Lemma seteq_nil_nil :
  forall {A} seq,
    @SetEq A seq nil <-> seq = nil.
Proof.
  unfold SetEq.
  intros; destruct seq.

  tauto.
  split; [ | discriminate ].
  intro H; specialize (H a).
  exfalso; simpl in H; rewrite <- H; eauto.
Qed.

Lemma seteq_nil_nil' :
  forall {A} seq,
    @SetEq A nil seq <-> seq = nil.
Proof.
  setoid_rewrite SetEq_Symmetric_iff.
  intro; exact seteq_nil_nil.
Qed.


From playground Require Import prelude.

(** This file is adapted from _Software Foundations_. The name binding approach
mostly follows the paper _The Locally Nameless Representation_, and is inspired
by the Coq development _formalmetacoq_ by the same author. *)

Module stlc.

Import atom_instance.

#[global]
Opaque atom.
#[global]
Opaque amap.
#[global]
Opaque aset.
#[global]
Opaque is_atom.

Section lang.

Implicit Types (x y : atom) (L : aset).

(** * Syntax *)

(** ** Type (τ) *)
Inductive ty : Type :=
| TBool
| TArrow (τ1 τ2 : ty)
.

(** ** Term (t) *)
Inductive tm : Type :=
| MFVar (x : atom)
| MBVar (k : nat)
| MApp (t1 t2 : tm)
| MAbs (τ : ty) (t : tm)
| MTrue
| MFalse
| MIf (t0 t1 t2 : tm)
.

Declare Custom Entry stlc.
Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "τ1 -> τ2" := (TArrow τ1 τ2) (in custom stlc at level 50,
                                          right associativity).
Notation "t1 t2" := (MApp t1 t2) (in custom stlc at level 1, left associativity).
Notation "\ : τ , t" :=
  (MAbs τ t) (in custom stlc at level 90,
                 τ custom stlc at level 99,
                 t custom stlc at level 99).

Coercion MFVar : atom >-> tm.
Coercion MBVar : nat >-> tm.

Notation "$ n" := (MBVar n) (in custom stlc at level 0, n constr at level 0,
                            format "$ n").
Notation "'Bool'" := TBool (in custom stlc at level 0).

Notation "'if' t0 'then' t1 'else' t2" :=
  (MIf t0 t1 t2) (in custom stlc at level 89,
                     t0 custom stlc at level 99,
                     t1 custom stlc at level 99,
                     t2 custom stlc at level 99,
                     left associativity).
Notation "'true'"  := true (at level 1).
Notation "'true'"  := MTrue (in custom stlc at level 0).
Notation "'false'"  := false (at level 1).
Notation "'false'"  := MFalse (in custom stlc at level 0).

(** * Examples *)

Definition idB :=
  <{ \:Bool, 0 }>.

Notation idBB :=
  <{\:Bool->Bool, 0}>.

Notation idBBBB :=
  <{\:((Bool->Bool)->(Bool->Bool)), 0}>.

Notation fstBB := <{\:Bool, \:Bool, 1}>.

Notation notB := <{\:Bool, if 0 then false else true}>.

(** * Small-step semantics *)

(** ** Variable opening *)
Reserved Notation "'[' k '~>' s ']' t" (in custom stlc at level 20, k constr,
                                           format "[ k '~>' s ] t").
Fixpoint open_ (k : nat) (s : tm) (t : tm) : tm :=
  match t with
  | <{ $n }> => if decide (k = n) then s else t
  | <{ \:τ, t }> => <{ \:τ, [S k~>s]t }>
  | <{ t1 t2 }> => <{ ([k~>s]t1) ([k~>s]t2) }>
  | <{ if t0 then t1 else t2 }> => <{ if ([k~>s]t0) then ([k~>s]t1) else ([k~>s]t2) }>
  | _ => t
  end
where "'[' k '~>' s ']' t" := (open_ k s t) (in custom stlc).

Definition open s t := open_ 0 s t.

Notation "t ^ s" := (open s t) (in custom stlc at level 20,
                               format "t ^ s").

(** ** Values (v) *)
Inductive value : tm -> Prop :=
  | VAbs τ t :
      value <{ \:τ, t }>
  | VTrue :
      value <{ true }>
  | VFalse :
      value <{ false }>.

(** ** Step relation *)
(* Unfortunately the notation --> is used in the standard library. *)
Reserved Notation "t '-->!' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
| SAppAbs τ t1 v2 :
    value v2 ->
    <{ (\:τ, t1) v2 }> -->! <{ t1^v2 }>
| SApp1 t1 t1' t2 :
    t1 -->! t1' ->
    <{ t1 t2 }> -->! <{ t1' t2 }>
| SApp2 v1 t2 t2' :
    value v1 ->
    t2 -->! t2' ->
    <{ v1 t2 }> -->! <{ v1 t2' }>
| SIfTrue t1 t2 :
    <{ if true then t1 else t2 }> -->! t1
| SIfFalse t1 t2 :
    <{ if false then t1 else t2 }> -->! t2
| SIf t0 t0' t1 t2 :
    t0 -->! t0' ->
    <{ if t0 then t1 else t2 }> -->! <{ if t0' then t1 else t2 }>

where "t '-->!' t'" := (step t t').

Notation multistep := (clos_refl_trans_1n _ step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

(** * Typing *)
Notation tctx := (amap ty).

Reserved Notation "Γ '⊢' t ':' τ" (at level 101,
                                   t custom stlc, τ custom stlc at level 0).
Inductive typing : tctx -> tm -> ty -> Prop :=
  | TVar Γ x τ :
      Γ !! x = Some τ ->
      Γ ⊢ x : τ
  | TAbs Γ τ1 τ2 t1 L :
      (forall x, x ∉ L -> <[x:=τ2]>Γ ⊢ t1^x : τ1) ->
      Γ ⊢ \:τ2, t1 : (τ2 -> τ1)
  | TApp Γ τ1 τ2 t1 t2 :
      Γ ⊢ t1 : (τ2 -> τ1) ->
      Γ ⊢ t2 : τ2 ->
      Γ ⊢ t1 t2 : τ1
  | TTrue Γ :
       Γ ⊢ true : Bool
  | TFalse Γ :
       Γ ⊢ false : Bool
  | TIf Γ t0 t1 t2 τ :
       Γ ⊢ t0 : Bool ->
       Γ ⊢ t1 : τ ->
       Γ ⊢ t2 : τ ->
       Γ ⊢ if t0 then t1 else t2 : τ

where "Γ '⊢' t ':' τ" := (typing Γ t τ).

(** * Infrastructure *)

(** ** Locally closed *)
Inductive lc : tm -> Prop :=
| LCVar x : lc <{ x }>
| LCTrue : lc <{ true }>
| LCFalse : lc <{ false }>
| LCIf t0 t1 t2 : lc t0 -> lc t1 -> lc t2 -> lc <{ if t0 then t1 else t2 }>
| LCApp t1 t2 : lc t1 -> lc t2 -> lc <{ t1 t2 }>
| LCAbs τ t L : (forall x, x ∉ L -> lc <{ t^x }>) -> lc <{ \:τ, t }>
.

(** ** Substitution *)
Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr,
                                       format "[ x ':=' s ] t").

Fixpoint subst (x : atom) (s : tm) (t : tm) : tm :=
  match t with
  | MFVar y => if decide (x = y) then s else t
  | <{ \:τ, t }> => <{ \:τ, [x:=s]t }>
  | <{ t1 t2 }> => <{ ([x:=s]t1) ([x:=s]t2) }>
  | <{ if t0 then t1 else t2 }> => <{ if ([x:=s]t0) then ([x:=s]t1) else ([x:=s]t2) }>
  | _ => t
  end

where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc).

(** ** Free variables *)
Fixpoint fv (t : tm) : aset :=
  match t with
  | MFVar x => {[x]}
  | <{ \:_, t }> => fv t
  | <{ t1 t2 }> => fv t1 ∪ fv t2
  | <{ if t0 then t1 else t2 }> => fv t0 ∪ fv t1 ∪ fv t2
  | _ => ∅
  end.

Notation "x # t" := (x ∉ fv t) (at level 40).

Definition closed t := fv t = ∅.

Instance atom_stale : @Stale aset atom := singleton.
Arguments atom_stale /.

Instance tm_stale : Stale tm := fv.
Arguments tm_stale /.

Instance tctx_stale : Stale tctx := dom aset.
Arguments tctx_stale /.

Instance aset_stale : Stale aset := id.
Arguments aset_stale /.

Lemma open_lc_ t : forall s u i j,
  <{ [j~>u]([i~>s]t) }> = <{ [i~>s]t }> ->
  i <> j ->
  <{ [j~>u]t }> = t.
Proof.
  induction t; hauto.
Qed.

Lemma open_lc t s :
  lc t -> forall k, <{ [k~>s]t }> = t.
Proof.
  induction 1; try qauto.

  (* TAbs *)
  - simpl_cofin.
    qauto use: open_lc_.
Qed.

Lemma subst_fresh t : forall x s,
  x # t -> <{ [x:=s]t }> = t.
Proof.
  induction t; qauto solve: fast_set_solver*.
Qed.

Lemma subst_open t : forall x s v,
  lc s ->
  <{ [x:=s](t^v) }> = <{ ([x:=s]t)^([x:=s]v) }>.
Proof.
  unfold open. generalize 0.
  induction t; hauto use: open_lc.
Qed.

Lemma subst_open_comm t x y s :
  x <> y ->
  lc s ->
  <{ [x:=s](t^y) }> = <{ ([x:=s]t)^y }>.
Proof.
  qauto use: subst_open.
Qed.

(** We may prove this one using [subst_open] and [subst_fresh], but a direct
induction gives us a slightly stronger version (without the local closure
constraint). *)
Lemma subst_intro t : forall s x,
  x # t ->
  <{ t^s }> = <{ [x:=s](t^x) }>.
Proof.
  unfold open. generalize 0.
  induction t; hauto simp+: set_unfold.
Qed.

(** Well-typed terms are locally closed. *)
Lemma typing_lc Γ t τ :
  Γ ⊢ t : τ ->
  lc t.
Proof.
  induction 1; eauto using lc.
Qed.

Lemma open_fresh t : forall x x',
  x # t ->
  x <> x' ->
  x # <{ t^x' }>.
Proof.
  unfold open. generalize 0.
  induction t; intros; simpl in *;
    qauto solve: fast_set_solver*.
Qed.

(* These lemmas are not needed in this development. *)
Lemma typing_rename_ Γ t τ τ' x y :
  <[x:=τ']>Γ ⊢ t : τ ->
  y ∉ fv t ∪ dom aset Γ ->
  <[y:=τ']>Γ ⊢ [x:=y]t : τ.
Proof.
  remember (<[x:=τ']>Γ) as Γ'.
  intros H. revert dependent Γ.
  induction H; intros; subst; simpl in *;
    try solve [ case_decide; subst; econstructor; set_unfold; by simplify_map_eq
              | econstructor; auto_apply; auto; fast_set_solver!! ].
  - econstructor.
    simpl_cofin.
    rewrite <- subst_open_comm by (eauto using lc; fast_set_solver!!).
    rewrite insert_commute by fast_set_solver!!.
    auto_apply.
    by rewrite insert_commute by fast_set_solver!!.
    set_unfold.
    qauto use: open_fresh.
Qed.

Lemma typing_rename Γ t τ τ' x y :
  <[x:=τ']>Γ ⊢ t^x : τ ->
  x ∉ fv t ∪ dom aset Γ ->
  y ∉ fv t ∪ dom aset Γ ->
  <[y:=τ']>Γ ⊢ t^y : τ.
Proof.
  intros.
  destruct (decide (y = x)); subst; eauto.
  rewrite subst_intro with (x:=x) by fast_set_solver!!.
  apply typing_rename_; eauto.
  set_unfold.
  qauto use: open_fresh.
Qed.

(** The admissible existential introduction form of abstraction. *)
Lemma TAbs_intro Γ τ1 τ2 t1 x :
  x ∉ fv t1 ∪ dom aset Γ ->
  <[x:=τ2]>Γ ⊢ t1^x : τ1 ->
  Γ ⊢ \:τ2, t1 : (τ2 -> τ1).
Proof.
  intros.
  econstructor.
  simpl_cofin.
  eapply typing_rename; eauto.
  fast_set_solver!!.
Qed.

(** * Metatheories *)

(** ** Progress *)
Theorem progress t τ :
  ∅ ⊢ t : τ ->
  value t \/ exists t', t -->! t'.
Proof.
  remember ∅ as Γ.
  induction 1; simplify_eq;
    hauto ctrs: value, step inv: value, typing.
Qed.

(** ** Preservation *)
Lemma weakening Γ Γ' t τ :
  Γ ⊢ t : τ ->
  Γ ⊆ Γ' ->
  Γ' ⊢ t : τ.
Proof.
  intros H. revert Γ'.
  induction H; intros;
    econstructor; intros; eauto using lookup_weaken, insert_mono.
Qed.

Lemma weakening_insert Γ t τ x τ' :
  x ∉ dom aset Γ ->
  Γ ⊢ t : τ ->
  <[x:=τ']>Γ ⊢ t : τ.
Proof.
  eauto using weakening, insert_fresh_subseteq.
Qed.

Lemma subst_preversation t Γ x v τ1 τ2 :
  <[x:=τ1]>Γ ⊢ t : τ2 ->
  Γ ⊢ v : τ1 ->
  Γ ⊢ <{ [x:=v]t }> : τ2.
Proof.
  intros H.
  remember (<[x:=τ1]>Γ) as Γ'.
  generalize dependent Γ.
  induction H; intros; subst; simpl;
    try qauto simp+: simplify_map_eq ctrs: typing.
  (* TAbs *)
  - econstructor.
    simpl_cofin.
    rewrite <- subst_open_comm by (eauto using typing_lc; fast_set_solver!!).
    auto_apply.
    by rewrite insert_commute by fast_set_solver!!.
    eauto using weakening_insert.
Qed.

Theorem preservation Γ t t' τ :
  Γ ⊢ t : τ ->
  t -->! t' ->
  Γ ⊢ t' : τ.
Proof.
  intros H. generalize dependent t'.
  induction H; intros ? Hs; sinvert Hs; subst;
    eauto using typing.
  (* TApp *)
  - select (_ ⊢ \:_, _ : _) (fun H => sinvert H).
    simpl_cofin.
    erewrite subst_intro by eauto.
    eauto using subst_preversation.
Qed.

(** ** Soundness *)
Definition stuck (t : tm) : Prop :=
  (nf step) t /\ ~ value t.

Corollary soundness t t' τ :
  ∅ ⊢ t : τ ->
  t -->* t' ->
  ~ (stuck t').
Proof.
  induction 2; qauto unfold: nf, stuck use: progress, preservation.
Qed.

End lang.
End stlc.