Require Export Db.Lemmas.
Require Export Utlc.SpecSyntax.
Require Export Utlc.SpecEvaluation.
Require Import Common.Common.
Require Import Common.Relations.

Require Import Omega.

Local Ltac crush :=
  intros;
  repeat
    (cbn in *;
     eauto with eval;
     repeat crushDbSyntaxMatchH;
     repeat crushUtlcSyntaxMatchH;
     repeat crushUtlcEvaluationMatchH;
     (* repeat crushDbLemmasMatchH; *)
     repeat crushDbLemmasRewriteH;
     repeat match goal with
                [ |- _ ∧ _ ] => split
              | [ |- evaln ?t ?t 0 ] => eapply stepRel_zero
              | [ H : eval ?t ?t', H' : evaln ?t' ?t'' ?n |- evaln ?t ?t'' (S ?n) ] => refine (stepRel_step eval _ _ _ _ H H')
              | [ |- _ ≤ _ ] => omega
            end;
     try subst);
  try discriminate;
  eauto.

Lemma eval₀_to_eval {t t'} : t -->₀ t' → t --> t'.
Proof.
  intros.
  eapply (eval_ctx₀ phole); crush.
Qed.

Section EvaluationContexts.

  Lemma pctx_app_sub' C :
    ∀ (ζ: Sub UTm) t,
      (pctx_app t C)[ζ] =
      pctx_app t[foldlDom up (depthlPCtx C) ζ] C[ζ].
  Proof. induction C; crush. Qed.

  Lemma pctx_app_sub C :
    ∀ (ζ: Sub UTm) t,
      (pctx_app t C)[ζ] =
      pctx_app t[ζ ↑⋆ depthPCtx C] C[ζ].
  Proof. induction C; crush. Qed.

  Lemma pctx_cat_app (t : UTm) (C₁ C₂ : PCtx) :
    pctx_app t (pctx_cat C₁ C₂) = pctx_app (pctx_app t C₁) C₂.
  Proof.
    induction C₂; crush.
  Qed.

  Lemma pctx_cat_assoc (C₁ C₂ C₃ : PCtx) :
    pctx_cat C₁ (pctx_cat C₂ C₃) = pctx_cat (pctx_cat C₁ C₂) C₃.
  Proof.
    induction C₃; crush.
  Qed.

  Lemma pctx_cat_phole_leftzero C : pctx_cat phole C = C.
  Proof.
    induction C; crush.
  Qed.

  Lemma ectx_cat (C₁ C₂: PCtx) :
    ECtx C₁ → ECtx C₂ → ECtx (pctx_cat C₁ C₂).
  Proof. induction C₂; crush. Qed.

  Lemma value_sub t (v: Value t) :
    ∀ (ζ: Sub UTm), Value t[ζ].
  Proof. induction t; crush. Qed.
  Hint Resolve value_sub.

  Lemma ectx_sub C (ectx_C: ECtx C) :
    ∀ (ζ: Sub UTm), ECtx C[ζ].
  Proof. induction C; crush. Qed.
  Hint Resolve ectx_sub.

End EvaluationContexts.

(* The following doesn't hold here: C[wrong] evaluates to wrong in single step *)
(* Lemma eval_ctx {C t t'}  : t --> t' -> ECtx C -> pctx_app t C --> pctx_app t' C. *)
(* Proof. *)
(*   induction 1. *)
(*   rewrite <- ?pctx_cat_app in *. *)
(*   eauto using ectx_cat with eval. *)
(* Qed. *)

Lemma eval_ctx {C t t'}  : t --> t' → t' ≠ wrong → ECtx C → pctx_app t C --> pctx_app t' C.
Proof.
  induction 1; intuition.
  rewrite <- ?pctx_cat_app in *.
  eauto using ectx_cat with eval.
Qed.

Section Values.

  Lemma value_ectx_inv {C} (eC: ECtx C) :
    ∀ t, Value (pctx_app t C) → Value t.
  Proof. induction C; cbn in *; intuition. Qed.

  Lemma ectx_wrong_not_value {C} : ECtx C -> ¬ (Value (pctx_app wrong C)).
  Proof.
    intros ec val.
    apply value_ectx_inv in val; crush.
  Qed.

  Lemma values_are_eval₀_normal {t t'} :
    Value t → t -->₀ t' → False.
  Proof. inversion 2; crush. Qed.

  Lemma values_are_normal {t : UTm} : Value t → normal t.
  Proof.
    intros vt; induction 1 as [? ? ? r'|?];
      apply value_ectx_inv in vt;
      eauto using values_are_eval₀_normal.
  Qed.
  Global Arguments values_are_normal {_} _ {_} _.

  Lemma wrong_normal : normal wrong.
  Proof.
    intros t' e.
    depind e.
    - destruct C; crush.
      inversion H.
    - destruct C; crush.
  Qed.

  Corollary wrong_evalStar_inv {t} : wrong -->* t → t = wrong.
  Proof.
    intros es. depind es; crush.
    exfalso; eapply wrong_normal; crush.
  Qed.
End Values.

Section CtxEval.
  Lemma eval₀_ctxeval {t t'} : t -->₀ t' → ctxeval t t'.
  Proof.
    apply (mkCtxEval phole _ _ I).
  Qed.

  Lemma ctxeval_eval {t t'} : ctxeval t t' → t --> t'.
  Proof.
    destruct 1.
    refine (eval_ctx₀ _ _ _); assumption.
  Qed.

  Lemma ctxevaln_evaln {t t' n} : ctxevaln t t' n → evaln t t' n.
  Proof.
    induction 1; econstructor; eauto using ctxeval_eval with eval.
  Qed.

  (* The following implication is actually an equivalence, but we don't need that. *)
  Lemma ctxeval_eval_ctx {t t'} : ctxeval t t' → forall Cu, ECtx Cu → pctx_app t Cu --> pctx_app t' Cu.
  Proof.
    destruct 1; intros; rewrite <- ?pctx_cat_app; eauto using ectx_cat with eval.
  Qed.

  Lemma ctxevaln_evaln_ctx {t t' n} : ctxevaln t t' n → forall Cu, ECtx Cu → evaln (pctx_app t Cu) (pctx_app t' Cu) n.
  Proof.
    induction 1; unfold evaln in *;
    econstructor; eauto using ctxeval_eval_ctx with eval.
  Qed.

  Lemma extend_ctxeval tu tu' Cu : ECtx Cu → ctxeval tu tu' → ctxeval (pctx_app tu Cu) (pctx_app tu' Cu).
  Proof.
    intros eCu ce.
    induction ce.
    rewrite <- ?pctx_cat_app.
    eauto using ctxeval, ectx_cat.
  Qed.

  Lemma extend_ctxevalStar {tu tu'} Cu : ECtx Cu → ctxevalStar tu tu' → ctxevalStar (pctx_app tu Cu) (pctx_app tu' Cu).
  Proof.
    intros eCu ce.
    unfold ctxevalStar.
    induction ce;
    eauto using extend_ctxeval with eval.
  Qed.

  Lemma extend_ctxevalStar' {tu1 tu2 tu1' tu2' Cu} :
    ctxevalStar tu1 tu2 →
    tu1' = pctx_app tu1 Cu →
    tu2' = pctx_app tu2 Cu →
    ECtx Cu → ctxevalStar tu1' tu2'.
  Proof.
    intros; subst; eauto using extend_ctxevalStar.
  Qed.
End CtxEval.

Section EvalN.
  Lemma evaln_to_evalStar {t t' n} :
    evaln t t' n → t -->* t'.
  Proof.
    induction 1; crush.
  Qed.

  Lemma evalStar_to_evaln {t t'} :
    t -->* t' → exists n, evaln t t' n.
  Proof.
    induction 1;
    [exists 0|destruct IHclos_refl_trans_1n as (n & en); exists (S n)];
    crush.
  Qed.

  Lemma evaln_to_evalPlus {t t' n} :
    evaln t t' (S n) → t -->+ t'.
  Proof.
    inversion 1; subst;
      eauto using evalStepStarToPlus, evaln_to_evalStar.
  Qed.

  Lemma ctxevaln_ctx {t t' n} :
    ctxevaln t t' n -> forall C, ECtx C → evaln (pctx_app t C) (pctx_app t' C) n.
  Proof.
    intros ec C eC; unfold evaln.
    induction ec; eauto using ctxeval_eval_ctx with eval.
  Qed.

  Lemma evaln_split {t t' } n n':
    evaln t t' (n + n') → exists t'', evaln t t'' n ∧ evaln t'' t' n'.
  Proof.
    revert t; induction n.
    - intros; exists t; crush.
    - intros t esn; depind esn; clear IHesn.
      destruct (IHn t' esn) as (t3 & es1 & es2).
      exists t3; crush.
  Qed.
End EvalN.

Section Termination.

  Lemma TerminatingI' (t: UTm) (vt: Value t) :
    ∀ t', t --> t' → t'⇓.
  Proof. intros t' r; elim (values_are_normal vt r). Qed.

  Lemma TerminatingIV' (t: UTm) (vt: Value t) :
    ∀ t' n, t --> t' → t'⇓_n.
  Proof. intros t' n r; elim (values_are_normal vt r). Qed.

  Lemma values_terminate (t: UTm) (vt: Value t) :
    t ⇓.
  Proof. exists t; crush. Qed.

  Lemma values_terminateN (t: UTm) (vt: Value t) :
    ∀ n, t ⇓_ n.
  Proof.
    exists t, 0; crush.
  Qed.

  Lemma TerminatingN_Terminating {t : UTm} {n} : t ⇓_ n -> t ⇓.
  Proof.
    destruct 1 as (v & m & vv & ineq & esm).
    exists v; eauto using evaln_to_evalStar with eval.
  Qed.

  Lemma Terminating_TerminatingN {t : UTm} : t ⇓ -> exists n, t ⇓_ n.
  Proof.
    destruct 1 as (v & vv & es).
    destruct (evalStar_to_evaln es) as (n & esn).
    exists n; exists v, n; crush.
  Qed.

End Termination.

Section SubstEval.

  Hint Resolve value_sub.
  Hint Resolve ectx_sub.

  Lemma eval₀_closed_under_substitution {t1 t2} (r: t1 -->₀ t2) :
    ∀ (ζ: Sub UTm), t1[ζ] -->₀ t2[ζ].
  Proof.
    induction r; crush; eauto with eval; unfold not in *;
    constructor; crush;
    match goal with
      | [|- ?t[?ζ] ≠ _] =>
        destruct t eqn: ?
    end; crush.
  Qed.

  Lemma eval_closed_under_substitution {t1 t2} (r: t1 --> t2) (ζ: Sub UTm) :
    t1[ζ] --> t2[ζ].
  Proof.
    induction r as [C t₁' t₂' e|C];
    rewrite -> ?pctx_app_sub; constructor;
      auto using eval₀_closed_under_substitution.
    destruct C; crush.
  Qed.

End SubstEval.

Section Determinacy.

  Lemma eval₀_determinacy {t₀ t₁ t₂} :
    t₀ -->₀ t₁ → t₀ -->₀ t₂ → t₁ = t₂.
  Proof.
    induction 1; inversion 1; subst; trivial;
    match goal with
      | H: ?x ≠ ?x |- _ => elim (H eq_refl)
      | H: ∀ _, _ ≠ _ |- _ => elim (H _ eq_refl)
      | H: ∀ _ _, _ ≠ _ |- _ => elim (H _ _ eq_refl)
    end.
  Qed.

  Ltac strengthenHyp :=
    match goal with
      (* Value inversion *)
      | [H: _ ∧ _               |- _] => destruct H
      | [H: False               |- _] => elim H
      (* Mismatched disequality assupmtions of evaluation *)
      | [H: ?x ≠ ?x             |- _] => elim H
      | [H: ∀ _, _ ≠ _          |- _] => elim (H _ eq_refl)
      | [H: ∀ _ _, _ ≠ _        |- _] => elim (H _ _ eq_refl)
      (* Eval₀ normal form reduction *)
      | [H: wrong        -->₀ _ |- _] => inversion H
      | [H: var _        -->₀ _ |- _] => inversion H
      | [H: abs _        -->₀ _ |- _] => inversion H
      | [H: unit         -->₀ _ |- _] => inversion H
      | [H: true         -->₀ _ |- _] => inversion H
      | [H: false        -->₀ _ |- _] => inversion H
      | [H: inl _        -->₀ _ |- _] => inversion H
      | [H: inr _        -->₀ _ |- _] => inversion H
      | [H: pair _ _     -->₀ _ |- _] => inversion H
      | [V: Value ?t, H: ?t -->₀ _ |- _] =>
        elim (values_are_eval₀_normal V H)
      (* Value strengthening *)
      | [V: Value (pctx_app _ ?C), E: ECtx ?C |- _] =>
        apply (value_ectx_inv E) in V; cbn in V
      (* Strengthen with eval₀ determinacy. *)
      | [H1: ?s -->₀ ?t, H2: ?s -->₀ ?u |- _] =>
        pose proof (eval₀_determinacy H1 H2);
          clear H2; subst t
    end.

  Ltac invertEval₀ :=
    match goal with
      | [H: app _ _      -->₀ _ |- _] => inversion H; clear H
      | [H: proj₁ _      -->₀ _ |- _] => inversion H; clear H
      | [H: proj₂ _      -->₀ _ |- _] => inversion H; clear H
      | [H: ite _ _ _    -->₀ _ |- _] => inversion H; clear H
      | [H: caseof _ _ _ -->₀ _ |- _] => inversion H; clear H
      | [H: seq _ _      -->₀ _ |- _] => inversion H; clear H
    end.

  Ltac destructECtx :=
    match goal with
      | [E: ECtx ?C, H: pctx_app _ ?C = _ |- _] =>
        is_var C; destruct C
      | [E: ECtx ?C, H: _ = pctx_app _ ?C |- _] =>
        is_var C; destruct C
    end.

  Local Ltac crushDet :=
    repeat
      (try discriminate;
       repeat strengthenHyp;
       repeat crushUtlcSyntaxMatchH;
       cbn in *|-; subst*); eauto.

  Lemma determinacy_help1 {t₁ t₁' t₂ t₂' t} (r₁: t₁ -->₀ t₁') (r₂: t₂ -->₀ t₂') :
    ∀ {C₁ C₂}, ECtx C₁ → ECtx C₂ →
      t = pctx_app t₁ C₁ →
      t = pctx_app t₂ C₂ →
      pctx_app t₁' C₁ = pctx_app t₂' C₂.
  Proof.
    induction t; intros;
    (* First look at the decisions encoded in the evaluation contexts. Try as
       fast as possible to get rid of cases where one context indicates that
       the other is reducing a normal form. *)
    destruct C₁; crushDet;
    destruct C₂; crushDet;
    (* Handle the cases where both contexts actually do the same thing. *)
    cbn; f_equal; eauto;
    (* Only inconsistent cases from here on. *)
    exfalso;
    (* One of the contexts is empty while the other one is non-empty. Take
       a look at what the empty context is reducing. We got one layer of
       datatype information from the non-empty context which we use to find
       the reduction. *)
    try invertEval₀; crushDet;
    (* From the inversion of the reduction we learn that the non-empty context
       must in fact be a normal-form which is impossible. Find the non-empty
       context again and give it a final blow. *)
    try destructECtx; crushDet.
  Qed.

  Lemma determinacy_help2 {t₁ t₁' t} (e₁: t₁ -->₀ t₁') :
    ∀ {C₁ C₂},
      t = pctx_app t₁ C₁ →
      t = pctx_app wrong C₂ →
      ECtx C₁ → ECtx C₂ →
      False.
  Proof.
    induction t; intros; crushDet;
    destruct C₂; crushDet;
    destruct C₁; crushDet;
    inversion e₁; crushDet;
    destruct C₂; crushDet.
  Qed.

  Lemma determinacy {t t₁ t₂} :
    t --> t₁ → t --> t₂ → t₁ = t₂.
  Proof.
    do 2 inversion 1.
    - eapply determinacy_help1; eauto.
    - exfalso; eapply determinacy_help2; eauto.
    - exfalso; eapply determinacy_help2; eauto.
    - reflexivity.
  Qed.

  Lemma determinacy_star {t t₁ t₂} :
    t -->* t₁ → t -->* t₂ → (t₁ -->* t₂ ∨ t₂ -->* t₁).
  Proof.
    intros es1 es2.
    pose proof es1 as es1'.
    induction es1; auto.
    destruct es2; auto.
    rewrite (determinacy H H0) in *.
    crushDet.
  Qed.
End Determinacy.

Section InvertECtxEq.

  Inductive EctxAppEq : ∀ (t : UTm) (C : PCtx) (t' : UTm) (C' : PCtx),  Prop :=
    | EctxAppEqLeft : ∀ t C C', ECtx C → EctxAppEq (pctx_app t C) C' t (pctx_cat C C')
    | EctxAppEqRight : ∀ t C C', ECtx C → EctxAppEq t (pctx_cat C C') (pctx_app t C) C'
    | ECtxValueLeft : ∀ t t' C C', Value t → EctxAppEq t C t' C'
    | ECtxValueRight : ∀ t t' C C', Value t' → EctxAppEq t C t' C'
  .

  Lemma ectxAppEqExtend {t C t' C'} C'' :
    EctxAppEq t C t' C' →
    EctxAppEq t (pctx_cat C C'') t' (pctx_cat C' C'').
  Proof.
    induction 1; rewrite <- ?pctx_cat_assoc; constructor; assumption.
  Qed.

  Lemma ectxAppEqExtendPAbs {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pabs C) t' (pabs C').
  Proof.
    eapply (ectxAppEqExtend (pabs phole)).
  Qed.

  Lemma ectxAppEqExtendPInl {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pinl C) t' (pinl C').
  Proof.
    eapply (ectxAppEqExtend (pinl phole)).
  Qed.

  Lemma ectxAppEqExtendPInr {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pinr C) t' (pinr C').
  Proof.
    eapply (ectxAppEqExtend (pinr phole)).
  Qed.

  Lemma ectxAppEqExtendPProj₁ {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pproj₁ C) t' (pproj₁ C').
  Proof.
    eapply (ectxAppEqExtend (pproj₁ phole)).
  Qed.

  Lemma ectxAppEqExtendPProj₂ {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pproj₂ C) t' (pproj₂ C').
  Proof.
    eapply (ectxAppEqExtend (pproj₂ phole)).
  Qed.

  Lemma ectxAppEqExtendPPair₁ {t C t' C' t₂} :
    EctxAppEq t C t' C' →
    EctxAppEq t (ppair₁ C t₂) t' (ppair₁ C' t₂).
  Proof.
    eapply (ectxAppEqExtend (ppair₁ phole t₂)).
  Qed.

  Lemma ectxAppEqExtendPPair₂ {t C t' C' t₁} :
    EctxAppEq t C t' C' →
    EctxAppEq t (ppair₂ t₁ C) t' (ppair₂ t₁ C').
  Proof.
    eapply (ectxAppEqExtend (ppair₂ t₁ phole)).
  Qed.

  Lemma ectxAppEqExtendPApp₁ {t C t' C' t₂} :
    EctxAppEq t C t' C' →
    EctxAppEq t (papp₁ C t₂) t' (papp₁ C' t₂).
  Proof.
    eapply (ectxAppEqExtend (papp₁ phole t₂)).
  Qed.

  Lemma ectxAppEqExtendPApp₂ {t C t' C' t₁} :
    EctxAppEq t C t' C' →
    EctxAppEq t (papp₂ t₁ C) t' (papp₂ t₁ C').
  Proof.
    eapply (ectxAppEqExtend (papp₂ t₁ phole)).
  Qed.

  Lemma ectxAppEqExtendPSeq₁ {t C t' C' t₂} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pseq₁ C t₂) t' (pseq₁ C' t₂).
  Proof.
    eapply (ectxAppEqExtend (pseq₁ phole t₂)).
  Qed.

  Lemma ectxAppEqExtendPIte₁ {t C t' C' t₂ t₃} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pite₁ C t₂ t₃) t' (pite₁ C' t₂ t₃).
  Proof.
    eapply (ectxAppEqExtend (pite₁ phole t₂ t₃)).
  Qed.

  Lemma ectxAppEqExtendPCaseof₁ {t C t' C' t₂ t₃} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pcaseof₁ C t₂ t₃) t' (pcaseof₁ C' t₂ t₃).
  Proof.
    eapply (ectxAppEqExtend (pcaseof₁ phole t₂ t₃)).
  Qed.

  Lemma ectxAppEqPHoleRight {t C} : ECtx C → EctxAppEq t C (pctx_app t C) phole.
  Proof.
    change C with (pctx_cat C phole); eauto using EctxAppEq.
  Qed.

  Lemma ectxAppEqPHoleLeft {t C} : ECtx C → EctxAppEq (pctx_app t C) phole t C.
  Proof.
    change C with (pctx_cat C phole); eauto using EctxAppEq.
  Qed.

  Lemma pctx_app_eq t C t' C' :
    ECtx C → ECtx C' →
    pctx_app t C = pctx_app t' C' →
    EctxAppEq t C t' C'.
  Proof.
    revert t' C';
    induction C; intros t' C' eC eC' eq';
    [simpl in *; subst;
     eauto using ectxAppEqPHoleLeft, ectxAppEqPHoleRight, EctxAppEq
    |idtac..];
    (destruct C';
      [change (pctx_app t' phole) with t' in *; subst;
       eauto using ectxAppEqPHoleLeft, ectxAppEqPHoleRight, EctxAppEq
      |idtac..]);
    crush;
    eauto using ectxAppEqExtendPAbs, ectxAppEqExtendPProj₂, ectxAppEqExtendPProj₁, ectxAppEqExtendPInr, ectxAppEqExtendPInl, ectxAppEqExtendPApp₁, ectxAppEqExtendPApp₂, ectxAppEqExtendPPair₁, ectxAppEqExtendPPair₂, ectxAppEqExtendPIte₁, ectxAppEqExtendPCaseof₁, ectxAppEqExtendPSeq₁;
    eauto using value_ectx_inv, ECtxValueRight, ECtxValueLeft.
  Qed.
End InvertECtxEq.

Section Termination'.

  Lemma TerminatingD (t: UTm) (m: t⇓) :
    ∀ t', t --> t' → Terminating t'.
  Proof.
    destruct m as (v & vv & es).
    intros t' e.
    depind es.
    - elim (values_are_normal vv e).
    - rewrite -> (determinacy e H).
      exists z; crush.
  Qed.

  Lemma TerminatingDN (t: UTm) n (m: t ⇓_ (S n)) :
    ∀ t' : UTm, t --> t' → t'⇓_n.
  Proof.
    destruct m as (v & m & vv & ineq & es).
    intros t' e.
    depind es.
    - elim (values_are_normal vv e).
    - rewrite -> (determinacy e H).
      assert (n0 ≤ n) by omega.
      exists t'', n0; crush.
  Qed.

  Lemma termination_closed_under_antireduction {t t'} :
    t --> t' → t' ⇓ → t ⇓.
  Proof.
    destruct 2 as (v & vv & es).
    exists v; eauto with eval.
  Qed.

  Lemma termination_closed_under_antireductionStar {t t'} :
    t -->* t' → t' ⇓ → t ⇓.
  Proof.
    intros e term.
    induction e; eauto using termination_closed_under_antireduction.
  Qed.

  Lemma TerminatingN_eval {t t' n } :
    t --> t' → t' ⇓_ n ↔ t ⇓_ (S n).
  Proof.
    intros e. constructor;
      destruct 1 as (v & m & vv & ineq & esm).
    - exists v, (S m); crush.
    - destruct esm.
      + elim (values_are_normal vv e).
      + rewrite -> (determinacy e H).
        exists t'', n0; crush.
  Qed.

  Lemma TerminatingN_evaln {t t' n } n' :
    evaln t t' n → t' ⇓_ n' ↔ t ⇓_ (n + n').
  Proof.
    induction 1; eauto using iff_refl, iff_trans, TerminatingN_eval.
  Qed.

  Lemma TerminatingN_xor_evaln {t t' n} :
    TerminatingN t n → evaln t t' (S n) → False.
  Proof.
    intros term essn.
    replace (S n) with (n + 1) in essn by omega.
    destruct (evaln_split n 1 essn) as (t'' & esn & es1).
    replace n with (n + 0) in term by omega.
    rewrite <- (TerminatingN_evaln 0 esn) in term.
    destruct term as (v & m & vv & ineq & es0).
    assert (m = 0) by omega; subst.
    inversion es0; subst.
    depind es1.
    elim (values_are_normal vv H).
  Qed.

  Lemma TerminatingN_lt {t n n'} :
    TerminatingN t n → n ≤ n' → TerminatingN t n'.
  Proof.
    destruct 1 as (v & m & vv & ineq & esm).
    intros ineq'.
    exists v, m; crush.
  Qed.

  Lemma Terminating_not_div_wrong {t} :
    t ⇓ → (t ⇑ ∨ t -->* wrong) → False.
  Proof.
    intros term.
    destruct 1 as [div | termwrong]; auto.
    destruct term as (? & ? & ?).
    destruct (determinacy_star H0 termwrong).
    - depind H1; try contradiction.
      eapply (values_are_normal H H1).
    - depind H1; try contradiction.
      eapply (wrong_normal _ H1).
  Qed.

  Lemma wrong_pctx_inv {C t} :
    pctx_app t C = wrong → t = wrong ∧ C = phole.
  Proof.
    induction C; crush.
  Qed.

  Lemma eval₀_ectx_inv C t (ec : ECtx C) {t' t''} :
    t'' -->₀ t' → t'' = pctx_app t C →
    Value t ∨ C = phole.
  Proof.
    induction 1;
    destruct C; crush;
    try match goal with
            [ H : _ = pctx_app t C |- _ ] =>
            (assert (Value (pctx_app t C)) by (rewrite <- H; crush))
        end; eauto using value_ectx_inv.
  Qed.

  Lemma eval_ectx_inv C t (ec : ECtx C) {t' t''} :
    t'' --> t' → pctx_app t C = t'' →
    Value t ∨
    (exists C', ECtx C' ∧ t = pctx_app wrong C' ∧ t' = wrong) ∨
    (exists t'', t' = pctx_app t'' C ∧ t --> t'').
  Proof.
    induction 1 as [C' t₀ t₀' e eC'|].
    - intros eq.
      pose proof (pctx_app_eq _ _ _ _ ec eC' eq) as inv.
      induction inv as [t C C' eC| t C C' eC| t t' C C' vt| t t' C C' vt'].
      + right; right.
        exists (pctx_app t₀' C);
        eauto using pctx_cat_app, eval_ctx₀.
      + destruct (eval₀_ectx_inv C t eC e eq_refl); crush;
        right; right.
        exists t₀';
        rewrite pctx_cat_phole_leftzero;
        split; crush.
        eapply (eval_ctx₀ phole); crush.
      + left; crush.
      + exfalso.
        eapply (values_are_normal vt');
        eapply (eval_ctx₀ phole); crush.
    - intros eq.
      pose proof (pctx_app_eq _ _ _ _ ec H eq) as inv.
      depind inv.
      + right; left.
        exists C; crush.
      + destruct (wrong_pctx_inv x); subst.
        right; left.
        exists phole; crush.
      + left; crush.
      + exfalso; crush.
  Qed.

  Lemma evalStar_ectx_inv C t (ec : ECtx C) v :
    pctx_app t C -->* v → Value v →
    (exists v', Value v' ∧ t -->* v' ∧ pctx_app v' C -->* v).
  Proof.
    intros es vv; depind es.
    - exists t; eauto using value_ectx_inv with eval.
    - destruct (eval_ectx_inv C t ec H eq_refl) as [vt|[[C' [eC' [? ?]]]|[t'' [eq e]]]]; subst.
      + exists t; crush.
      + rewrite -> (wrong_evalStar_inv es) in *.
        crush.
      + destruct (IHes t'' C ec eq_refl vv) as (v' & vv' & es1' & es2').
        exists v'; crush.
  Qed.

  Lemma inversion_termination_evalcontext C t (ec: ECtx C) :
    (pctx_app t C) ⇓ → t ⇓.
  Proof.
    destruct 1 as (v & vv & es).
    destruct (evalStar_ectx_inv C t ec v es) as (v' & vv' & es1 & es2); subst; crush.
    exists v'; crush.
  Qed.

  Corollary div_ectx {t C} :
    ECtx C → t ⇑ → (pctx_app t C) ⇑.
  Proof. eauto using inversion_termination_evalcontext. Qed.

  Lemma pctx_cat_phole {C C'} : C ≠ phole → pctx_cat C C' ≠ phole.
  Proof.
    induction C'; simpl; crush.
  Qed.

  Lemma eval_to_wrong_ectx {t C} (eC : ECtx C):
    t -->* wrong → (pctx_app t C) -->* wrong.
  Proof.
    intros es.
    depind es.
    - assert (phole_or_not : C = phole ∨ C ≠ phole)
        by (destruct C; [left|right..]; crush).
      destruct (phole_or_not); subst.
      + simpl; crush.
      + eapply evalToStar.
        eauto with eval.
    - induction H.
      + apply (evalStepStar (pctx_app (pctx_app t' C0) C)); auto.
        rewrite <- ?pctx_cat_app.
        eauto using ectx_cat with eval.
      + rewrite <- ?pctx_cat_app.
        eapply evalToStar.
        eauto using pctx_cat_phole, ectx_cat with eval.
  Qed.

End Termination'.

Section EvalInContext.
  Lemma eval_from_eval₀ {t t' t₀ t₀' C} :
    t₀ -->₀ t₀' →
    t = pctx_app t₀ C →
    t' = pctx_app t₀' C →
    ECtx C →
    t --> t'.
  Proof.
    intros; subst; eauto using eval_ctx₀.
  Qed.

  Lemma ctxeval_from_eval₀ {t t' t₀ t₀' C} :
    t₀ -->₀ t₀' →
    t = pctx_app t₀ C →
    t' = pctx_app t₀' C →
    ECtx C →
    ctxeval t t'.
  Proof.
    intros; subst; eauto using ctxeval.
  Qed.

End EvalInContext.

Ltac crushUtlcEvaluationMatchH2 :=
  match goal with
    | [ |- ECtx (pctx_cat _ _)] => eapply ectx_cat
    | [ |- ECtx phole ] => cbn
    | [ |- ECtx (pite₁ _ _ _) ] => cbn
    | [ |- ECtx (pinl _) ] => cbn
    | [ |- ECtx (pinr _) ] => cbn
    | [ |- ECtx (pproj₁ _) ] => cbn
    | [ |- ECtx (pproj₂ _) ] => cbn
    | [ |- ECtx (papp₁ _ _) ] => cbn
    | [ |- ECtx (papp₂ _ _) ] => cbn
    | [ |- ECtx (pcaseof₁ _ _ _) ] => (unfold ECtx; cbn)
  end.

Ltac inferContext :=
  cbn; try reflexivity;
  let rec inferC acc t t₀ :=
      match t with
        | t₀ => instantiate (1 := acc)
        | app ?t1 ?t2 => inferC (pctx_cat (papp₁ phole t2) acc) t1 t₀ + inferC (pctx_cat (papp₂ t1 phole) acc) t2 t₀
        | pair ?t1 ?t2 => inferC (pctx_cat (ppair₁ phole t2) acc) t1 t₀ + inferC (pctx_cat (ppair₂ t1 phole) acc) t2 t₀
        | seq ?t1 ?t2 => inferC (pctx_cat (pseq₁ phole t2) acc) t1 t₀
        | inl ?t1 => inferC (pctx_cat (pinl phole) acc) t1 t₀
        | inr ?t1 => inferC (pctx_cat (pinr phole) acc) t1 t₀
        | ite ?t1 ?t2 ?t3 => inferC (pctx_cat (pite₁ phole t2 t3) acc) t1 t₀
        | caseof ?t1 ?t2 ?t3 => inferC (pctx_cat (pcaseof₁ phole t2 t3) acc) t1 t₀
        | proj₁ ?t1 => inferC (pctx_cat (pproj₁ phole) acc) t1 t₀
        | proj₂ ?t1 => inferC (pctx_cat (pproj₂ phole) acc) t1 t₀
        | pctx_app t₀ ?C => instantiate (1 := pctx_cat C acc)
        | pctx_app ?t1 (pctx_cat ?C1 ?C2) => inferC (pctx_app (pctx_app t1 C1) C2) t₀
        | pctx_app ?t1 ?C => inferC (pctx_cat C acc) t1 t₀
      end
  in repeat match goal with
              | [ |- ?t = pctx_app ?t₀ (pctx_cat ?C1 ?C2) ] => (rewrite -> ?pctx_cat_app)
              | [ |- pctx_app ?t0 ?C = pctx_app ?t' ?C ] => f_equal
              | [ |- ?t = pctx_app ?t₀ ?C ] => (inferC phole t t₀; rewrite -> ?pctx_cat_app; simpl; rewrite -> ?pctx_cat_app in *; reflexivity)
            end.

Lemma test_inferContext (t : UTm) (C' : PCtx): True.
Proof.
  assert (pctx_app (pair (inl t) unit) C' = pctx_app t (pctx_cat (ppair₁ (pinl phole) unit) C')).
  inferContext.
  trivial.
Qed.


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 conj19eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus (mult lv0 lv1) lv1) (mult (Succ lv0) lv1)).
Admitted.
QuickChick conj19eqsynthconj5.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import String List.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

Require Import GenLow GenHigh Tactics Sets Classes.
Import GenLow GenHigh.
Import ListNotations.
Import QcDefaultNotation.

Open Scope qc_scope.
Local Open Scope string.

Set Bullet Behavior "Strict Subproofs".
(** * Correctness of dependent generators *)

(* begin sizeEqs *)
Class SizedProofEqs {A : Type} (P : A -> Prop) :=
  { iter : nat -> set A;
    mon : forall n1 n2, n1 <= n2 -> iter n1 \subset iter n2;
    spec : \bigcup_(n : nat) iter n <--> P}.
(* end sizeEqs *)

Class SizedSuchThatCorrect {A : Type} (P : A -> Prop) `{SizedProofEqs A P} (g : nat -> G (option A)) :=
  { sizedSTCorrect : forall s, isSome :&: semGen (g s) <--> Some @: (iter s) }.

Class SuchThatCorrect {A : Type} (P : A -> Prop) (g : G (option A)) :=
  { STCorrect : isSome :&: semGen g <-->  Some @: [set x : A | P x ] }.

(** * Dependent sized generators *)

(* begin genSTSized_class *)
Class GenSizedSuchThat (A : Type) (P : A -> Prop) := { arbitrarySizeST : nat -> G (option A) }.
(* end genSTSized_class *)

(** * Monotonicity of denendent sized generators *)

Class GenSizedSuchThatMonotonic (A : Type)
      `{GenSizedSuchThat A} `{forall s, SizeMonotonic (arbitrarySizeST s)}.

Class GenSizedSuchThatMonotonicOpt (A : Type)
      `{GenSizedSuchThat A} `{forall s, SizeMonotonicOpt (arbitrarySizeST s)}.

Class GenSizedSuchThatSizeMonotonic (A : Type)
      `{GenSizedSuchThat A} `{SizedMonotonic _ arbitrarySizeST}.

Class GenSizedSuchThatSizeMonotonicOpt (A : Type)
      `{GenSizedSuchThat A} `{SizedMonotonicOpt _ arbitrarySizeST}.

(** * Correctness of denendent sized generators *)

Class GenSizedSuchThatCorrect (A : Type) (P : A -> Prop)
      `{GenSizedSuchThat A P}
      `{SizedSuchThatCorrect A P arbitrarySizeST}.

(** * Dependent generators *)

(* begin genST_class *)
Class GenSuchThat (A : Type) (P : A -> Prop) := { arbitraryST : G (option A) }.
(* end genST_class *)

Notation "'genST' x" := (@arbitraryST _ x _) (at level 70).

(** * Monotonicity of denendent generators *)

Class GenSuchThatMonotonic (A : Type) (P : A -> Prop) `{GenSuchThat A P}
      `{@SizeMonotonic _ arbitraryST}.

Class GenSuchThatMonotonicOpt (A : Type) (P : A -> Prop) `{GenSuchThat A P}
      `{@SizeMonotonicOpt _ arbitraryST}.

(** * Correctness of dependent generators *)

Class GenSuchThatCorrect {A : Type} (P : A -> Prop)
      `{GenSuchThat A P}
      `{SuchThatCorrect A P arbitraryST}.

Class GenSuchThatMonotonicCorrect (A : Type) (P : A -> Prop)
      `{GenSuchThat A P}
      `{@SizeMonotonicOpt _ arbitraryST}
      `{SuchThatCorrect A P arbitraryST}.

(** Coercions *)

Instance GenSizedSuchThatMonotonicOptOfSizeMonotonic
         (A : Type) (P : A -> Prop) (Hgen : GenSizedSuchThat A P)
         (Hmon : forall s : nat, SizeMonotonicOpt (arbitrarySizeST s))
: @GenSizedSuchThatMonotonicOpt A _ Hgen Hmon.

Instance GenSizedSuchThatSizeMonotonicOptOfSizedMonotonic
         (A : Type) (P : A -> Prop) (Hgen : GenSizedSuchThat A P)
         (Hmon : SizedMonotonicOpt arbitrarySizeST)
: @GenSizedSuchThatSizeMonotonicOpt A _ Hgen Hmon.

Instance GenSizedSuchThatCorrectOptOfSizedSuchThatCorrect
         (A : Type) (P : A -> Prop) (H : GenSizedSuchThat A P)
         (Heqs : SizedProofEqs P)
         (Hcorr : SizedSuchThatCorrect P arbitrarySizeST)
: @GenSizedSuchThatCorrect A P H Heqs Hcorr.

Instance GenSuchThatMonotonicOptOfSizeMonotonic
         (A : Type) (P : A -> Prop) (Hgen : GenSuchThat A P)
         (Hmon : SizeMonotonicOpt arbitraryST)
: @GenSuchThatMonotonicOpt A _ Hgen Hmon.

Instance GenSuchThatCorrectOptOfSuchThatCorrect
         (A : Type) (P : A -> Prop) (H : GenSuchThat A P)
         (Hcorr : SuchThatCorrect P (genST P))
: @GenSuchThatCorrect A P H Hcorr.

Instance SizeMonotonicOptofSizeMonotonic {A} (g : G (option A))
         {H : SizeMonotonic g} : SizeMonotonicOpt g.
Proof.
  intros s1 s2 Hs a.
  eapply monotonic; eauto.
Qed.

(** * Coercions from sized to unsized generators *)

(* Generators *)

(* begin GenSuchThatOfBounded *)
Instance GenSuchThatOfBounded (A : Type) (P : A -> Prop) (H : GenSizedSuchThat A P)
: GenSuchThat A P := { arbitraryST := sized arbitrarySizeST }.
(* end GenSuchThatOfBounded *)

Generalizable Variables PSized PMon PSMon PCorr.

(* Monotonicity *)

Instance GenSuchThatMonotonicOfSized (A : Type) (P : A -> Prop)
         {H : GenSizedSuchThat A P}
         `{@GenSizedSuchThatMonotonic A P H PMon}
         `{@GenSizedSuchThatSizeMonotonic A P H PSMon}
: GenSuchThatMonotonic A P.

Instance SizeMonotonicOptOfBounded' (A : Type) (P : A -> Prop)
         {H : GenSizedSuchThat A P}
         `{@GenSizedSuchThatMonotonicOpt A P H PMon}
         `{@GenSizedSuchThatSizeMonotonicOpt A P H PSMon}
: SizeMonotonicOpt (genST P).
Proof.
  unfold arbitraryST, GenSuchThatOfBounded.
Admitted. (* XXX lemma *)

(* begin SizeMonotonicOptOfBounded *)
Instance SizeMonotonicOptOfBounded (A : Type) (P : A -> Prop)
         (H1 : GenSizedSuchThat A P)
         (H2 : SizedProofEqs P) (* XXX change name *)
         (H2 : forall s : nat, SizeMonotonicOpt (arbitrarySizeST s))
         (H3 : SizedMonotonicOpt arbitrarySizeST) (* XXX change name *)
: SizeMonotonicOpt (genST P).
(* end SizeMonotonicOptOfBounded *)
Proof.
  eapply SizeMonotonicOptOfBounded'.
  constructor; eauto.
  constructor; eauto.
Qed.

Instance GenSuchThatMonotonicOptOfSized' (A : Type) (P : A -> Prop)
         {H : GenSizedSuchThat A P}
         `{@GenSizedSuchThatMonotonicOpt A P H PMon}
         `{@GenSizedSuchThatSizeMonotonicOpt A P H PSMon}
: GenSuchThatMonotonicOpt A P.

(* Correctness *)
Instance SuchThatCorrectOfBounded' (A : Type) (P : A -> Prop)
         {H : GenSizedSuchThat A P}
         `{@GenSizedSuchThatMonotonicOpt A P H PMon}
         `{@GenSizedSuchThatSizeMonotonicOpt A P H PSMon}
         `{@GenSizedSuchThatCorrect A P H PSized PCorr}
: SuchThatCorrect P arbitraryST.
Proof.
  constructor; unfold arbitraryST, GenSuchThatOfBounded.
  rewrite semSized_opt; eauto.
  split.
  - intros [H3 H4]. destruct a; try discriminate.
    eexists. split; [| reflexivity ].
    eapply spec.
    destruct H4 as [n [_ Hsem]].
    exists n. split. now constructor.
    assert (Ha : (isSome :&: semGen (arbitrarySizeST n)) (Some a)).
    { split; eauto. }
    eapply PCorr in Ha. destruct Ha as [a' [Hit Heq]]. inv Heq. eassumption.
  - intros [y [HP Heq]]. inv Heq.
    eapply spec in HP. destruct HP as [n [_ Hit]].
    split; eauto. exists n. split; [ now constructor |].
    eapply PCorr. eexists; split; eauto.
Qed.

(* begin SuchThatCorrectOfBounded *)
Instance SuchThatCorrectOfBounded (A : Type) (P : A -> Prop)
         (H1 : GenSizedSuchThat A P)
         (H2 : SizedProofEqs P) (* XXX change name *)
         (H3 : forall s : nat, SizeMonotonicOpt (arbitrarySizeST s))
         (H4 : SizedMonotonicOpt arbitrarySizeST) (* XXX change name *)
         (H5 : SizedSuchThatCorrect P arbitrarySizeST)
: SuchThatCorrect P arbitraryST.
(* end SuchThatCorrectOfBounded *)
Proof.
  eapply SuchThatCorrectOfBounded'; eauto.
  constructor; eauto.
  constructor; eauto.
  constructor; eauto.
Qed.

(* TODO: Move to another file *)
(*
(** Leo's example from DependentTest.v *)

Print Foo.
Print goodFooNarrow.

DeriveSized Foo as "SizedFoo".

(*
Inductive Foo : Set :=
    Foo1 : Foo | Foo2 : Foo -> Foo | Foo3 : nat -> Foo -> Foo

Inductive goodFooNarrow : nat -> Foo -> Prop :=
    GoodNarrowBase : forall n : nat, goodFooNarrow n Foo1
  | GoodNarrow : forall (n : nat) (foo : Foo),
                 goodFooNarrow 0 foo ->
                 goodFooNarrow 1 foo -> goodFooNarrow n foo
 *)

(* Q : Can we but the size last so we don't have to eta expand?? *)
Print genGoodNarrow.

(** For dependent gens we show generate this instance *)
Instance genGoodNarrow (n : nat) : ArbitrarySizedSuchThat Foo (goodFooNarrow n) :=
  {
    arbitrarySizeST := genGoodNarrow' n;
    shrinkSizeST x := []
  }.

(* For proofs we should generate this instances *)

Instance genGoodNarrowMon (n : nat) (s : nat) :
  SizeMonotonic (@arbitrarySizeST Foo (goodFooNarrow n) _ s).
Abort.

Instance genGoodNarrowSMon (n : nat) :
  @ArbitrarySTSizedSizeMotonic Foo (@goodFooNarrow n) _.
Abort.

Instance genGoodNarrowCorr (n : nat) :
  GenSizeSuchThatCorrect (goodFooNarrow n) (@arbitrarySizeST Foo (goodFooNarrow n) _).
Abort.
*)

(** We can now abstract away from sizes and get the generator and the proofs for free *)

(* Class SizedProofEqs' {A : Type} (P : A -> Prop) := *)
(*   { *)
(*     zero' : set (option A); *)
(*     succ' : set (option A) -> set (option A); *)
(*     spec1 : Some @: P \subset \bigcup_(n : nat) ((succ' ^ n) zero'); *)
(*     spec2 : \bigcup_(n : nat) ((succ' ^ n) zero') \subset  Some @: P :|: [ None ]; *)
(*   }. *)

(* Looks like Scott induction, although we have not proved that
   succ is continuous *)
(* Lemma fixed_point_ind {A} (Q P : A -> Prop) `{SizedProofEqs A P}: *)
(*   zero \subset Q -> *)
(*   (forall (s : set A), s \subset Q -> succ s \subset Q) -> *)
(*   P \subset Q. *)
(* Proof. *)
(*   intros Hz IH. rewrite <- spec. intros x [n [_ HP]]. *)
(*   revert x HP.  *)
(*   induction n. *)
(*   - eauto. *)
(*   - intros x. eapply IH. eauto. *)
(* Qed. *)


(* * Natural Deduction *)

From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability.FOL Require Import Syntax.Facts Syntax.Theories.
From Undecidability.FOL Require Export Deduction.FullNDFacts.
From Undecidability.FOL.Semantics.Tarski Require Export FullFacts FullSoundness.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Require Import Lia.
Import FullSyntax.

Set Default Proof Using "Type".

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Section Consistency.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {p : peirce}.

  #[local] Existing Instance TM.

  Lemma consistent : ~ ([] ⊢ ⊥).
  Proof.
    intros H. unshelve eapply (sound_for_classical_model _ H).
    - exact (fun _ => tt).
    - apply TM_sat_decidable.
    - easy.
  Qed.

End Consistency.


(** This proves Gödel's first incompleteness theorem.

    It constructs a Pi_1 arithmetic formula G that satisfies the equation
    IsWeakHeytingAxiom  |--  G <-> ~IsProved IsAxiom G
    We may interpret G as roughly saying "I am not provable by IsAxiom".
    Under additional hypotheses on IsAxiom, we will show that G is true in
    the standard model of arithmetic, and that G is not provable by IsAxiom.
    G is not refutable either, by its truth in the standard model.
    Because G is not provable, there are models of arithmetic where it is false.
    In other words, G has non-standard proofs only.

    The most difficult hypothesis on IsAxiom will be its consistency, which is
    necessary to avoid proving G (and ~G). We will also require that IsAxiom extends
    arithmetic, to lift G in the language of IsAxiom. *)

Require Import PeanoNat.
Require Import Arith.Wf_nat.
Require Import Arith.Compare_dec.
Require Import EnumSeqNat.
Require Import Formulas.
Require Import Proofs.
Require Import Substitutions.
Require Import IsFreeForSubst.
Require Import PeanoAxioms.
Require Import ProofTactics.
Require Import PeanoModel.
Require Import HeytingModel.
Require Import HeytingRepresentation.
Require Import BoolRepresented.
Require Import DeductionTheorem.
Require Import BetaRepr.
Require Import EnumSeqNat_repr.
Require Import IsProof_repr.
Require Import Consistency.

(* Theta composes arithmetic predicate prop with self-application,
   prop(X0(X0)). *)
Definition Theta (prop : nat) : nat :=
  ComposePropFunc prop SubstSelfZeroRepresented.

Lemma ComposePropFuncSpec :
  forall (A : nat) (B : nat -> nat) (k : nat) (Brep : FunctionRepresented 1 B),
    IsLproposition A = true
    -> (forall v, 1 <= v -> VarOccursFreeInFormula v A = false)
    -> IsProved IsWeakHeytingAxiom
               (Lequiv (Subst (PAnat (B k)) 0 A)
                       (Subst (PAnat k) 0 (ComposePropFunc A (fr_prop _ _ Brep)))).
Proof.
  intros.
  unfold ComposePropFunc.
  pose (Nat.max (MaxVar A) (MaxVar Brep)) as m.
  fold m.
  rewrite Subst_exists; simpl.
  rewrite Subst_and, SubstSubstIdem, SubstTerm_var. simpl.
  apply LandIntro.
  - refine (LimpliesTrans
              IsWeakHeytingAxiom _ _ _ _
              (LexistsIntro_impl IsWeakHeytingAxiom _ _ (PAnat (B k)) _ _ _)).
    + rewrite Subst_and.
      apply LandIntroHyp.
      apply DropHypothesis.
      apply SubstIsLproposition.
      exact H. apply IsLterm_PAnat.
      rewrite SubstSubstDiffCommutes.
      rewrite (SubstSubstNested _ (fr_propprop _ _ Brep)), SubstTerm_var.
      rewrite Nat.eqb_refl.
      pose proof (FormulaRepresents_alt
                    1 B Brep (ConsNat k NilNat)
                    (fr_rep _ _ Brep) (fr_propprop _ _ Brep) (B k)) as H1.
      simpl in H1.
      rewrite CoordConsHeadNat in H1.
      destruct H1 as [H1 _].
      specialize (H1 eq_refl).
      rewrite SubstSubstDiffCommutes. exact H1.
      discriminate. apply PAnat_closed. apply PAnat_closed.
      apply MaxVarDoesNotOccurFree. apply fr_propprop.
      apply le_n_S, Nat.le_max_r.
      apply MaxVarFreeSubst_var. apply fr_propprop.
      apply le_n_S, Nat.le_max_r.
      discriminate. apply PAnat_closed. apply PAnat_closed.
      rewrite (SubstSubstNested _ H), SubstTerm_var, Nat.eqb_refl.
      apply LimpliesRefl.
      apply SubstIsLproposition. exact H.
      apply IsLterm_PAnat.
      apply MaxVarDoesNotOccurFree.
      exact H. apply le_n_S, Nat.le_max_l.
      apply MaxVarFreeSubst_var.
      exact H. apply le_n_S, Nat.le_max_l.
    + apply IsLterm_PAnat.
    + rewrite IsLproposition_and.
      rewrite SubstIsLproposition.
      apply SubstIsLproposition.
      exact H. apply IsLterm_var.
      apply SubstIsLproposition. apply fr_propprop.
      apply IsLterm_var. apply IsLterm_PAnat.
    + apply IsFreeForSubst_PAnat.
      rewrite IsLproposition_and.
      rewrite SubstIsLproposition.
      apply SubstIsLproposition.
      exact H. apply IsLterm_var.
      apply SubstIsLproposition. apply fr_propprop.
      apply IsLterm_var. apply IsLterm_PAnat.
  - apply LexistsElim_impl.
    apply VarOccursFreeInFormula_SubstClosed.
    apply MaxVarDoesNotOccurFree. exact H.
    apply le_n_S, Nat.le_max_l. apply PAnat_closed.
    apply LforallIntro.
    apply PushHypothesis.
    (* Replace Lvar (S m) by PAnat (B k). *)
    apply (LimpliesTrans _ _ (Leq (Lvar (S m)) (PAnat (B k)))).
    pose proof (fr_rep _ _ Brep (ConsNat k NilNat)) as H1.
    simpl in H1.
    rewrite CoordConsHeadNat in H1.
    apply (LforallElim _ _ _ (Lvar (S m))) in H1.
    rewrite Subst_equiv, Subst_eq, SubstTerm_var, SubstTerm_PAnat in H1.
    simpl in H1.
    rewrite SubstSubstDiffCommutes.
    apply LandElim1 in H1. exact H1.
    discriminate. apply PAnat_closed.
    rewrite VarOccursInTerm_var. reflexivity.
    apply IsLterm_var.
    rewrite IsFreeForSubst_equiv.
    unfold Leq. rewrite IsFreeForSubst_rel2, Bool.andb_true_r.
    apply MaxVarFreeSubst_var.
    apply SubstIsLproposition. apply fr_propprop.
    apply IsLterm_PAnat.
    apply le_n_S.
    apply (Nat.le_trans _ _ _ (MaxVar_Subst _ _ _)).
    apply Nat.max_lub.
    rewrite MaxVarTerm_PAnat. apply le_0_n.
    apply Nat.le_max_r.
    apply LeqElimSubstVar.
    rewrite IsLproposition_implies.
    rewrite SubstIsLproposition.
    apply SubstIsLproposition. exact H.
    apply IsLterm_PAnat.
    exact H. apply IsLterm_var. apply IsLterm_PAnat.
    apply IsFreeForSubst_PAnat.
    rewrite IsLproposition_implies.
    rewrite SubstIsLproposition.
    apply SubstIsLproposition. exact H.
    apply IsLterm_PAnat. exact H.
    apply IsLterm_var.
    rewrite Subst_implies.
    rewrite SubstSubstNested, SubstTerm_var, Nat.eqb_refl.
    rewrite (Subst_nosubst _ (S m)).
    apply LimpliesRefl.
    apply SubstIsLproposition. exact H.
    apply IsLterm_PAnat.
    apply VarOccursFreeInFormula_SubstClosed.
    apply MaxVarDoesNotOccurFree. exact H.
    apply le_n_S, Nat.le_max_l. apply PAnat_closed.
    exact H.
    apply MaxVarDoesNotOccurFree. exact H.
    apply le_n_S, Nat.le_max_l.
    apply MaxVarFreeSubst_var. exact H.
    apply le_n_S, Nat.le_max_l.
Qed.

(* Gödel's famous self-referencing formulas,
   Theta(prop)(Theta(prop)) = prop(Theta(prop)(Theta(prop))).
   Informally, GodelFormula(prop) is a fixpoint of prop.
   By taking prop(X0) := "X0 is not provable",
   we obtain a formula G equivalent to "G is not provable". *)
Definition GodelFormula (prop : nat) : nat :=
  Subst (PAnat (Theta prop)) 0 (Theta prop).

Lemma GodelFormula_closed : forall prop : nat,
    IsLproposition prop = true
    -> (forall n, 0 < n -> VarOccursFreeInFormula n prop = false)
    -> forall v, VarOccursFreeInFormula v (GodelFormula prop) = false.
Proof.
  intros.
  assert (IsLproposition (Theta prop) = true) as thetaprop.
  { apply ComposePropFuncIsProp. exact H. apply fr_propprop. }
  unfold GodelFormula.
  destruct v.
  - apply VarOccursFreeInFormula_SubstIdem.
    exact thetaprop. apply PAnat_closed.
  - rewrite VarOccursFreeInFormula_SubstDiff.
    2: exact thetaprop. 2: discriminate.
    unfold Theta.
    apply ComposePropFuncVars.
    exact H. apply fr_propprop.
    intros. exact (H0 _ H1).
    intros. apply fr_vars, H1.
    apply le_n_S, le_0_n.
    apply PAnat_closed.
Qed.

Lemma GodelFormulaIsLproposition : forall prop : nat,
    IsLproposition prop = true
    -> IsLproposition (GodelFormula prop) = true.
Proof.
  intros.
  apply SubstIsLproposition.
  2: apply IsLterm_PAnat.
  unfold Theta.
  apply ComposePropFuncIsProp. exact H.
  apply fr_propprop.
Qed.

(* Formalization of the fixpoint equation
   G = Theta(prop)(Theta(prop)) = prop(Theta(prop)(Theta(prop))) = prop(G).
   The equality is replaced by logical equivalence of arithmetical propositions,
   proved by IsWeakHeytingAxiom. *)
Lemma PropFixesGodelFormula : forall (prop : nat),
    IsLproposition prop = true
    -> (forall v:nat, 0 < v -> VarOccursFreeInFormula v prop = false)
    -> IsProved IsWeakHeytingAxiom
               (Lequiv (GodelFormula prop)
                       (Subst (PAnat (GodelFormula prop)) 0 prop)).
Proof.
  intros prop propprop zeroonlyfree.
  pose proof (ComposePropFuncSpec
                prop (fun prop : nat => Subst (PAnat prop) 0 prop)
                (Theta prop) SubstSelfZeroRepresented propprop zeroonlyfree) as H.
  simpl in H.
  apply LandIntro.
  - apply DeductionTheorem.
    apply GodelFormulaIsLproposition, propprop.
    apply GodelFormula_closed, zeroonlyfree. exact propprop.
    assert (IsProved (fun n : nat => (IsWeakHeytingAxiom n || (n =? GodelFormula prop))%bool)
                     (GodelFormula prop)) as GprovesItself.
    { apply AxiomIsProved. apply Bool.orb_true_intro.
      right. apply Nat.eqb_refl. apply GodelFormulaIsLproposition.
      exact propprop. }
    unfold GodelFormula at 2 in GprovesItself.
    unfold Theta at 2 in GprovesItself.
    apply (WeakenProvable
             IsWeakHeytingAxiom
             (fun n : nat => (IsWeakHeytingAxiom n || (n =? GodelFormula prop))%bool))
      in H.
    apply LandElim2 in H.
    exact (LimpliesElim _ _ _ H GprovesItself).
    intros n H0.
    rewrite H0. reflexivity.
  - unfold GodelFormula at 2.
    unfold Theta at 2.
    apply DeductionTheorem.
    apply SubstIsLproposition. exact propprop. apply IsLterm_PAnat.
    intro v.
    destruct v. apply VarOccursFreeInFormula_SubstIdem.
    exact propprop.
    apply PAnat_closed.
    rewrite VarOccursFreeInFormula_SubstDiff.
    apply zeroonlyfree. apply le_n_S, le_0_n.
    exact propprop. discriminate.
    apply PAnat_closed.
    apply (WeakenProvable
             IsWeakHeytingAxiom
             (fun n : nat => (IsWeakHeytingAxiom n || (n =? Subst (PAnat (GodelFormula prop)) 0 prop))%bool))
      in H.
    apply LandElim1 in H.
    apply (LimpliesElim _ _ _ H).
    apply AxiomIsProved.
    unfold GodelFormula. rewrite Nat.eqb_refl.
    apply Bool.orb_true_r.
    apply SubstIsLproposition. exact propprop.
    apply IsLterm_PAnat.
    intros. rewrite H0. reflexivity.
Qed.

(* Pi_1 closed formula expressing the non provability of itself. *)
Definition IamNotProvable (IsAxiom : nat -> bool) IsAxiomRep (InterpArithLprop : nat) : nat
  := GodelFormula (Lnot (IsProvedArith IsAxiom IsAxiomRep InterpArithLprop)).

Lemma IamNotProvable_spec : forall IsAxiom IsAxiomRep InterpArithLprop,
  IsLproposition InterpArithLprop = true ->
  (forall v : nat, 2 <= v -> VarOccursFreeInFormula v InterpArithLprop = false) ->
  let G := IamNotProvable IsAxiom IsAxiomRep InterpArithLprop in
  IsProved IsWeakHeytingAxiom
           (Lequiv G (Subst (PAnat G) 0
                            (Lnot (IsProvedArith IsAxiom IsAxiomRep InterpArithLprop)))).
Proof.
  intros.
  apply PropFixesGodelFormula.
  rewrite IsLproposition_not.
  apply IsProvedArithIsLprop, H.
  intros w H1. rewrite VarOccursFreeInFormula_not.
  apply IsProvedArithVars. exact H. exact H0. exact H1.
Qed.

(* The truth of IamNotProvable in the standard model of arithmetic is absolute,
   it says that the brute force search over all proof:nat never terminates.
   However we cannot lift this to IsProved IsWeakHeytingAxiom, because
   the Gödel formula is Pi_1 and not Sigma_1. There are non standard proofs of G. *)
Lemma IamNotProvableTrueEquiv
  : forall (IsAxiom : nat -> bool) IsAxiomRep (InterpArith : nat -> nat)
      (InterpArithRepr : FunctionRepresented 1 InterpArith)
      varValues,
    let G := IamNotProvable IsAxiom IsAxiomRep InterpArithRepr in
    ((~IsProved IsAxiom (InterpArith G)) <-> HAstandardModel G varValues).
Proof.
  intros IsAxiom IsAxiomRep InterpArith InterpArithRepr varValues.
  simpl.
  pose (IamNotProvable IsAxiom IsAxiomRep InterpArithRepr) as g.
  fold g.
  pose proof (IamNotProvable_spec
                IsAxiom IsAxiomRep _ (fr_propprop _ _ InterpArithRepr)
                (fr_vars _ _ InterpArithRepr))
    as gequiv.
  simpl in gequiv. fold g in gequiv.
  pose proof (IsProvedArith_sat
                IsAxiom IsAxiomRep InterpArithRepr InterpArith g varValues
                (fr_propprop _ _ InterpArithRepr) (fr_rep _ _ InterpArithRepr))
    as gprovable.
  pose proof (HAstandardModel_correction
                IsWeakHeytingAxiom _ HAaxiomsSatisfied gequiv) as H.
  split.
  - intros gtrue.
    specialize (H varValues).
    rewrite HAstandardModel_equiv in H. rewrite H.
    destruct gprovable as [_ H0].
    rewrite HAstandardModel_Subst, HAstandardModel_not.
    intro gsat.
    contradict gtrue. apply H0.
    rewrite HAstandardModel_Subst. exact gsat.
    apply IsFreeForSubst_PAnat.
    apply IsProvedArithIsLprop, fr_propprop.
    apply IsFreeForSubst_PAnat.
    rewrite IsLproposition_not.
    apply IsProvedArithIsLprop, fr_propprop.
  - intros gtrue proof.
    destruct gprovable as [H0 _].
    specialize (H0 proof).
    specialize (H varValues).
    rewrite HAstandardModel_equiv in H.
    destruct H as [H _]. specialize (H gtrue).
    rewrite Subst_not, HAstandardModel_not in H.
    contradiction.
Qed.

(* If IsAxiom proves IamNotProvable, then by IamNotProvable_spec
   IsAxiom also proves ~IamNotProvable, which is a contradiction in IsAxiom. *)
Lemma IamNotProvableNotProvable
  : forall (IsAxiom : nat -> bool) IsAxiomRep (InterpArith : nat -> nat)
      (InterpArithRepr : FunctionRepresented 1 InterpArith),
    (forall prop : nat, IsProved IsWeakHeytingAxiom prop
                 -> IsProved IsAxiom (InterpArith prop))
    -> (forall prop, IsLproposition prop = true
               -> InterpArith (Lnot prop) = Lnot (InterpArith prop))
    -> IsProved IsAxiom (InterpArith (IamNotProvable IsAxiom IsAxiomRep InterpArithRepr))
    -> IsInconsistent IsAxiom.
Proof.
  intros IsAxiom IsAxiomRep InterpArith InterpArithRepr.
  intros IsAxiomExtendsHA InterpNot liarproof.
  pose (IamNotProvable IsAxiom IsAxiomRep InterpArithRepr) as G.
  apply (FalseElim IsAxiom (InterpArith G)).
  2: rewrite IsLproposition_not, IsLproposition_eq, IsLterm_var; reflexivity.
  apply LandIntro. exact liarproof.
  (* Proof of IsProved IsAxiom (Lnot (InterpArith G)).
     By extension of Heyting arithmetic, it suffices to prove
     IsProved IsWeakHeytingAxiom (Lnot G). *)
  rewrite <- InterpNot.
  2: apply GodelFormulaIsLproposition; rewrite IsLproposition_not
  ; apply IsProvedArithIsLprop, fr_propprop.
  apply IsAxiomExtendsHA.
  pose proof (IamNotProvable_spec
                IsAxiom IsAxiomRep _ (fr_propprop _ _ InterpArithRepr)
                (fr_vars _ _ InterpArithRepr))
    as H.
  simpl in H. fold G in H. rewrite Subst_not in H.
  apply LandElim1, IsProvedContraposition in H.
  apply (LimpliesElim _ _ _ H). clear H.
  apply LnotLnotIntro.
  (* Proof of
     IsProved IsWeakHeytingAxiom
              (Subst (PAnat G) 0 (IsProvedArith IsAxiom InterpArithLprop))
     which is the arithmetization of IsProved IsAxiom (InterpArith G). *)
  fold G in liarproof.
  apply (ArithmetizeProof IsAxiom IsAxiomRep) in liarproof.
  pose proof (ComposePropFuncSpec
                (IsProvedAsLprop IsAxiom IsAxiomRep) InterpArith G InterpArithRepr
                (IsProvedAsLpropIsLproposition IsAxiom IsAxiomRep)
                (IsProvedAsLpropVars _ _)) as H.
  apply LandElim1 in H.
  apply (LimpliesElim _ _ _ H).
  exact liarproof.
Qed.

(* The contraposition of the previous lemma, which is the usual way of
   phrasing that Gödel's sentence is not provable. Constructively this lemma
   is slightly weaker. *)
Lemma IamNotProvableNotProvableConsistent
  : forall (IsAxiom : nat -> bool) IsAxiomRep (InterpArith : nat -> nat)
      (InterpArithRepr : FunctionRepresented 1 InterpArith),
    (forall prop : nat, IsProved IsWeakHeytingAxiom prop
                 -> IsProved IsAxiom (InterpArith prop))
    -> (forall prop, IsLproposition prop = true
               -> InterpArith (Lnot prop) = Lnot (InterpArith prop))
    -> IsConsistent IsAxiom
    -> ~IsProved IsAxiom (InterpArith (IamNotProvable IsAxiom IsAxiomRep InterpArithRepr)).
Proof.
  intros. intro abs.
  pose proof (IamNotProvableNotProvable
                IsAxiom IsAxiomRep InterpArith InterpArithRepr H H0 abs).
  contradiction.
Qed.

(* Change the previous conclusion "IamNotProvable is not proved by IsAxiom"
   into the equivalent "IamNotProvable is true". *)
Lemma IamNotProvableTrue
  : forall (IsAxiom : nat -> bool) IsAxiomRep (InterpArith : nat -> nat)
      (InterpArithRepr : FunctionRepresented 1 InterpArith),
    (forall prop : nat, IsProved IsWeakHeytingAxiom prop
                 -> IsProved IsAxiom (InterpArith prop))
    -> (forall prop, IsLproposition prop = true
               -> InterpArith (Lnot prop) = Lnot (InterpArith prop))
    -> IsConsistent IsAxiom
    -> HAstandardModelSat (IamNotProvable IsAxiom IsAxiomRep InterpArithRepr).
Proof.
  intros. intro varValues.
  apply (IamNotProvableTrueEquiv _ _ _ InterpArithRepr).
  exact (IamNotProvableNotProvableConsistent _ _ _ _ H H0 H1).
Qed.

(* Variant of the previous lemma where IsAxiom is a sub-theory of true
   arithmetic (instead of an extension of IsWeakHeytingAxiom).
   Its consistency is given by the standard model of arithmetic. *)
Lemma IamNotProvableSubTrueArith : forall (IsAxiom : nat -> bool) IsAxiomRep,
    (forall ax:nat, IsAxiom ax = true -> HAstandardModelSat ax)
    -> HAstandardModelSat (IamNotProvable IsAxiom IsAxiomRep IdRepresented).
Proof.
  (* By contradiction : if there was a proof of IamNotProvable by IsAxiom,
     then IamNotProvable would be true in the standard model of arithmetic.
     But then the initial proof would not exist. *)
  intros IsAxiom IsAxiomRep IsAxiomSat varValues.
  apply (IamNotProvableTrueEquiv _ _ _ IdRepresented).
  intro proofG.
  pose proof (HAstandardModel_correction IsAxiom _ IsAxiomSat proofG) as H.
  specialize (H varValues).
  rewrite <- (IamNotProvableTrueEquiv _ _ _ IdRepresented) in H.
  contradiction.
Qed.

Lemma IsWeakHeytingAxiomRep : FunctionRepresentedBool 1 IsWeakHeytingAxiom.
Proof.
  apply (OrRepresented 1).
  apply (OrRepresented 1).
  apply (OrRepresented 1).
  apply (OrRepresented 1).
  apply (OrRepresented 1).
  apply (OrRepresented 1).
  apply (OrRepresented 1).
  - apply (EqbRepresented 1).
    apply (proj_represented 1 0); auto.
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply ComposeRepr_21. exact ConsNat_repr.
    apply ComposeRepr_11. exact Lnot_repr.
    apply ComposeRepr_21. exact Leq_repr.
    apply ComposeRepr_21. exact Lop1_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_21. exact Lop_repr.
    apply (ConstantRepresented 0).
    apply (ConstantRepresented 0).
    apply (ConstantRepresented 0).
  - apply (EqbRepresented 1).
    apply (proj_represented 1 0); auto.
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply ComposeRepr_21. exact ConsNat_repr.
    2: apply (ConstantRepresented 0).
    apply ComposeRepr_21. exact Lor_repr.
    apply ComposeRepr_21. exact Leq_repr.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply (ConstantRepresented PAzero).
    apply ComposeRepr_21. exact Lexists_repr.
    apply (ConstantRepresented 1).
    apply ComposeRepr_21. exact Leq_repr.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    unfold PAsucc.
    apply ComposeRepr_21. exact Lop1_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 1).
  - apply (EqbRepresented 1).
    apply (proj_represented 1 0); auto.
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply ComposeRepr_21. exact ConsNat_repr.
    apply ComposeRepr_21. exact Lforall_repr.
    apply (ConstantRepresented 1).
    apply ComposeRepr_21. exact Limplies_repr.
    apply ComposeRepr_21. exact Leq_repr.
    apply ComposeRepr_21. exact Lop1_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_21. exact Lop1_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 1).
    apply ComposeRepr_21. exact Leq_repr.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 1).
    apply (ConstantRepresented 0).
  - apply (EqbRepresented 1).
    apply (proj_represented 1 0); auto.
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply ComposeRepr_21. exact ConsNat_repr.
    apply ComposeRepr_21. exact Leq_repr.
    apply ComposeRepr_21.
    apply ComposeRepr_32. exact Lop2_repr.
    apply (ConstantRepresented 0).
    apply (proj_represented 2 0); auto.
    apply (proj_represented 2 1); auto.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply (ConstantRepresented PAzero).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply (ConstantRepresented 0).
  - apply (EqbRepresented 1).
    apply (proj_represented 1 0); auto.
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply ComposeRepr_21. exact ConsNat_repr.
    apply ComposeRepr_21. exact Lforall_repr.
    apply (ConstantRepresented 1).
    apply ComposeRepr_21. exact Leq_repr.
    apply ComposeRepr_21.
    apply ComposeRepr_32. exact Lop2_repr.
    apply (ConstantRepresented 0).
    apply (proj_represented 2 0); auto.
    apply (proj_represented 2 1); auto.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_21. exact Lop1_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 1).
    apply ComposeRepr_21. exact Lop1_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_31. exact Lop2_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 1).
    apply (ConstantRepresented 0).
  - apply (EqbRepresented 1).
    apply (proj_represented 1 0); auto.
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply ComposeRepr_21. exact ConsNat_repr.
    apply ComposeRepr_21. exact Leq_repr.
    apply ComposeRepr_21.
    apply ComposeRepr_32. exact Lop2_repr.
    apply (ConstantRepresented 1).
    apply (proj_represented 2 0); auto.
    apply (proj_represented 2 1); auto.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply (ConstantRepresented PAzero).
    apply (ConstantRepresented PAzero).
    apply (ConstantRepresented 0).
  - apply (EqbRepresented 1).
    apply (proj_represented 1 0); auto.
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply ComposeRepr_21. exact ConsNat_repr.
    apply ComposeRepr_21. exact Lforall_repr.
    apply (ConstantRepresented 1).
    apply ComposeRepr_21. exact Leq_repr.
    apply ComposeRepr_21.
    apply ComposeRepr_32. exact Lop2_repr.
    apply (ConstantRepresented 1).
    apply (proj_represented 2 0); auto.
    apply (proj_represented 2 1); auto.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11.
    apply ComposeRepr_21. exact Lop1_repr.
    apply (ConstantRepresented 0).
    apply (proj_represented 1 0); auto.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 1).
    apply ComposeRepr_11.
    apply ComposeRepr_21.
    apply ComposeRepr_32. exact Lop2_repr.
    apply (ConstantRepresented 0).
    apply (proj_represented 2 0); auto.
    apply (proj_represented 2 1); auto.
    apply ComposeRepr_21.
    apply ComposeRepr_32. exact Lop2_repr.
    apply (ConstantRepresented 1).
    apply (proj_represented 2 0); auto.
    apply (proj_represented 2 1); auto.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 1).
    apply (proj_represented 1 0); auto.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply (ConstantRepresented 0).
  - apply (EqbRepresented 1).
    apply (proj_represented 1 0); auto.
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply (ComposeRepr_11 _ _ (ConsNat_fst_repr _)).
    apply ComposeRepr_21. exact ConsNat_repr.
    apply ComposeRepr_21. exact Lforall_repr.
    apply (ConstantRepresented 1).
    apply ComposeRepr_21.
    apply (ComposeRepr_22 _ _ _ Land_repr).
    exact Limplies_repr.
    apply ComposeRepr_22. exact Limplies_repr.
    apply (proj_represented 2 1); auto.
    apply (proj_represented 2 0); auto.
    apply ComposeRepr_21.
    apply ComposeRepr_32. exact Lrel2_repr.
    apply (ConstantRepresented 1).
    apply (proj_represented 2 0); auto.
    apply (proj_represented 2 1); auto.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 1).
    apply ComposeRepr_21. exact Lexists_repr.
    apply (ConstantRepresented 2).
    apply ComposeRepr_21. exact Leq_repr.
    apply ComposeRepr_21.
    apply ComposeRepr_32. exact Lop2_repr.
    apply (ConstantRepresented 0).
    apply (proj_represented 2 0); auto.
    apply (proj_represented 2 1); auto.
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 2).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 0).
    apply ComposeRepr_11. exact Lvar_repr.
    apply (ConstantRepresented 1).
    apply (ConstantRepresented 0).
Qed.

Lemma IamNotProvableHeytingTrue
  : HAstandardModelSat (IamNotProvable _ IsWeakHeytingAxiomRep IdRepresented).
Proof.
  apply IamNotProvableSubTrueArith.
  intros ax H.
  apply (HAstandardModel_correction _ _ HAaxiomsSatisfied).
  apply AxiomIsProved. exact H.
  apply PAaxiomIsLproposition.
  unfold IsWeakPeanoAxiom. rewrite H. reflexivity.
Qed.

(* Here we use a model of IsAxiom that satisfies IamNotProvable.
   A syntactical proof is also possible. *)
Lemma IamNotProvableNotRefutable : forall (IsAxiom : nat -> bool) IsAxiomRep,
    (forall n:nat, IsAxiom n = true -> HAstandardModelSat n)
    -> forall n, IsProof IsAxiom (Lnot (IamNotProvable IsAxiom IsAxiomRep IdRepresented)) n = false.
Proof.
  intros.
  destruct (IsProof IsAxiom (Lnot (IamNotProvable IsAxiom IsAxiomRep IdRepresented)) n) eqn:des.
  2: reflexivity.
  exfalso.
  assert (IsProved IsAxiom (Lnot (IamNotProvable IsAxiom IsAxiomRep IdRepresented))).
  { exists n. exact des. }
  pose proof (HAstandardModel_correction IsAxiom _ H H0 (fun _ => 0)).
  rewrite HAstandardModel_not in H1.
  contradict H1. apply IamNotProvableSubTrueArith, H.
Qed.

Lemma IsWeakPeanoAxiomRep : FunctionRepresentedBool 1 IsWeakPeanoAxiom.
Proof.
  apply (OrRepresented 1 _ _ IsWeakHeytingAxiomRep).
  exact IsPropAx4_repr.
Qed.

(* Peano's G is also true, because PA is a consistent extension of HA. *)
Lemma IamNotProvablePeanoTrue
  : HAstandardModelSat (IamNotProvable _ IsWeakPeanoAxiomRep IdRepresented).
Proof.
  intro varValues.
  apply (IamNotProvableTrueEquiv _ _ _ IdRepresented).
  intro proofG.
  apply (IamNotProvableNotProvable IsWeakPeanoAxiom _ _ IdRepresented) in proofG.
  exact (PAconsistent proofG).
  intros. apply (WeakenProvable IsWeakHeytingAxiom IsWeakPeanoAxiom).
  intros. unfold IsWeakPeanoAxiom. rewrite H0. reflexivity. exact H.
  reflexivity.
Qed.