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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq natural (len (rev (Nil))) (len (Nil))).
Admitted.
QuickChick lfind_hyp_test.


Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSets.
Require Import Coq.Lists.SetoidList.
Import ListNotations.

Require Import Shuffle.List.
Require Shuffle.Instruction.

Module Opcode <: UsualDecidableType.
  Inductive Opcode : Set :=
  | Up : Opcode
  | Down : Opcode.

  Definition t : Type := Opcode.

  Include HasUsualEq.
  Include UsualIsEq.

  Definition eq_dec : forall x y : t, {x = y} + {x <> y}.
  Proof.
    decide equality.
  Qed.

  Lemma not_Up_iff_Down : forall opcode : t, Up <> opcode <-> Down = opcode.
  Proof.
    now intros [|].
  Defined.

  Lemma not_Down_iff_Up : forall opcode : t, Down <> opcode <-> Up = opcode.
  Proof.
    now intros [|].
  Defined.
End Opcode.

Module Make (Operand : DecidableTypeBoth).
  Module Instruction := Instruction.Make Opcode Operand.

  Definition t : Type :=
    list Instruction.t.

  Module Notations.
    Notation Up owner :=
      ((Opcode.Up, owner)).

    Notation Down owner :=
      ((Opcode.Down, owner)).

    Notation In instruction instructions :=
      (InA Instruction.eq instruction instructions).

    Notation Ahead owner instructions :=
      (In (Up owner) instructions).

    Notation Active owner instructions :=
      (~ In (Up owner) instructions /\
      In (Down owner) instructions).

    Notation Absent owner instructions :=
      (~ In (Down owner) instructions).
  End Notations.
  Import Notations.

  Inductive Ok : t -> Prop :=
  | nil :
    Ok []
  | cons_Up :
    forall
      (p₀ : Operand.t)
      (x₀ : t),
      Active p₀ x₀ ->
      Ok x₀ ->
      Ok (Up p₀ :: x₀)
  | cons_Down :
    forall
      (p₀ : Operand.t)
      (x₀ : t),
      Absent p₀ x₀ ->
      Ok x₀ ->
      Ok (Down p₀ :: x₀).

  Definition Closed
    (x : t) :
    Prop :=
      forall
        p : Operand.t,
        In (Down p) x -> Ahead p x.

  Lemma Closed_impl_not_Active :
    forall
      (p : Operand.t)
      (x : t),
      Closed x ->
      ~ Active p x.
  Proof.
    intros p x Closed_x (not_Ahead_p & H).
    now contradict not_Ahead_p; apply Closed_x.
  Qed.

  Module Orthogonal.
    Section Orthogonal.
      Variables
        (v : Operand.t)
        (x : t).

      Lemma Up_impl_Down :
        Ok x ->
        Ahead v x ->
        In (Down v) x.
      Proof.
        intros Ok_x.
        induction Ok_x as [| p₀ x₀ Active_p₀_x₀ Ok_x₀ IHx₀| p₀ x₀ Absent_p₀_x₀ Ok_x₀ IHx₀];
          intros Ahead_v_x; [easy| ..].
          1 - 2:
          apply InA_cons in Ahead_v_x as [(eq & v_eq_p₀)| Ahead_v_x₀];
          [change (Operand.eq v p₀) in v_eq_p₀| now right; apply IHx₀].
            now rewrite v_eq_p₀; right.
          now contradict eq; apply Opcode.not_Up_iff_Down.
      Qed.

      Lemma Ahead_Active :
        Ahead v x ->
        Active v x ->
        False.
      Proof.
        now intros Ahead_v_x Active_v_x.
      Qed.

      Lemma Active_Absent :
        Active v x ->
        Absent v x ->
        False.
      Proof.
        now intros Active_v_x Absent_v_x.
      Qed.

      Lemma Ahead_Absent :
        Ok x ->
        Ahead v x ->
        Absent v x ->
        False.
      Proof.
        intros Ok_x Ahead_v_x Absent_v_x.
        contradict Absent_v_x.
        now apply Up_impl_Down.
      Qed.

      Lemma Active_impl_not_Ahead :
        Active v x ->
        ~ Ahead v x.
      Proof.
        now intros Active_v_x Ahead_v_x; apply Ahead_Active.
      Qed.

      Lemma Absent_impl_not_Ahead :
        Ok x ->
        Absent v x ->
        ~ Ahead v x.
      Proof.
        now intros Ok_x Absent_v_x Ahead_v_x; apply Ahead_Absent.
      Qed.

      Lemma Ahead_impl_not_Active :
        Ahead v x ->
        ~ Active v x.
      Proof.
        now intros Ahead_v_x Active_v_x; apply Ahead_Active.
      Qed.

      Lemma Absent_impl_not_Active :
        Absent v x ->
        ~ Active v x.
      Proof.
        now intros Absent_v_x Active_v_x; apply Active_Absent.
      Qed.

      Lemma Ahead_impl_not_Absent :
        Ok x ->
        Ahead v x ->
        ~ Absent v x.
      Proof.
        now intros Ok_x Ahead_v_x Absent_v_x; apply Ahead_Absent.
      Qed.

      Lemma Active_impl_not_Absent :
        Active v x ->
        ~ Absent v x.
      Proof.
        now intros Active_v_x Absent_v_x; apply Active_Absent.
      Qed.
    End Orthogonal.

    Module Hints.
      #[export]
      Hint Resolve Active_impl_not_Ahead : instructions.
      #[export]
      Hint Resolve Absent_impl_not_Ahead : instructions.
      #[export]
      Hint Resolve Ahead_impl_not_Active : instructions.
      #[export]
      Hint Resolve Absent_impl_not_Active : instructions.
      #[export]
      Hint Resolve Ahead_impl_not_Absent : instructions.
      #[export]
      Hint Resolve Active_impl_not_Absent : instructions.
    End Hints.
  End Orthogonal.
  Import Orthogonal.Hints.

  Module Ok.
    Section Ok.
      Variables
        (p₀ v : Operand.t)
        (u₀ : Instruction.t)
        (x₀ x : t).

      Lemma cons_inv :
        Ok (u₀ :: x₀) ->
        Ok x₀.
      Proof.
        now inversion 1.
      Qed.

      Lemma cons_Up_inv :
        Ok (Up p₀ :: x₀) ->
        Active p₀ x₀.
      Proof.
        intros Ok_x₀.
        now inversion_clear Ok_x₀.
      Qed.

      Lemma cons_Down_inv :
        Ok (Down p₀ :: x₀) ->
        Absent p₀ x₀.
      Proof.
        intros Ok_x₀.
        now inversion_clear Ok_x₀.
      Qed.

      Lemma nil_iff :
        Ok [] <->
        True.
      Proof.
        now split; [| constructor].
      Qed.

      Lemma cons_Up_iff :
        Ok (Up p₀ :: x₀) <->
          Active p₀ x₀ /\
          Ok x₀.
      Proof.
        now split; [inversion_clear 1| constructor].
      Qed.

      Lemma cons_Down_iff :
        Ok (Down p₀ :: x₀) <->
          Absent p₀ x₀ /\
          Ok x₀.
      Proof.
        now split; [inversion_clear 1| constructor].
      Qed.
    End Ok.

    Lemma split :
      forall
      x y : t,
      Ok (x ++ y) ->
      Ok y.
    Proof.
      intros x y; move y after x.
      induction x as [| u₀ x₀ IHx₀]; intros Ok_z.
        exact Ok_z.
      apply IHx₀, cons_inv with (1 := Ok_z).
    Qed.

    Module Hints.
      #[export]
      Hint Constructors Ok : instructions.

      #[export]
      Hint Immediate cons_inv : instructions.
      #[export]
      Hint Immediate cons_Up_inv : instructions.
      #[export]
      Hint Immediate cons_Down_inv : instructions.
    End Hints.

    Add Parametric Morphism : Ok with signature
      (Tail (A := Instruction.t)) ++> impl as Ok_morphism.
    Proof.
      intros x y (u₀ & x₀) Ok_x.
      now apply Ok.cons_inv with u₀.
    Qed.
  End Ok.
  Import Ok.Hints.

  Ltac instructions_tac :=
    eauto with instructions.

  Module Ahead.
    Section Ahead.
      Variables
        (p₀ v : Operand.t)
        (u₀ : Instruction.t)
        (x₀ : t).

      Lemma nil :
        ~ Ahead v [].
      Proof.
        intros Ahead_v_x.
        apply InA_nil with (1 := Ahead_v_x).
      Qed.

      Lemma cons_Up_hd :
        Ahead p₀ (Up p₀ :: x₀).
      Proof.
        now left.
      Qed.

      Lemma cons_Down_hd :
        Ok (Down p₀ :: x₀) ->
        ~ Ahead p₀ (Down p₀ :: x₀).
      Proof with instructions_tac.
        intros Ok_x.
        enough (not_Ahead_p₀_x₀ : ~ Ahead p₀ x₀)...
        now apply not_InA_cons;
          enough (Opcode.Up <> Opcode.Down) by firstorder.
      Qed.

      Lemma cons_tl :
        Ahead v x₀ ->
        Ahead v (u₀ :: x₀).
      Proof.
        now right.
      Qed.

      Lemma nil_iff :
        Ahead v [] <->
        False.
      Proof.
        now split; [apply nil|].
      Qed.

      Lemma cons_Up_iff :
        Ahead v (Up p₀ :: x₀) <->
          Operand.eq p₀ v \/
          Ahead v x₀.
      Proof.
        split.
          intros Ahead_v_x.
          destruct (Operand.eq_dec p₀ v) as [p₀_eq_v| p₀_neq_v];
            [now left| right].
          now apply InA_cons in Ahead_v_x as [(_ & p₀_eq_v)| Ahead_v_x₀];
            [absurd (Operand.eq p₀ v)|].
        now intros [p₀_eq_v| Ahead_v_x₀]; [left| right].
      Qed.

      Lemma cons_Down_iff :
        Ahead v (Down p₀ :: x₀) <->
        Ahead v x₀.
      Proof.
        split.
          intros Ahead_v_x.
          now apply InA_cons in Ahead_v_x as [(Up_eq_Down & _)| Ahead_v_x₀];
            [contradict Up_eq_Down; apply Opcode.not_Up_iff_Down|].
        now intros Ahead_v_x₀; right.
      Qed.
    End Ahead.

    Module Hints.
      #[export]
      Hint Resolve nil : instructions.
      #[export]
      Hint Resolve cons_Up_hd : instructions.
      #[export]
      Hint Resolve cons_Down_hd : instructions.
      #[export]
      Hint Resolve cons_tl : instructions.
    End Hints.
  End Ahead.
  Import Ahead.Hints.

  Module Active.
    Section Active.
      Variables
        (p₀ v : Operand.t)
        (x₀ : t).

      Lemma nil : ~ Active v [].
      Proof.
        intros (_ & In_Down_v).
        apply InA_nil with (1 := In_Down_v).
      Qed.

      Lemma cons_Up_hd :
        ~ Active p₀ (Up p₀ :: x₀).
      Proof with instructions_tac.
        enough (Ahead p₀ (Up p₀ :: x₀))...
      Qed.

      Lemma cons_Up_tl :
        ~ Operand.eq p₀ v ->
        Active v x₀ ->
        Active v (Up p₀ :: x₀).
      Proof.
        intros p₀_neq_v Active_v_x₀.
        constructor; [| now right].
        rewrite Ahead.cons_Up_iff; tauto.
      Qed.

      Lemma cons_Down_hd :
        Ok (Down p₀ :: x₀) ->
        Active p₀ (Down p₀ :: x₀).
      Proof with instructions_tac.
        intros Ok_instructions.
        constructor; [| now left].
        rewrite Ahead.cons_Down_iff...
      Qed.

      Lemma cons_Down_tl :
        Active v x₀ ->
        Active v (Down p₀ :: x₀).
      Proof with instructions_tac.
        intros Active_v.
        constructor; [| now right].
        rewrite Ahead.cons_Down_iff...
      Qed.

      Lemma nil_iff :
        Active v [] <->
        False.
      Proof.
        now split; [apply nil|].
      Qed.

      Lemma cons_Up_iff :
        Active v (Up p₀ :: x₀) <->
          ~ Operand.eq p₀ v /\
          Active v x₀.
      Proof.
        split.
          intros (not_Ahead_v_x & In_Down_v_x).
          assert (~ Operand.eq p₀ v /\ ~ Ahead v x₀) as
            (p₀_neq_v & not_Ahead_v_x₀) by
            (rewrite Ahead.cons_Up_iff in not_Ahead_v_x; tauto).
          enough (In (Down v) x₀) by firstorder.
          now enough (Opcode.Down <> Opcode.Up);
            [apply InA_cons in In_Down_v_x; firstorder|].
        now intros (p₀_neq_v & Active_v_x₀); apply cons_Up_tl.
      Qed.

      Lemma cons_Down_iff :
        Ok (Down p₀ :: x₀) ->
          Active v (Down p₀ :: x₀) <->
            Operand.eq p₀ v \/
            Active v x₀.
      Proof.
        intros Ok_instructions.
        split.
          intros (not_Ahead_v_x & In_Down_v_x).
          destruct (Operand.eq_dec p₀ v) as [p₀_eq_v| p₀_neq_v];
            [now left| right].
          apply InA_cons in In_Down_v_x.
          enough (~ Operand.eq v p₀); firstorder.
        now intros [<-| Active_v];
          [apply cons_Down_hd| apply cons_Down_tl].
      Qed.
    End Active.

    Module Hints.
      #[export]
      Hint Resolve nil : instructions.
      #[export]
      Hint Resolve cons_Up_hd : instructions.
      #[export]
      Hint Resolve cons_Up_tl : instructions.
      #[export]
      Hint Resolve cons_Down_hd : instructions.
      #[export]
      Hint Resolve cons_Down_tl : instructions.
    End Hints.
    Import Hints.

    Module Sets (M : MSetInterface.WSetsOn Operand).
      Module M_Facts := MSetFacts.WFactsOn Operand M.
      Module M_Properties := MSetProperties.WPropertiesOn Operand M.

      Notation Ok x s :=
        (forall
          p : Operand.t,
          M.In p s <->
          Active p x).

      Fixpoint active
        (x : t) :
        M.t :=
        match x with
        | [] =>
          M.empty
        | Up p₀ :: x₀ =>
          M.remove p₀ (active x₀)
        | Down p₀ :: x₀ =>
          M.add p₀ (active x₀)
        end.

      Notation count x :=
        (M.cardinal (active x)).

      Section Iff.
        Variables
          (p₀ : Operand.t)
          (x₀ : t)
          (p : Operand.t).

        Lemma nil_iff :
          M.In p (active []) <-> False.
        Proof.
          apply M_Facts.empty_iff.
        Qed.

        Lemma cons_Up_iff :
          M.In p (active (Up p₀ :: x₀)) <->
            ~ Operand.eq p₀ p /\
            M.In p (active x₀).
        Proof.
          now simpl; rewrite M_Facts.remove_iff.
        Qed.

        Lemma cons_Down_iff :
          M.In p (active (Down p₀ :: x₀)) <->
            Operand.eq p₀ p \/
            M.In p (active x₀).
        Proof.
          apply M_Facts.add_iff.
        Qed.
      End Iff.

      Section Spec.
        Variables
          x : t.

        Lemma spec :
          Make.Ok x ->
          Ok x (active x).
        Proof.
          induction 1 as [| u₀ x₀ Active_u₀_x₀ Ok_x₀ IHx₀|
          u₀ x₀ Absent_u₀_x₀ Ok_x₀ IHx₀]; intros p.
              now rewrite nil_iff.
            now rewrite cons_Up_iff, IHx₀, Active.cons_Up_iff.
          now rewrite cons_Down_iff, IHx₀, Active.cons_Down_iff by
            now constructor.
        Qed.

        Lemma closed :
          Make.Ok x ->
          Make.Closed x ->
          M.Empty (active x).
        Proof.
          intros Ok_x Closed_x p.
          rewrite spec by assumption.
          now apply Closed_impl_not_Active.
        Qed.
      End Spec.

      Section Hints.
        Variables
          (p₀ : Operand.t)
          (x₀ : t).

        Lemma not_In_Up :
          ~ M.In p₀ (active (Up p₀ :: x₀)).
        Proof.
          simpl; auto with set.
        Qed.

        Lemma In_Down :
          M.In p₀ (active (Down p₀ :: x₀)).
        Proof.
          simpl; auto with set.
        Qed.

        Lemma Down_not_In :
          Make.Ok (Down p₀ :: x₀) ->
          ~ M.In p₀ (active x₀).
        Proof with eauto with instructions.
          intros Ok_x.
          enough (Active_p₀_x₀ : ~ Active p₀ x₀).
            contradict Active_p₀_x₀; apply spec...
          auto with instructions.
        Qed.

        Lemma Up_In :
          Make.Ok (Up p₀ :: x₀) ->
          M.In p₀ (active x₀).
        Proof with eauto with instructions.
          intros Ok_x.
          apply spec...
        Qed.
      End Hints.

      Section Count.
        Variables
          (p₀ : Operand.t)
          (x₀ x : t).

        Lemma count_closed :
          Make.Ok x ->
          Make.Closed x ->
          count x = O.
        Proof.
          intros Ok_x Closed_x.
          enough (M.Empty (active x)) by
            auto with set.
          now apply closed.
        Qed.

        Lemma count_Up :
          Make.Ok (Up p₀ :: x₀) ->
          S (count (Up p₀ :: x₀)) = count x₀.
        Proof.
          intros Ok_x.
          apply M_Properties.remove_cardinal_1...
          now apply Up_In.
        Qed.

        Lemma count_Down :
          Make.Ok (Down p₀ :: x₀) ->
          count (Down p₀ :: x₀) = S (count x₀).
        Proof with instructions_tac.
          intros Ok_x.
          apply M_Properties.add_cardinal_2.
          now apply Down_not_In.
        Qed.
      End Count.

      Definition IsChromaticNumber
        (instructions : t)
        (χ : nat) :
        Prop :=
        Skip.Forall
          (fun skip : t => count skip <= χ)
          instructions /\
        Skip.Exists
          (fun skip : t => count skip = χ)
          instructions.
    End Sets.
  End Active.

  Module Absent.
    Section Absent.
      Variables
        (p₀ v : Operand.t)
        (u₀ : Instruction.t)
        (x₀ : t).

      Lemma nil :
        Absent v [].
      Proof.
        unfold not; apply InA_nil.
      Qed.

      Lemma cons_Up_hd :
        Ok (Up p₀ :: x₀) ->
        ~ Absent p₀ (Up p₀ :: x₀).
      Proof.
        instructions_tac.
      Qed.

      Lemma cons_Up_tl :
        Absent v x₀ ->
        Absent v (Up p₀ :: x₀).
      Proof.
        intros Absent_v.
        now apply not_InA_cons; split;
          [apply Instruction.neq_opcode, Opcode.not_Down_iff_Up|].
      Qed.

      Lemma cons_Down_hd :
        ~ Absent p₀ (Down p₀ :: x₀).
      Proof.
        enough (In (Down p₀) (Down p₀ :: x₀)) by firstorder.
        now constructor.
      Qed.

      Lemma cons_Down_tl :
        ~ Operand.eq p₀ v ->
        Absent v x₀ ->
        Absent v (Down p₀ :: x₀).
      Proof.
        intros p₀_neq_v Absent_v.
        now apply not_InA_cons; split;
          [apply Instruction.neq_operand; contradict p₀_neq_v|].
      Qed.

      Lemma cons_inv :
        Absent v (u₀ :: x₀) ->
        Absent v x₀.
      Proof.
        intros Absent_v.
        now apply not_InA_cons in Absent_v.
      Qed.

      Lemma nil_iff :
        Absent v [] <->
        True.
      Proof.
        easy.
      Qed.

      Lemma cons_Down_iff :
        Absent v (Down p₀ :: x₀) <->
          ~ Operand.eq p₀ v /\
          Absent v x₀.
      Proof.
        split; intros Absent_v; [| now apply cons_Down_tl].
        apply not_InA_cons in Absent_v as (v_neq_p₀ & Absent_v).
        apply Instruction.neq_eq_opcode in v_neq_p₀; [| reflexivity].
        now split; [contradict v_neq_p₀|].
      Qed.

      Lemma cons_Up_iff :
        Absent v (Up p₀ :: x₀) <->
        Absent v x₀.
      Proof.
        split.
          intros Absent_v.
          now apply not_InA_cons with (Up p₀).
        now intros Absent_v; apply not_InA_cons; split;
          [apply Instruction.neq_opcode, Opcode.not_Down_iff_Up|].
      Qed.
    End Absent.

    Module Hints.
      #[export]
      Hint Resolve nil : instructions.
      #[export]
      Hint Resolve cons_Up_hd : instructions.
      #[export]
      Hint Resolve cons_Up_tl : instructions.
      #[export]
      Hint Resolve cons_Down_hd : instructions.
      #[export]
      Hint Resolve cons_Down_tl : instructions.

      #[export]
      Hint Immediate cons_inv : instructions.
    End Hints.
  End Absent.

  Module Hints.
    Create HintDb instructions.

    Export Ok.Hints.
    Export Orthogonal.Hints.
    Export Ahead.Hints.
    Export Active.Hints.
    Export Absent.Hints.
  End Hints.
End Make.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B Aprime P : Universe, ((wd_ O E /\ (wd_ O Eprime /\ (wd_ O A /\ (wd_ A Aprime /\ (wd_ B O /\ (wd_ E Eprime /\ (wd_ Aprime P /\ (col_ O E B /\ (col_ A O E /\ col_ Aprime O E))))))))) -> col_ E A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export Dynamic.
Require Import SyntaxProp.
Require Import MapProp.

Lemma step_preserves_this :
  forall id M M' H H' n n' e e' l L C Q,
    (exists e, heapLookup H id = Some (l, L, C, Q, e)) ->
    id / (M, H, n); e ==> (M', H', n'); e' ->
    exists L' C' Q' e'', heapLookup H' id = Some (l, L', C', Q', e'').
Proof with hauto.
  introv Hex Hstep.
  gen e'.
  inv Hex as [e' Hlookup].
  expr_cases (induction e) Case; intros;
    inv Hstep; try solve[inv_ctx]...
Qed.

Lemma monotonic_heap :
  forall id M M' H H' n n' e e',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    length H <= length H'.
Proof with hauto.
  introv Hstep.
  gen Hstep. gen e'.
  expr_cases(induction e) Case; intros;
    inv Hstep; try solve[inv_ctx]...
Qed.

Lemma monotonic_local_heap :
  forall id id' M M' H H' n n' e e' L L' l,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    LH H id' = Some L ->
    LH H' id' = Some L' ->
    In l L ->
    In l L'.
Proof with (hauto; eauto using in_cons).
  introv Hstep HLH1 HLH2 HIn.
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try rewrite_and_invert...
  + Case "ENew".
    destruct (heapLookup H id')...
    destruct_actor a...
Qed.

Lemma new_locs_in_local_heap :
  forall id M M' H H' n n' L L' e e',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    LH H id = Some L ->
    LH H' id = Some L' ->
    (forall l, In l (freeLocs e) -> In l L) ->
    (forall l, In l (freeLocs e') -> In l L').
Proof with eauto using in_or_app.
  introv Hstep HLH1 HLH2 HIn HIn'.
  assert (forall l, In l L -> In l L') as Hmono.
    intros; eapply monotonic_local_heap...
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try contradiction;
    simpls;
    try solve [
          first [apply in_app_or in HIn'|
                 apply freeLocs_subst_in in HIn'];
          inv HIn'; eauto using in_or_app]...
  + Case "ENew".
    inv HIn'; try contradiction.
    hauto.
    constructors...
Qed.

Lemma new_ids_in_heap :
  forall id M M' H H' n n' e e',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    (forall id, In id (freeIds e) -> id < length H) ->
    (forall id', In id' (freeIds e') -> id' < length H').
Proof with (hauto; eauto using in_or_app, monotonic_heap).
  introv Hstep Hid HIn.
  assert (length H <= length H') as Hmono...
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try rewrite_and_invert; simpls;
    try (first [apply in_app_or in HIn
               |apply freeIds_subst_in in HIn];
         inv HIn);
    try contradiction;
    try (assert (id' < length H) by eauto using in_or_app; omega)...
Qed.

Lemma bid_actors_in_heap :
  forall id id' M M' H H' n n' e e' l,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    id < length H ->
    (forall l id'', In (l, id'') (freeBIds e) -> id'' < length H) ->
    In (l, id') (freeBIds e') ->
    id' < length H.
Proof with eauto using in_or_app, monotonic_heap.
  introv Hstep Hlt HBId HIn.
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx; simpls;
    try contradiction;
    try solve[
          first[apply in_app_or in HIn
               |apply freeBIds_subst_in in HIn];
          inv HIn; eauto using in_or_app]...
  + Case "EBes". inv HIn... inv H. omega.
Qed.

Lemma bid_loc_in_local_heap :
  forall id id' M M' H H' n n' e e' l L L' L'',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    (forall l', In l' (freeLocs e) -> In l' L'') ->
    (forall l' id'',
        In (l', id'') (freeBIds e) ->
        id'' < length H /\
        LH H id'' = Some L -> In l' L) ->
    In (l, id') (freeBIds e') ->
    LH H id' = Some L ->
    LH H' id' = Some L' ->
    LH H id = Some L'' ->
    In l L'.
Proof with eauto using in_or_app.
  introv Hstep Hloc HBId HIn HLH HLH' HLH''.
  gen e'. gen L''.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx; simpls;
    try contradiction;
    try rewrite_and_invert;
    try solve[apply in_app_or in HIn;
              inv HIn;
              try solve[eapply IHe1 with (L'' := L'');
                        eauto using in_or_app
                       |eapply IHe2 with (L'' := L'');
                        eauto using in_or_app];
              try eapply monotonic_local_heap;
              try eapply HBId;
              eauto using in_or_app]...
  + Case "EApp".
    eapply freeBIds_subst_in in HIn. inv HIn; eapply HBId...
  + Case "EBes".
    inv HIn; try contradiction.
    inv H...
    repeat rewrite_and_invert...
Qed.

Lemma step_footprint :
  forall id id' M M' H H' n n' e e' e'' l L C Q,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    heapLookup H' id' = Some (l, L, C, Q, e'') ->
    (exists L C Q, heapLookup H id' = Some (l, L, C, Q, e'')) \/
    e'' = EUnit /\ In l L.
Proof with hauto.
  introv Hstep Hlookup.
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
  + Case "ENew".
    right. splits... constructors...
Qed.

Lemma step_local_heap_neq :
  forall id id' M M' H H' n n' e e' L,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    LH H' id' = Some L ->
    id <> id' ->
    id' < length H ->
    LH H id' = Some L.
Proof with hauto.
  introv Hstep HLH Hneq Hlt.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    hauto;
    try contradiction;
    try omega...
Qed.

Lemma step_id_lt :
  forall id id' M M' H H' n n' e e' L,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    LH H' id' = Some L ->
    id' < length H \/ id' = length H /\ L = n :: nil.
Proof with hauto.
  introv Hstep HLH.
  gen e'. gen L.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
Qed.

Lemma step_single_allocation :
  forall id id' M M' H H' n n' e e',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    length H < length H' ->
    id' < length H ->
    LH H' id' = LH H id'.
Proof with (hauto; try omega).
  introv Hstep Hlt Hlt'.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
Qed.

Lemma step_allocates_n :
  forall id id' M M' H H' n n' e e' L,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    LH H id' = Some L ->
    LH H' id' = Some L \/ LH H' id' = Some (n :: L).
Proof with hauto.
  introv Hstep HLH.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep;
    try inv_ctx...
Qed.

Lemma monotonic_fresh :
  forall id M M' H H' n n' e e',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    n <= n'.
Proof with eauto.
  introv Hstep.
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
Qed.

Lemma step_conversation_neq :
  forall id id' M M' H H' n n' e e' C,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    conv H' id' = Some C ->
    id <> id' ->
    id' < length H ->
    conv H id' = Some C.
Proof with hauto.
  introv Hstep Hconv Hneq Hlt.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    hauto;
    try contradiction;
    try omega...
Qed.

Lemma step_conv_lt :
  forall id id' M M' H H' n n' e e' C,
    id / (M, H, n); e ==> (M', H', n'); e' ->
    conv H' id' = Some C ->
    id' < length H \/ id' = length H /\ forall id, C id = None.
Proof with hauto.
  introv Hstep HLH.
  gen e'. gen C.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx; hauto;
    try solve [left; eapply heapLookup_lt; destruct (heapLookup H id'); hauto
              |left; eapply heapLookup_lt; destruct (heapLookup H' id'); hauto]...
Qed.

Lemma step_conversation_effect :
  forall id M M' H H' n n' e e' C C',
    id / (M, H, n); e ==> (M', H', n'); e' ->
    conv H id = Some C ->
    conv H' id = Some C' ->
    (forall id qid,
        C' id = Some qid ->
        C id = Some qid \/ qid = n /\ M' qid = Some (nil, id)).
Proof with eauto.
  introv Hstep Hconv Hconv'.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try rewrite_and_invert;
    try solve[hauto
             |rewrite_and_invert].
  + Case "ENew".
    hauto. inv H0.
    rewrite_and_invert.
  + Case "EAtStart".
    hauto.
    - unfold extend in H0.
      cases_if... inv_eq...
    - unfold extend in H0.
      cases_if... inv_eq...
  + Case "EAtStart".
    hauto.
    - unfold extend in H0.
      cases_if... inv_eq...
    - unfold extend in H0.
      cases_if... inv_eq...
  + Case "EAtEnd".
    hauto.
    - unfold drop in H0.
      cases_if...
    - unfold drop in H0.
      cases_if...
  + Case "EAtEnd".
    hauto.
    - unfold drop in H0.
      cases_if...
    - unfold drop in H0.
      cases_if...
Qed.


From Undecidability.TM.Code Require Import ProgrammingTools.

(* * Constructor and Deconstructor Machines for Natural Numbers *)

Lemma tl_length (X : Type) (xs : list X) :
  length (tl xs) = pred (length xs).
Proof. destruct xs; auto. Qed.

Global Hint Rewrite tl_length : list.

Section CaseNat.

  (* ** Deconstructor *)

  Definition CaseNat_Rel : Rel (tapes sigNat^+ 1) (bool * tapes sigNat^+ 1) :=
    Mk_R_p
      (fun tin '(yout, tout) =>
         forall (n : nat) (sn : nat),
           tin ≃(;sn) n ->
           match yout, n with
           | false, O => tout ≃(;sn) 0
           | true, S n' => tout ≃(;S sn) n'
           | _, _ => False
           end).

  Definition CaseNat : pTM sigNat^+ bool 1 :=
    Move Rmove;;
    Switch (ReadChar)
          (fun o => match o with
                 | Some (inr sigNat_S) => Return (Write (inl START)) true (* S *)
                 | Some (inr sigNat_O) => Return (Move Lmove) false (* O *)
                 | _ => Return (Nop) default (* invalid input *)
                 end).

  Definition CaseNat_steps := 5.

  Lemma CaseNat_Sem : CaseNat ⊨c(CaseNat_steps) CaseNat_Rel.
  Proof.
    unfold CaseNat_steps. eapply RealiseIn_monotone.
    { unfold CaseNat. TM_Correct. }
    { Unshelve. 4,8: reflexivity. all: lia. }
    {
      intros tin (yout&tout) H. intros n s HEncN. TMSimp.
      destruct HEncN as (r1&HEncN&Hs). TMSimp.
      destruct n; cbn in *; TMSimp.
      - repeat econstructor; auto.
      - hnf. eexists. split. f_equal. cbn. lia.
    }
  Qed.

  (* ** Constructors *)
  Section NatConstructor.

    Definition S_Rel : Rel (tapes sigNat^+ 1) (unit * tapes sigNat^+ 1) :=
      Mk_R_p (ignoreParam (fun tin tout => forall n sn : nat, tin ≃(;sn) n -> tout ≃(;pred sn) S n)).

    Definition Constr_S : pTM sigNat^+ unit 1 :=
      WriteMove (inr sigNat_S) Lmove;; Write (inl START).

    Definition Constr_S_steps := 3.

    Lemma Constr_S_Sem : Constr_S ⊨c(Constr_S_steps) S_Rel.
    Proof.
      unfold Constr_S_steps. eapply RealiseIn_monotone.
      { unfold Constr_S. TM_Correct. }
      { cbn. lia. }
      {
        intros tin (yout, tout) H. intros n sn HEncN.
        TMSimp. clear all except HEncN.
        destruct HEncN as (r1&->&Hs). cbn. simpl_tape.
        hnf. eexists. split. f_equal. simpl_list. lia.
      }
    Qed.

    Definition Constr_O_size := pred >> pred.

    Definition O_Rel : Rel (tapes sigNat^+ 1) (unit * tapes sigNat^+ 1) :=
      fun tin '(_, tout) => forall sn, isVoid_size tin[@Fin0] sn -> tout[@Fin0] ≃(;Constr_O_size sn) O.

    Definition Constr_O : pTM sigNat^+ unit 1 := WriteValue 0.

    Goal Constr_O = WriteMove (inl STOP) Lmove;; WriteMove (inr sigNat_O) Lmove;; Write (inl START).
    Proof. unfold Constr_O, WriteValue, WriteString.WriteString, encode, Encode_map, map, rev, Encode_nat, encode, repeat, app. reflexivity. Qed.
    Definition Constr_O_steps := 5.

    Lemma Constr_O_Sem : Constr_O ⊨c(Constr_O_steps) O_Rel.
    Proof.
      unfold Constr_O_steps. eapply RealiseIn_monotone.
      { unfold Constr_O. TM_Correct. }
      { cbn. reflexivity. }
      { intros tin (yout, tout) H. intros s HRight. cbn in H. unfold Constr_O_size in *.
        specialize (H _ HRight). contains_ext. unfold WriteValue_size. cbn. lia.
      }
    Qed.

  End NatConstructor.

End CaseNat.

(* ** Tactic Support *)

Ltac smpl_TM_CaseNat :=
  once lazymatch goal with
  | [ |- CaseNat ⊨ _ ] => eapply RealiseIn_Realise; apply CaseNat_Sem
  | [ |- CaseNat ⊨c(_) _ ] => apply CaseNat_Sem
  | [ |- projT1 (CaseNat) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply CaseNat_Sem
  | [ |- Constr_O ⊨ _ ] => eapply RealiseIn_Realise; apply Constr_O_Sem
  | [ |- Constr_O ⊨c(_) _ ] => apply Constr_O_Sem
  | [ |- projT1 (Constr_O) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Constr_O_Sem
  | [ |- Constr_S ⊨ _ ] => eapply RealiseIn_Realise; apply Constr_S_Sem
  | [ |- Constr_S ⊨c(_) _ ] => apply Constr_S_Sem
  | [ |- projT1 (Constr_S) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Constr_S_Sem
  end.

Smpl Add smpl_TM_CaseNat : TM_Correct.

From Undecidability.TM.Hoare Require Import HoareLogic HoareRegister HoareTactics.

Lemma Constr_O_SpecT_size (ss : Vector.t nat 1) :
  TripleT (≃≃(([], withSpace  [|Void |] ss))) Constr_O_steps Constr_O (fun _ => ≃≃(([], withSpace  [|Contains _ 0|] (appSize [|Constr_O_size|] ss)))).
Proof.  unfold withSpace.
  eapply RealiseIn_TripleT.
  - apply Constr_O_Sem.
  - intros tin [] tout H1 H2. cbn in *. specialize (H2 Fin0). simpl_vector in *; cbn in *. modpon H1. tspec_solve.
Qed.

Lemma Constr_S_SpecT_size :
  forall (y : nat) ss,
    TripleT (≃≃(([], withSpace  [|Contains _ y |] ss))) Constr_S_steps Constr_S
            (fun _ => ≃≃(([], withSpace  [|Contains _ (S y)|] (appSize [|S|] ss)))).
Proof.  unfold withSpace.
  intros y ss.
  eapply RealiseIn_TripleT.
  - apply Constr_S_Sem.
  - intros tin [] tout H HEnc. cbn in *.
    specialize (HEnc Fin0). simpl_vector in *; cbn in *. modpon H. tspec_solve.
Qed.

Definition CaseNat_size (n : nat) : Vector.t (nat->nat) 1 :=
  match n with
  | O => [|id|]
  | S n' => [|S|]
  end.

Lemma CaseNat_SpecT_size (y : nat) (ss : Vector.t nat 1) :
  TripleT
    ≃≃([], withSpace  [|Contains _ y |] ss)
    CaseNat_steps
    CaseNat
    (fun yout =>
       ≃≃([if yout then y <> 0 else y = 0],withSpace ([|Contains _ (pred y)|])
            (appSize (CaseNat_size y) ss))).
Proof.  unfold withSpace.
  eapply RealiseIn_TripleT.
  - apply CaseNat_Sem.
  - intros tin yout tout H HEnc. specialize (HEnc Fin0). simpl_vector in *; cbn in *. modpon H.
    destruct yout, y; cbn in *; auto.
    + tspec_solve. easy.
    + tspec_solve. easy.
Qed.

Ltac hstep_Nat :=
  lazymatch goal with
  | [ |- TripleT ?P ?k Constr_O ?Q ] => eapply Constr_O_SpecT_size
  | [ |- TripleT ?P ?k Constr_S ?Q ] => eapply Constr_S_SpecT_size
  | [ |- TripleT ?P ?k CaseNat ?Q ] => eapply CaseNat_SpecT_size
  end.

Smpl Add hstep_Nat : hstep_Spec.


Require Export Iron.Language.SystemF2Store.ExpBase.
Require Export Iron.Language.SystemF2Store.ExpAlt.

(********************************************************************)
(* Lift type indices in expressions. *)
Fixpoint liftTX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar _     => xx
  |  XLoc _     => xx

  |  XLAM x
  => XLAM (liftTX (S d) x)

  |  XAPP x t
  => XAPP (liftTX d x)  (liftTT 1 d t)

  |  XLam t x
  => XLam (liftTT 1 d t)  (liftTX d x)

  |  XApp x1 x2
  => XApp (liftTX d x1) (liftTX d x2)

  |  XCon dc ts xs
  => XCon dc (map (liftTT 1 d) ts) (map (liftTX d) xs)

  |  XCase xx alts
  => XCase (liftTX d xx) (map (liftTA d) alts)

  |  XUpdate c i ts x1 x2
  => XUpdate c i (map (liftTT 1 d) ts) (liftTX d x1) (liftTX d x2)

 end

 with liftTA (d: nat) (aa: alt) : alt :=
  match aa with
  |  AAlt dc xx
  => AAlt dc (liftTX d xx)
  end.

(********************************************************************)
(* Lift expression indices in expressions *)
Fixpoint liftXX (n:  nat) (d:  nat) (xx: exp) {struct xx} : exp :=
 match xx with
    |  XVar ix
    => if le_gt_dec d ix
        (* index was pointing into env, lift it across new elems *)
        then XVar (ix + n)
        (* index was locally bound, leave it be *)
        else xx

    |  XLoc l
    => XLoc l

    |  XLAM x
    => XLAM (liftXX n d x)

    |  XAPP x t
    => XAPP (liftXX n d x) t

    (* increase the depth as we move across a lambda *)
    |  XLam t1 x1
    => XLam t1 (liftXX n (S d) x1)

    |  XApp x1 x2
    => XApp   (liftXX n d x1) (liftXX n d x2)

    (* lift all the arguments of a data constructor *)
    |  XCon dc ts xs
    => XCon dc ts (map (liftXX n d) xs)

    (* lift all the alternatives in a case-expression *)
    |  XCase x alts
    => XCase (liftXX n d x) (map (liftXA n d) alts)

    |  XUpdate c i ts x1 x2
    => XUpdate c i ts (liftXX n d x1) (liftXX n d x2)
    end

 with liftXA (n: nat) (d: nat) (aa: alt) {struct aa}:=
  match aa with
  (* When we enter into the right of an alternative, a new type
     is pushed onto the environment for each of the arguments
     of the data constructor. We need to increase the current
     binding depth by the number of arguments. *)
  |  AAlt (DataCon tag arity) x
  => AAlt (DataCon tag arity) (liftXX n (d + arity) x)
  end.

(* The data constructor of an alternative is unchanged
   by lifting. *)
Lemma dcOfAlt_liftXA
 : forall n d a
 , dcOfAlt (liftXA n d a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_liftXA : global.

Lemma dcOfAlt_liftTA
 : forall d a
 , dcOfAlt (liftTA d a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_liftTA : global.

Lemma dcOfAlt_liftTA_map
 :  forall ix aa
 ,  map dcOfAlt (map (liftTA ix) aa)
 =  map dcOfAlt aa.
Proof.
 intros. induction aa; simpl; burn.
Qed.
Hint Rewrite dcOfAlt_liftTA_map : global.

(* When we lift an expression by zero places,
   then the expression is unchanged. *)
Lemma liftXX_zero
 : forall d x
 , liftXX 0 d x = x.
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA 0 d a = a)
  ; intros; simpl; try burn.

 Case "XVar".
  lift_cases; burn.

 Case "XCon".
  nforall.
  rewrite (map_ext_in (liftXX 0 d) id); auto.
  rewrite map_id; auto.

 Case "XCase".
  nforall.
  rewrite (map_ext_in (liftXA 0 d) id); auto.
  rewrite map_id. burn.

 Case "XAlt".
  destruct dc. burn.
Qed.
Hint Rewrite liftXX_zero : global.

(* Commutivity of lifting. *)
Lemma liftXX_comm
 : forall n m x d
 , liftXX n d (liftXX m d x)
 = liftXX m d (liftXX n d x).
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA n d (liftXA m d a)
      =  liftXA m d (liftXA n d a))
  ; intros; simpl; try burn.

 Case "XVar".
  repeat (simple; lift_cases; intros); burn.

 Case "XCon".
  f_equal. lists.
  nforall.
  rewrite (map_ext_in
   (fun x0 => liftXX n d (liftXX m d x0))
   (fun x0 => liftXX m d (liftXX n d x0))); burn.

 Case "XCase".
  f_equal. eauto.
  lists.
  nforall.
  rewrite (map_ext_in
   (fun a1 => liftXA n d (liftXA m d a1))
   (fun a1 => liftXA m d (liftXA n d a1))); burn.

 Case "XAlt".
  destruct dc. burn.
Qed.

(* When consecutively lifting an expression, we can lift by one
   more place in the first lifting and but one less in the second. *)
Lemma liftXX_succ
 : forall n m d x
 , liftXX (S n) d (liftXX m     d x)
 = liftXX n     d (liftXX (S m) d x).
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA (S n) d (liftXA  m    d a)
      =  liftXA n     d (liftXA (S m) d a))
  ; intros; simpl; try burn.

 Case "XVar".
  repeat (simple; lift_cases; intros); burn.

 Case "XCon".
  f_equal. lists. nforall.
  rewrite (map_ext_in
   (fun x0 => liftXX (S n) d (liftXX m d x0))
   (fun x0 => liftXX n d (liftXX (S m) d x0))); burn.

 Case "XCase".
  f_equal; auto. lists. nforall.
  rewrite (map_ext_in
   (fun x1 => liftXA (S n) d (liftXA m d x1))
   (fun x1 => liftXA n d (liftXA (S m) d x1))); burn.
  auto. auto.

 Case "XAlt".
  destruct dc; burn.
Qed.
Hint Rewrite liftXX_succ : global.

(* We can collapse two consecutive lifting expressions by lifting
   just onces by the sum of the places, provided the lifting
   occurs at depth zero.
   (TODO: we may be able to weaken this second requirement. *)
Lemma liftXX_plus
 : forall n m x
 , liftXX n 0 (liftXX m 0 x) = liftXX (n + m) 0 x.
Proof.
 intros. gen n.
 induction m; intros.
  burn.

  intros.
  rrwrite (n + S m = S n + m).
  rewrite liftXX_comm.
  rewrite <- IHm.
  rewrite liftXX_comm.
  burn.
Qed.


(*|
############################################
Tactic automation: simple decision procedure
############################################

:Link: https://stackoverflow.com/q/47126795
|*)

(*|
Question
********

I'm trying to automate a decision procedure for whether an ASCII
character is whitespace or not. Here is what I currently have.
|*)

Require Import Ascii String.

Scheme Equality for ascii.

Definition IsWhitespace (c : ascii) := (c = "009"%char) \/ (c = "032"%char).

Definition isWhitespace (c : ascii) : {IsWhitespace c} + {not (IsWhitespace c)}.
Proof.
  unfold IsWhitespace.
  pose proof (ascii_eq_dec c "009"%char) as [H1 | H1];
    pose proof (ascii_eq_dec c "032"%char) as [H2 | H2]; auto.
  right. intros [H3 | H3]; auto.
Qed.

(*|
What would be a good approach for making the proof more concise?
|*)

(*|
Answer (ejgallego)
******************

The proof is almost the most concise it can be! At most what you can
do is to call a more powerful tactic such as ``intuition``:
|*)

Reset isWhitespace. (* .none *)
Definition isWhitespace (c : ascii) : {IsWhitespace c} + {not (IsWhitespace c)}.
Proof.
  now unfold IsWhitespace;
    case (ascii_eq_dec c "009"%char);
    case (ascii_eq_dec c " "%char); intuition.
Qed.

(*|
----

**A:** Just a bit more concise reformulation of the above:
|*)

Reset isWhitespace. (* .none *)
Definition isWhitespace (c : ascii) : {IsWhitespace c} + {not (IsWhitespace c)}.
Proof.
  compute; case (ascii_eq_dec c "009"%char), (ascii_eq_dec c " "%char); tauto.
Qed.

(*| We use ``compute`` to unfold everything here. |*)

(*|
Answer (Jason Gross)
********************

Frequently, making a proof more automated involves writing a bit more
code than you started with, so that you can handle more cases. Taking
this approach, I adapted some boilerplate from `fiat-crypto
<https://github.com/mit-plv/fiat-crypto/blob/5da42750e1349ce761107902ef3039195adac62c/src/Util/Decidable.v>`__:
|*)

Reset Initial. (* .none *)
Require Import Coq.Strings.Ascii Coq.Strings.String.

Class Decidable (P : Prop) := dec : {P} + {~P}.
Arguments dec _ {_}.
Notation DecidableRel R := (forall x y, Decidable (R x y)).

Global Instance dec_or {A B} {HA : Decidable A} {HB : Decidable B} :
  Decidable (A \/ B).
Proof. hnf in *. tauto. Defined.
Global Instance dec_eq_ascii : DecidableRel (@eq ascii) := ascii_dec.

(*| With this boilerplate, your proof becomes |*)

Definition IsWhitespace (c : ascii) := (c = "009"%char) \/ (c = "032"%char).
Definition isWhitespace (c : ascii) : Decidable (IsWhitespace c) := _.

(*|
which is about as short as a proof can be. (Note that ``:= _`` is the
same as ``. Proof. exact _. Defined.``, which itself is the same as
``. Proof. typeclasses eauto. Defined.``.)

Note that this is fairly similar to ejgallego's proof, since ``tauto``
is the same as ``intuition fail``.

Note also that `the original boilerplate in fiat-crypto
<https://github.com/mit-plv/fiat-crypto/blob/5da42750e1349ce761107902ef3039195adac62c/src/Util/Decidable.v>`__
is much longer, but also more powerful than simply using ``hnf in *;
tauto``, and handles a few dozen different sorts of decidable
propositions.

----

**Q:** This is super interesting! Would you mind explaining the
``Arguments`` aspect? And why use ``Notation`` instead of
``Definition``?

**Q:** Also... This approach looks a lot like the
``Coq.Structures.Equalities`` part of the standard library, is there
any particular reason not to use it?

**A:** The ``Arguments`` bit lets you write ``dec (x = y)`` to mean
"find an instance of decidability of ``x = y`` by typeclass resolution
and use that here". Without it, ``dec (x = y)`` is a type error,
because ``dec`` means "find the first instance of decidability of any
proposition, by typeclass resolution, and use that here".
|*)

(*|
Answer (ejgallego)
******************

Following the spirit of Jason's answer, we can of course use some
libraries dealing with decidable equality to arrive at your result:

This will declare ``ascii`` as a type with decidable equality:
|*)

Reset Initial. (* .none *)
From Coq Require Import Ascii String ssreflect ssrfun ssrbool.
From mathcomp Require Import eqtype ssrnat.

Lemma ascii_NK : cancel N_of_ascii ascii_of_N.
Proof. exact: ascii_N_embedding. Qed.

Definition ascii_eqMixin := CanEqMixin ascii_NK.
Canonical ascii_eqType := EqType _ ascii_eqMixin.

(*|
In this style, usually you state your properties are decidable
propositions so there is nothing to prove:
|*)

Definition IsWhitespaceb (c : ascii) := [|| c == "009"%char | c == " "%char].

(*|
However if you want, you can of course recover the non-computational one:
|*)

Definition IsWhitespace (c : ascii) := (c = "009"%char) \/ (c = "032"%char).

Lemma whitespaceP c : reflect (IsWhitespace c) (IsWhitespaceb c).
Proof. exact: pred2P. Qed.

(*| Some more automation can be used of course. |*)


Inductive foo (V:Type):Type :=
  | Foo : list (bar V) -> foo V
with bar (V:Type): Type :=
  | bar1: bar V
  | bar2 : V -> bar V.

Module WithPoly.
Polymorphic Inductive foo (V:Type):Type :=
  | Foo : list (bar V) -> foo V
with bar (V:Type): Type :=
  | bar1: bar V
  | bar2 : V -> bar V.
End WithPoly.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Lemma.
Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.ExprTac.
Require Import MirrorCore.Views.Ptrns.

Set Implicit Arguments.
Set Strict Implicit.

Section setoid.
  Context {typ : Set}.
  Context {func : Set}.
  Context {RType_typD : RType typ}.
  Context {Typ2_Fun : Typ2 RType_typD RFun}.
  Context {RSym_func : RSym func}.

  (** Reasoning principles **)
  Context {RTypeOk_typD : RTypeOk}.
  Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.
  Context {RSymOk_func : RSymOk RSym_func}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {RelDec_eq_typ : RelDec (@eq typ)}.
  Context {RelDec_Correct_eq_typ : RelDec_Correct RelDec_eq_typ}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Variable Rbase : Set.
  Variable Rbase_eq : Rbase -> Rbase -> bool.
  Hypothesis Rbase_eq_ok : forall a b, Rbase_eq a b = true -> a = b.

  Inductive R : Set :=
  | Rinj (r : Rbase)
  | Rrespects (l r : R)
  | Rpointwise (t : typ) (r : R)
  | Rflip (r : R).

  Definition Rflip' (r : R) : R :=
    match r with
    | Rflip r => r
    | _ => Rflip r
    end.

  Fixpoint Req_dec (a b : R) : bool :=
    match a , b with
    | Rinj a , Rinj b => Rbase_eq a b
    | Rrespects l r , Rrespects l' r' =>
      if Req_dec l l' then Req_dec r r' else false
    | Rpointwise t a , Rpointwise t' a' =>
      if t ?[ eq ] t' then Req_dec a a' else false
    | Rflip a , Rflip b => Req_dec a b
    | _ , _ => false
    end.

  Theorem Req_dec_ok : forall x y : R, Req_dec x y = true -> x = y.
  Proof.
    clear - RTypeOk_typD Rbase_eq_ok RelDec_Correct_eq_typ.
    induction x; destruct y; simpl; try solve [ congruence ].
    { intros.
      eapply Rbase_eq_ok in H. destruct H; reflexivity. }
    { specialize (IHx1 y1).
      specialize (IHx2 y2).
      destruct (Req_dec x1 y1); intros; try congruence.
      destruct (Req_dec x2 y2); intros; try congruence.
      f_equal; tauto. }
    { consider (t ?[ eq ] t0); intros.
      { subst. f_equal; eauto. } }
    { intros. eapply IHx in H. f_equal. assumption. }
  Qed.

  Variable RbaseD : Rbase -> forall t : typ, option (typD t -> typD t -> Prop).

  Hypothesis RbaseD_single_type
  : forall r t1 t2 rD1 rD2,
      RbaseD r t1 = Some rD1 ->
      RbaseD r t2 = Some rD2 ->
      t1 = t2.

  (** This is due to universe problems! **)
  Definition respectful :=
    fun (A B : Type) (R : A -> A -> Prop) (R' : B -> B -> Prop)
        (f g : A -> B) =>
      forall x y : A, R x y -> R' (f x) (g y).

  Definition pointwise_relation :=
    fun (A B : Type) (R : B -> B -> Prop) (f g : A -> B) =>
      forall a : A, R (f a) (g a).

  Definition flip (A : Type) (R : A -> A -> Prop) : A -> A -> Prop :=
    fun x y => R y x.

  Fixpoint RD (r : R) (t : typ) : option (typD t -> typD t -> Prop) :=
    match r with
      | Rinj r => RbaseD r t
      | Rrespects l r =>
        typ2_match (F:=RFun) (fun T => option (T -> T -> Prop)) t
                   (fun lt rt =>
                      match RD l lt , RD r rt with
                        | Some l , Some r => Some (respectful l r)
                        | _ , _ => None
                      end)
                   None
      | Rpointwise _t r =>
        typ2_match (F:=RFun) (fun T => option (T -> T -> Prop)) t
                   (fun lt rt =>
                      match type_cast lt _t with
                        | Some _ =>
                          match RD r rt with
                            | Some r => Some (pointwise_relation (A:=typD lt) r)
                            | _ => None
                          end
                        | None => None
                      end)
                   None
      | Rflip r =>
        match RD r t with
        | Some rD => Some (flip rD)
        | None => None
        end
    end.

  Theorem RD_single_type
  : forall r t1 t2 rD1 rD2,
      RD r t1 = Some rD1 ->
      RD r t2 = Some rD2 ->
      t1 = t2.
  Proof using tyArr RbaseD_single_type Typ2Ok_Fun.
    induction r; simpl; intros.
    { eapply RbaseD_single_type; eauto. }
    { destruct (typ2_match_case t2) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
        rewrite H1 in *; [ clear H1 | congruence ].
      destruct (typ2_match_case t1) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
        rewrite H1 in *; [ clear H1 | congruence ].
      revert H; revert H0.
      red in x4; red in x1; subst.
      simpl.
      autorewrite_with_eq_rw.
      intros; forwardy; inv_all; subst.
      f_equal; eauto. }
    { destruct (typ2_match_case t2) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
        rewrite H1 in *; [ clear H1 | congruence ].
      destruct (typ2_match_case t1) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
        rewrite H1 in *; [ clear H1 | congruence ].
      revert H; revert H0.
      red in x4; red in x1; subst.
      simpl.
      autorewrite_with_eq_rw.
      intros; forwardy; inv_all; subst.
      red in y0, y3; subst.
      f_equal; eauto. }
    { forwardy.
      inv_all. subst. eauto. }
  Qed.

  (** Patterns *)
  Definition ptrnRinj {T : Type} (p : ptrn Rbase T) : ptrn R T :=
    fun r _T good bad =>
      match r with
      | Rinj a => p a _T good (fun x => bad (Rinj x))
      | Rrespects a b => bad (Rrespects a b)
      | Rpointwise a b => bad (Rpointwise a b)
      | Rflip a => bad (Rflip a)
      end.

  Global Instance ptrn_ok_ptrnRinj {T} p : ptrn_ok p -> ptrn_ok (@ptrnRinj T p).
  Proof using.
    unfold ptrnRinj; red; intros.
    destruct x; simpl; try solve [ right; red; eauto ].
    destruct (H r).
    { left; destruct H0. exists x. red. eauto. }
    { right. red. red in H0. intros.
      setoid_rewrite H0. reflexivity. }
  Qed.

  Theorem Succeeds_ptrnRinj {T} p x res
  : ptrn_ok p ->
    Succeeds x (@ptrnRinj T p) res ->
    exists y, Succeeds y p res /\ x = Rinj y.
  Proof using.
    destruct x; unfold Succeeds; simpl; intros;
    try solve [ ptrn_contradict ].
    eexists; split; eauto.
    intros.
    destruct (H r) as [ [ ? ? ] | ? ].
    { red in H1. setoid_rewrite H1 in H0. setoid_rewrite H1. eauto. }
    { red in H1. setoid_rewrite H1 in H0.
      ptrn_contradict. }
  Qed.

  Global Instance SucceedsE_ptrnRinj {T} p x res
  : ptrn_ok p -> SucceedsE x (@ptrnRinj T p) res :=
  { s_result := exists y, Succeeds y p res /\ x = Rinj y }.
  intros.  eauto using Succeeds_ptrnRinj.
  Defined.

  Definition ptrnRflip {T : Type} (p : ptrn R T)
  : ptrn R T :=
    fun r _T good bad =>
      match r with
      | Rinj a => bad (Rinj a)
      | Rrespects a b => bad (Rrespects a b)
      | Rpointwise a b => bad (Rpointwise a b)
      | Rflip a => p a _T good (fun x => bad (Rflip x))
      end.

  Global Instance ptrn_ok_ptrnRflip {T} p : ptrn_ok p -> ptrn_ok (@ptrnRflip T p).
  Proof using.
    unfold ptrnRflip; red; intros.
    destruct x; simpl; try solve [ right; red; eauto ].
    destruct (H x).
    { left; destruct H0. exists x0. red. eauto. }
    { right. red. red in H0. intros.
      setoid_rewrite H0. reflexivity. }
  Qed.

  Theorem Succeeds_ptrnRflip {T} p x res
  : ptrn_ok p ->
    Succeeds x (@ptrnRflip T p) res ->
    exists y, Succeeds y p res /\ x = Rflip y.
  Proof using.
    destruct x; unfold Succeeds; simpl; intros;
    try solve [ ptrn_contradict ].
    eexists; split; eauto.
    intros.
    destruct (H x) as [ [ ? ? ] | ? ].
    { red in H1. setoid_rewrite H1 in H0. setoid_rewrite H1. eauto. }
    { red in H1. setoid_rewrite H1 in H0.
      ptrn_contradict. }
  Qed.

  Global Instance SucceedsE_ptrnRflip {T} p x res
  : ptrn_ok p -> SucceedsE x (@ptrnRflip T p) res :=
  { s_result := exists y, Succeeds y p res /\ x = Rflip y }.
  intros.  eauto using Succeeds_ptrnRflip.
  Defined.

  Definition ptrnRrespectsL {T U : Type}
             (pd : ptrn R (T -> U))
             (pr : ptrn R T)
  : ptrn R U :=
    fun r _T good bad =>
      match r with
      | Rinj a => bad (Rinj a)
      | Rrespects a b => pr b _T (fun x => pd a _T (fun y => good (y x))
                                              (fun a => bad (Rrespects a b)))
                            (fun b => bad (Rrespects a b))
      | Rpointwise a b => bad (Rpointwise a b)
      | Rflip a => bad (Rflip a)
      end.

  Global Instance ptrn_ok_ptrnRrespectsL {T U} pl pr
  : ptrn_ok pl -> ptrn_ok pr -> ptrn_ok (@ptrnRrespectsL T U pl pr).
  Proof using.
    unfold ptrnRrespectsL; red; intros.
    destruct x; simpl; try solve [ right; red; eauto ].
    destruct (H x1); destruct (H0 x2).
    { forward_reason. left.
      unfold Succeeds in *. exists (x0 x). intros.
      setoid_rewrite H2. setoid_rewrite H1. reflexivity. }
    { right. red. red in H2.
      setoid_rewrite H2. eauto. }
    { right. destruct H2. red in H1, H2.
      red. setoid_rewrite H2. setoid_rewrite H1. eauto. }
    { right. red in H1, H2.
      red. setoid_rewrite H2. eauto. }
  Qed.

  Theorem Succeeds_ptrnRrespectsL {T U} pl pr x res
  : ptrn_ok pl -> ptrn_ok pr ->
    Succeeds x (@ptrnRrespectsL T U pl pr) res ->
    exists y z resL resR, Succeeds y pl resL /\ Succeeds z pr resR /\
                          x = Rrespects y z /\ res = resL resR.
  Proof using.
    destruct x; unfold Succeeds; simpl; intros;
    try solve [ ptrn_contradict ].
    exists x1; exists x2.
    destruct (H0 x2).
    { destruct H2; red in H2. setoid_rewrite H2 in H1.
      destruct (H x1).
      { destruct H3; red in H3; setoid_rewrite H3 in H1.
        do 2 eexists. split; eauto. split; eauto.
        split; eauto.
        specialize (H1 _ (fun x => x) (fun _ => res)).
        symmetry; assumption. }
      { red in H3. setoid_rewrite H3 in H1.
        ptrn_contradict. } }
    { red in H2. setoid_rewrite H2 in H1. ptrn_contradict. }
  Qed.

  Global Instance SucceedsE_ptrnRrespectsL {T U} pl pr x res
  : ptrn_ok pl -> ptrn_ok pr -> SucceedsE x (@ptrnRrespectsL T U pl pr) res :=
  { s_result := exists y z resL resR, Succeeds y pl resL /\ Succeeds z pr resR /\
                          x = Rrespects y z /\ res = resL resR }.
  intros.  eauto using Succeeds_ptrnRrespectsL.
  Defined.

  Definition ptrnRpointwiseL {T U : Type}
             (pd : ptrn typ (T -> U))
             (pr : ptrn R T)
  : ptrn R U :=
    fun r _T good bad =>
      match r with
      | Rinj a => bad (Rinj a)
      | Rpointwise a b => pr b _T (fun x => pd a _T (fun y => good (y x))
                                              (fun a => bad (Rpointwise a b)))
                            (fun b => bad (Rpointwise a b))
      | Rrespects a b => bad (Rrespects a b)
      | Rflip a => bad (Rflip a)
      end.

  Global Instance ptrn_ok_ptrnRpointwiseL {T U} pl pr
  : ptrn_ok pl -> ptrn_ok pr -> ptrn_ok (@ptrnRpointwiseL T U pl pr).
  Proof using.
    unfold ptrnRpointwiseL; red; intros.
    destruct x; simpl; try solve [ right; red; eauto ].
    destruct (H t); destruct (H0 x).
    { forward_reason. left.
      unfold Succeeds in *. setoid_rewrite H2.
      setoid_rewrite H1. eauto. }
    { right. red. red in H2.
      setoid_rewrite H2. eauto. }
    { right. destruct H2. red in H1, H2.
      red. setoid_rewrite H2. setoid_rewrite H1. eauto. }
    { right. red in H1, H2.
      red. setoid_rewrite H2. eauto. }
  Qed.

  Theorem Succeeds_ptrnRpointwiseL {T U} pl pr x res
  : ptrn_ok pl -> ptrn_ok pr ->
    Succeeds x (@ptrnRpointwiseL T U pl pr) res ->
    exists y z resL resR, Succeeds y pl resL /\ Succeeds z pr resR /\
                          x = Rpointwise y z /\ res = resL resR.
  Proof using.
    destruct x; unfold Succeeds; simpl; intros;
    try solve [ ptrn_contradict ].
    exists t; exists x.
    destruct (H0 x).
    { destruct H2; red in H2. setoid_rewrite H2 in H1.
      destruct (H t).
      { destruct H3; red in H3; setoid_rewrite H3 in H1.
        do 2 eexists. split; eauto. split; eauto.
        split; eauto.
        specialize (H1 _ (fun x => x) (fun _ => res)).
        symmetry; assumption. }
      { red in H3. setoid_rewrite H3 in H1.
        ptrn_contradict. } }
    { red in H2. setoid_rewrite H2 in H1. ptrn_contradict. }
  Qed.

  Global Instance SucceedsE_ptrnRpointwiseL {T U} pl pr x res
  : ptrn_ok pl -> ptrn_ok pr -> SucceedsE x (@ptrnRpointwiseL T U pl pr) res :=
  { s_result := exists y z resL resR, Succeeds y pl resL /\ Succeeds z pr resR /\
                          x = Rpointwise y z /\ res = resL resR }.
  intros.  eauto using Succeeds_ptrnRpointwiseL.
  Defined.

  Section refl_trans_types.
    Context {T} (RD : T -> forall t : typ, option (typD t -> typD t -> Prop)).

    Definition refl_dec : Type := T -> bool.
    Definition trans_dec : Type := T -> bool.
    Definition refl_dec_ok (rd : refl_dec) : Prop :=
      forall r t rD, rd r = true -> RD r t = Some rD -> Reflexive rD.
    Definition trans_dec_ok (rd : trans_dec) : Prop :=
      forall r t rD, rd r = true -> RD r t = Some rD -> Transitive rD.
  End refl_trans_types.

  Arguments refl_dec _ : clear implicits.
  Arguments trans_dec _ : clear implicits.

  (** Reflexivity and transitivity *)
  Section is_refl.
    Lemma Refl_pointwise : forall {T U : Type} (R : T -> T -> Prop),
      Reflexive R -> Reflexive (pointwise_relation (A:=U) R).
    Proof using.
      compute. auto.
    Qed.

    Variable is_refl : refl_dec Rbase.
    Definition is_reflR : refl_dec R :=
      fix is_reflR (r : R) : bool :=
        match r with
        | Rinj r => is_refl r
        | Rpointwise _ x => is_reflR x
        | Rflip r => is_reflR r
        | _ => false
        end.

    Hypothesis is_reflOk : refl_dec_ok RbaseD is_refl.

    Theorem is_reflROk : refl_dec_ok RD is_reflR.
    Proof using Typ2Ok_Fun is_reflOk.
      red.
      induction r; simpl; intros; eauto; try congruence.
      { simpl. intros.
        destruct (typ2_match_case t0) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
          rewrite H1 in *; [ clear H1 | congruence ].
        revert H0.
        red in x1; subst; simpl.
        autorewrite_with_eq_rw.
        intros. forwardy; inv_all; subst.
        eapply IHr in H; [ | eassumption ].
        red.
        intro. autorewrite_with_eq_rw.
        eapply Refl_pointwise. eassumption. }
      { forwardy; inv_all; subst.
        red. intros. unfold flip. eapply IHr; eauto. }
    Qed.
  End is_refl.

  Section is_trans.
    Lemma Trans_pointwise : forall {T U : Type} (R : T -> T -> Prop),
        Transitive R -> Transitive (pointwise_relation (A:=U) R).
    Proof using.
      compute. eauto.
    Qed.

    Variable is_trans : trans_dec Rbase.
    Definition is_transR : trans_dec R :=
      fix is_transR (r : R) : bool :=
        match r with
        | Rinj r => is_trans r
        | Rpointwise _ x => is_transR x
        | Rflip r => is_transR r
        | _ => false
        end.

    Hypothesis is_transOk : trans_dec_ok RbaseD is_trans.

    Theorem is_transROk : trans_dec_ok RD is_transR.
    Proof using Typ2Ok_Fun is_transOk.
      red.
      induction r; simpl; intros; eauto; try congruence.
      { simpl. intros.
        destruct (typ2_match_case t0) as [ [ ? [ ? [ ? H1 ] ] ] | H1 ];
          rewrite H1 in *; [ clear H1 | congruence ].
        revert H0.
        red in x1; subst; simpl.
        autorewrite_with_eq_rw.
        intros. forwardy; inv_all; subst.
        eapply IHr in H; [ | eassumption ].
        red.
        do 3 intro. autorewrite_with_eq_rw.
        eapply Trans_pointwise. eassumption. }
      { forwardy; inv_all; subst.
        red. intros. unfold flip. eapply IHr; eauto. }
    Qed.
  End is_trans.

  (** Rewriting Lemmas **)
  Section lemmas.
    (** Note: This could be parameterized by the type of expressions
     **)
    Existing Instance Expr_expr.

    Record rw_concl : Type :=
    { lhs : expr typ func
    ; rel : R
    ; rhs : expr typ func }.

    Definition rw_lemma : Set :=
      Lemma.lemma typ (expr typ func) rw_concl.

    Definition rw_conclD (tus tvs : tenv typ) (c : rw_concl)
    : option (exprT tus tvs Prop) :=
      match typeof_expr tus tvs c.(lhs) with
      | None => None
      | Some t =>
        match lambda_exprD tus tvs t c.(lhs)
            , lambda_exprD tus tvs t c.(rhs)
            , RD c.(rel) t
        with
        | Some lhs , Some rhs , Some rel =>
          Some (fun us vs => rel (lhs us vs) (rhs us vs))
        | _ , _ , _ => None
        end
      end.

    Lemma rw_concl_weaken
    : forall (tus tvs : tenv typ) (l : rw_concl) (lD : exprT tus tvs Prop),
        rw_conclD tus tvs l = Some lD ->
        forall tus' tvs' : list typ,
        exists lD' : exprT (tus ++ tus') (tvs ++ tvs') Prop,
          rw_conclD (tus ++ tus') (tvs ++ tvs') l = Some lD' /\
          (forall (us : hlist typD tus) (us' : hlist typD tus')
                  (vs : hlist typD tvs) (vs' : hlist typD tvs'),
              lD us vs <-> lD' (hlist_app us us') (hlist_app vs vs')).
    Proof.
      unfold rw_conclD. simpl. intros.
      forwardy. inv_all. subst.
      erewrite ExprFacts.typeof_expr_weaken by eauto.
      eapply ExprFacts.lambda_exprD_weaken in H0; eauto.
      destruct H0 as [ ? [ Hx ? ] ]; rewrite Hx; clear Hx.
      eapply ExprFacts.lambda_exprD_weaken in H1; eauto.
      destruct H1 as [ ? [ Hx ? ] ]; rewrite Hx; clear Hx.
      rewrite H2. eexists; split; eauto.
      intros. simpl. rewrite <- H0. rewrite <- H1. reflexivity.
    Qed.

    Definition flip_rw_concl (a : rw_concl) : rw_concl :=
    {| lhs := a.(rhs)
     ; rel := Rflip' a.(rel)
     ; rhs := a.(lhs)
     |}.

    Definition flip_rw_lemma (lem : rw_lemma) : rw_lemma :=
    {| vars := lem.(vars)
     ; premises := lem.(premises)
     ; concl := flip_rw_concl lem.(concl) |}.

    Lemma RD_Rflip'_Rflip : forall a b,
        RD (Rflip' a) b = RD (Rflip a) b.
    Proof.
      destruct a; simpl; eauto.
      intros. destruct (RD a b); reflexivity.
    Qed.

    Theorem flip_rw_lemma_sound
    : forall (lem : rw_lemma),
        lemmaD rw_conclD nil nil lem ->
        lemmaD rw_conclD nil nil (flip_rw_lemma lem).
    Proof using RTypeOk_typD Typ2Ok_Fun RSymOk_func.
      unfold lemmaD, lemmaD'. simpl.
      intros. forwardy.
      Cases.rewrite_all_goal.
      destruct (concl lem); simpl in *.
      unfold flip_rw_concl. simpl.
      unfold rw_conclD in *. simpl in *.
      forwardy.
      erewrite lambda_exprD_typeof_Some; eauto.
      Cases.rewrite_all_goal.
      rewrite RD_Rflip'_Rflip.
      simpl.
      Cases.rewrite_all_goal.
      inv_all.
      subst. unfold flip. eauto.
    Qed.

  End lemmas.

End setoid.

Arguments rw_concl typ func Rbase : rename, clear implicits.
Arguments rw_lemma typ func Rbase : rename, clear implicits.
Arguments R typ Rbase : rename, clear implicits.
Arguments Rrespects {_ _} _ _.
Arguments Rpointwise {_ _} _ _.
Arguments Rflip {_ _} _.
Arguments Rinj {_ _} _.
Arguments refl_dec _ : clear implicits.
Arguments trans_dec _ : clear implicits.

Require Import MirrorCore.Reify.ReifyClass.

Section reify_R.
  Variables Ty Rbase : Set.
  Context {Reify_Ty : Reify Ty}.
  Context {Reify_Rbase : Reify Rbase}.

(*
  Local Notation "x @ y" := (@RApp x y) (only parsing, at level 30).
  Local Notation "'!!' x" := (@RExact _ x) (only parsing, at level 25).
  Local Notation "'?' n" := (@RGet n RIgnore) (only parsing, at level 25).
  Local Notation "'?!' n" := (@RGet n RConst) (only parsing, at level 25).
  Local Notation "'#'" := RIgnore (only parsing, at level 0).
*)

  Set Printing Universes.

  Definition reify_R : Command (R Ty Rbase) :=
    CFix
      (CFirst (   CPattern (ls:=_::_::nil)
                           (RApp (RApp (RApp (RApp (RExact (@Morphisms.respectful)) RIgnore) RIgnore) (RGet 0 RIgnore)) (RGet 1 RIgnore))
                           (fun a b : function (CRec 0) => Rrespects (typ:=Ty) (Rbase:=Rbase) a b)
               :: CPattern (ls:=_::_::nil)
                           (RApp (RApp (RApp (RExact (@Morphisms.pointwise_relation)) (RGet 0 RIgnore)) RIgnore) (RGet 1 RIgnore))
                           (fun (a : function@{Set} (CCall (reify_scheme Ty))) (b : function (CRec 0)) =>
                              Rpointwise a b)
               :: CPattern (ls:=_::nil)
                           (RApp (RApp (RApp (RApp (RExact (@Basics.flip)) RIgnore) RIgnore) RIgnore) (RGet 0 RIgnore))
                           (fun a : function (CRec 0) => Rflip a)
               :: CMap (@Rinj Ty _) (reify_scheme Rbase)
               :: nil)).

  Global Instance Reify_R : Reify (R Ty Rbase) :=
  { reify_scheme := CCall reify_R }.
End reify_R.

Section Reify_Proper_concl.
  Variables Ty func Rbase : Set.
  Context {Reify_Ty : Reify Ty}.
  Context {Reify_expr_typ_func : Reify (expr Ty func)}.
  Context {Reify_Rbase : Reify Rbase}.

  Local Notation "x @ y" := (@RApp x y) (only parsing, at level 30).
  Local Notation "'!!' x" := (@RExact _ x) (only parsing, at level 25).
  Local Notation "'?' n" := (@RGet n RIgnore) (only parsing, at level 25).
  Local Notation "'?!' n" := (@RGet n RConst) (only parsing, at level 25).
  Local Notation "'#'" := RIgnore (only parsing, at level 0).

  Definition reify_rw_concl :=
    CPattern (ls:=_::_::_::nil)
             (?0 @ ?1 @ ?2)
             (fun (a : function (reify_scheme (R Ty Rbase))) (b c : function (CCall (reify_scheme (expr Ty func)))) =>
                @Build_rw_concl Ty func Rbase b a c).

  Global Instance Reify_rw_concl : Reify (rw_concl Ty func Rbase) :=
  { reify_scheme := CCall reify_rw_concl }.

End Reify_Proper_concl.


(** * Kernels defined in terms of limits *)
(** ** Contents
- Definition coincides with the direct definition
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Categories.

Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.limits.graphs.zero.
Require Import UniMath.CategoryTheory.limits.graphs.equalizers.
Require Import UniMath.CategoryTheory.limits.kernels.

(** * Definition of kernels in terms of limits *)
Section def_kernels.

  Variable C : category.
  Let hs: has_homsets C := homset_property C.
  Variable Z : Zero C.

  Definition Kernel {a b : C} (f : C⟦a, b⟧) := Equalizer C f (ZeroArrow Z a b).

  (** ** Maps between Kernels as limits and direct definition. *)
  Lemma equiv_Kernel1_eq {a b : C} (f : C⟦a, b⟧) (K : limits.kernels.Kernel (equiv_Zero2 Z) f) :
    KernelArrow K · f = KernelArrow K · ZeroArrow Z a b.
  Proof.
    rewrite precomp_with_ZeroArrow. rewrite <- equiv_ZeroArrow. apply KernelCompZero.
  Qed.

  Lemma equiv_Kernel1_isEqualizer {a b : C} (f : C⟦a, b⟧)
        (K : limits.kernels.Kernel (equiv_Zero2 Z) f) :
    isEqualizer C f (ZeroArrow Z a b) K (KernelArrow K) (equiv_Kernel1_eq f K).
  Proof.
    use (make_isEqualizer _ ).
    intros e h' H'.
    use unique_exists.
    (* Construction of the morphism *)
    - use KernelIn.
      + exact h'.
      + rewrite precomp_with_ZeroArrow in H'.
        use (pathscomp0 _ (!(equiv_ZeroArrow e b Z))).
        exact H'.
    (* Commutativity *)
    - cbn. use KernelCommutes.
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y X. cbn in X.
      use limits.kernels.KernelInsEq. unfold KernelArrow.
      use (pathscomp0 X). apply pathsinv0.
      use limits.kernels.KernelCommutes.
  Qed.

  Definition equiv_Kernel1 {a b : C} (f : C⟦a, b⟧) (K : limits.kernels.Kernel (equiv_Zero2 Z) f) :
    Kernel f.
  Proof.
    use make_Equalizer.
    - exact K.
    - exact (KernelArrow K).
    - exact (equiv_Kernel1_eq f K).
    - exact (equiv_Kernel1_isEqualizer f K).
  Defined.

  (* Other direction *)

  Lemma equiv_Kernel2_eq {a b : C} (f : C⟦a, b⟧) (K : Kernel f) :
    EqualizerArrow C K · f = limits.zero.ZeroArrow (equiv_Zero2 Z) (EqualizerObject C K) b.
  Proof.
    rewrite (EqualizerArrowEq C K). rewrite equiv_ZeroArrow.
    rewrite precomp_with_ZeroArrow. apply idpath.
  Qed.

  Lemma equiv_Kernel2_isEqualizer {a b : C} (f : C⟦a, b⟧) (K : Kernel f) :
    isKernel (equiv_Zero2 Z) (EqualizerArrow C K) f (equiv_Kernel2_eq f K).
  Proof.
    use (make_isKernel).
    intros w h H.
    use unique_exists.
    (* Construction of the morphism *)
    - use EqualizerIn.
      + exact h.
      + rewrite H.
        rewrite precomp_with_ZeroArrow.
        apply equiv_ZeroArrow.
    (* Commutativity *)
    - use EqualizerArrowComm.
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y T. cbn in T.
      use EqualizerInUnique. exact T.
  Qed.

  Definition equiv_Kernel2 {a b : C} (f : C⟦a, b⟧) (K : Kernel f) :
    limits.kernels.Kernel (equiv_Zero2 Z) f.
  Proof.
    use make_Kernel.
    - exact (EqualizerObject C K).
    - exact (EqualizerArrow C K).
    - exact (equiv_Kernel2_eq f K).
    - exact (equiv_Kernel2_isEqualizer f K).
  Defined.

End def_kernels.


Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Sets.Ensembles
        Coq.Arith.Arith
        Fiat.Computation.Core
        Fiat.ADT.ADTSig
        Fiat.ADT.Core
        Fiat.Common.ilist
        Fiat.Common.StringBound
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.ADTNotation.BuildADT
        Fiat.ADTNotation.BuildADTSig
        Fiat.QueryStructure.Specification.Representation.QueryStructureSchema
        Fiat.QueryStructure.Specification.Representation.QueryStructure
        Fiat.QueryStructure.Specification.Operations.Mutate.

(* Definitions for updating query structures. *)

(* This update is fairly constrained:
   If the update is consistent with the constraints, it is
   applied to the table,
   OTHERWISE
   No tables are changed. *)
Definition QSUpdate
           qs_schema
           (qs : QueryStructure qs_schema)
           (Ridx : _)
           (UpdatedTuples : @Ensemble (@RawTuple (GetNRelSchemaHeading _ Ridx)))
           (UpdateFunction : Relation_Definitions.relation (@RawTuple (GetNRelSchemaHeading _ Ridx)))
: Comp (QueryStructure qs_schema * list RawTuple) :=
  QSMutate qs Ridx (IndexedEnsembleUpdate (GetRelation qs Ridx) UpdatedTuples UpdateFunction).

Notation "'Update' b 'from' r '!' Ridx 'as' c 'making' Trans 'where' Ens" :=
  (let qs_schema := _ in
   let r' : QueryStructure qs_schema := r in
   let Ridx' := ibound (indexb (@Build_BoundedIndex _ _ (QSschemaNames qs_schema) Ridx%string _)) in
   (QSUpdate r' Ridx'
            (fun b => Ens) (fun b c => Trans)))
    (r at level 0, Ridx at level 0, Ens at level 0, Trans at level 0, at level 80).


(*
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.SublistT.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.QuantifierLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Normal.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.

Local Open Scope logic_base.
Local Open Scope syntax.

Class BindedProofTheory (BL: BinderLanguage): Type := {
  binded_Gamma:> forall ts, ProofTheory (binded_L ts)
}.

Class QuantifierLogic
      (BL: BinderLanguage)
      {nL: forall ts, NormalLanguage (binded_L ts)}
      {qL: QuantifierLanguage BL}
      (BGamma: BindedProofTheory BL)
      {nGamma: forall ts, NormalProofTheory (binded_L ts) (binded_Gamma ts)}
      {mpGamma: forall ts, MinimumPropositionalLogic (binded_L ts) (binded_Gamma ts)} :=
{
  allp_elim: forall (t: type) (ts: list type) (x: binded_expr (t :: ts)) (e: binded_term ts t),
    |-- allp x --> ins_expr x e;
  allp_gen: forall (t: type) (ts: list type) (x: binded_expr ts) (y: binded_expr (t :: ts)),
    |-- lift_expr (sublistT_cons t (sublistT_refl ts)) x --> y ->
    |-- x --> allp y;
  exp_intros: forall (t: type) (ts: list type) (x: binded_expr (t :: ts)) (e: binded_term ts t),
    |-- ins_expr x e --> exp x;
  exp_gen: forall (t: type) (ts: list type) (x: binded_expr (t :: ts)) (y: binded_expr ts),
    |-- x --> lift_expr (sublistT_cons t (sublistT_refl ts)) y ->
    |-- exp x --> y
}.

*)


Set Warnings "-parsing".
From mathcomp Require Import all_ssreflect.
Require Import Real Reals RealCoqReal.
Set Warnings "parsing".
Require Import Psatz.

Section RealHelpers.

  Generalizable Variables K M Real.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real : Type}
          {SemiDecOrderedField_Real : SemiDecOrderedField Real}
          {ComplArchiSemiDecOrderedField_Real : ComplArchiSemiDecOrderedField}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (realTheory ) (constants [IZReal_tac]).

  Lemma IZreal_relator z : relate (IZreal z) (IZR z).
  Proof.
    suff H : forall z', (0 <= z')%Z -> @relate Real  (@IZreal K klb Real SemiDecOrderedField_Real  z') (IZR z').
    - case z => [| p |p]; try by apply H;lia.
      rewrite IZreal_neg IZR_NEG.
      apply relate_subtraction.
        by apply H.
        apply Z_of_nat_prop.
        elim => [| n' IH]; first by rewrite Nat2Z.inj_0;apply relate_constant0.
        rewrite Nat2Z.inj_succ.
        have -> : (Z.succ (Z.of_nat n')) = ((Z.of_nat n') +1)%Z by lia.
        rewrite IZreal_hom plus_IZR.
        apply relate_addition =>//.
        suff -> : (@IZreal _ _ _ SemiDecOrderedField_Real 1) = (@real_1 _ _ _ SemiDecOrderedField_Real) by apply relate_constant1.
        intros.
        simpl; auto.
  Qed.

  Lemma relate_IZreal z x : relate (IZreal z) x -> x = (IZR z).
  Proof.
    suff H: relate (@IZreal _ _ _ SemiDecOrderedField_Real z) (IZR z).
    - move => R.
        by relate.
          by apply IZreal_relator.
  Qed.

  Lemma relate_prec n : relate (prec n) (/ 2 ^ n)%R.
  Proof.
    elim n =>  [ /=  | n' IH ]; first by rewrite Rinv_1; apply relate_constant1.
    have -> : (prec n'.+1) = (prec n') * (prec 1).
    - have -> : n'.+1 = (n'+1)%coq_nat by lia.
        apply (prec_hom n' 1).
        have -> : (prec 1) = (real_1 / real_2_neq_0) by [].
        rewrite  /= Rinv_mult_distr; [| by lra| by apply pow_nonzero].
        rewrite Rmult_comm.
        apply relate_multiplication => //.
        rewrite /real_div.
        have -> : (/ 2 = 1 *  /2)%R by lra.
        apply relate_multiplication; first by apply relate_constant1.
        apply (relate_divison real_2 real_2_neq_0 2).
          by apply IZreal_relator.
  Qed.

(* Ltac classical := *)
(*   match goal with *)
(*   | |- eq ?x ?y => apply transport_eq;   intro; intro; intro; intro; classical (* (fail "not implemented yet") *) *)
(*   | |- ?x < ?y => apply transport_lt; intro; intro; intro; intro; classical *)
(*   | |- ?x > ?y => apply transport_lt; intro; intro; intro; intro; classical *)
(*   | |- ?x >= ?y => apply transport_geq; intro; intro; intro; intro; classical *)
(*   | |- ?x <= ?y => apply transport_leq; intro; intro; intro; intro; classical *)
(*   | |- ?x <> ?y => apply transport_neq; intro; intro; intro; intro; classical      *)
(*   (* | |- exists x : Real, ?A => apply transport_exists;  intro; intro; intro; classical *) *)
(*   | |- forall x , ?A => apply (transport_forall (fun x => A));   intro; intro; intro; classical *)
(*   (* | |- forall x : Real, ?A => apply (transport_forall (fun x => A));   intro; intro; intro; classical *) *)

(*   | |- ?A => apply skip *)
(*                    (* | |- ?A => match A with *) *)
(*                    (*          | ?a = ?b => fail "haha" *) *)
(*                    (*          | _ => fail "FAIL" A *) *)
(*                    (*          end  *) *)

(*   end. *)

  Lemma IZreal4neq0 : IZreal 4 <> real_0.
  Proof.
    apply transport_neq.
    intro.
    intro.
    intro.
    intro.
    relate.
    rewrite (relate_IZreal _ _ H).
      by lra.

    (* classical. *)
    (* relate. *)
    (* rewrite (relate_IZreal _ _ H). *)
    (*   by lra. *)
  Qed.

  (* results about (/ 2 ^ n) adapted  from incone *)
  Lemma tpmn_lt n: (0 < /2^n)%R.
  Proof. apply/Rinv_0_lt_compat/pow_lt; lra. Qed.

  Lemma pwr2gtz m: exists n, (2^n > m)%nat.
  Proof.
    elim: m => [ | m [n /leP ih]]; first by exists 0%nat; apply /leP => /=; lia.
                                                     by exists n.+1; apply /leP => /=; lia.
  Qed.

  Lemma dns0_tpmn: forall eps, (0 < eps)%R -> exists n, (/2^n < eps)%R.
  Proof.
    move => eps epsprp.
    pose z := Z.to_nat (up (/eps)).
    have [n /leP nprp]:= pwr2gtz z; have g0: (0 < 2^n)%R by apply pow_lt; lra.
    exists n.
    rewrite -[eps]Rinv_involutive; try lra.
    apply Rinv_lt_contravar; first by rewrite Rmult_comm; apply Rdiv_lt_0_compat;  try lra.
    have ->: (2 = INR 2)%R by trivial.
    rewrite -pow_INR.
    apply /Rlt_le_trans/(le_INR _ _ nprp).
    suff : (INR z.+1 > (/ eps))%R by lra.
    apply /Rgt_trans/(archimed (/ eps)).1.
    rewrite S_INR.
    rewrite INR_IZR_INZ.
    unfold z.
    rewrite Z2Nat.id; first by lra.
    apply le_IZR.
    have epsprp' : (0 < / eps)%R by apply Rinv_0_lt_compat.
    suff: ((IZR (up (/ eps))) > (/ eps))%R by lra.
      by apply archimed.
  Qed.

End RealHelpers.


Require Import Undecidability.CFG.CFP.

From Undecidability.CFG.Reductions Require
  PCP_to_CFPP PCP_to_CFPI.

Require Import Undecidability.Synthetic.Undecidability.

Require Undecidability.PCP.PCP_undec.

(* The Context-free Post Grammar Palindrome Problem is undecidable. *)
Lemma CFPP_undec : undecidable CFPP.
Proof.
  eapply undecidability_from_reducibility.
  exact PCP_undec.PCP_undec.
  exact PCP_to_CFPP.reduction.
Qed.

(* The Context-free Post Grammar Intersection Problem is undecidable. *)
Lemma CFPI_undec : undecidable CFPI.
Proof.
  eapply undecidability_from_reducibility.
  exact PCP_undec.PCP_undec.
  exact PCP_to_CFPI.reduction.
Qed.


(** Coq coding by choukh, July 2022 **)

Require Import ConstructiveEpsilon Setoid.
Require Import Notions Equivalence NatLargeElim.
Require Nat NatEmbed.

Reserved Notation "x ?= a" (at level 70).
Reserved Notation "x @ n" (at level 50).
Reserved Notation "x >>= f" (at level 50).
Reserved Notation "A ⇀ B" (at level 10).

Class 偏函数模型 := {
  偏 : Type → Type where "A ⇀ B" := (A → 偏 B);

  解包关系 {A} : 偏 A → A → Prop where "x ?= a" := (解包关系 x a);
  解包关系单射 {A} : ∀ (x : 偏 A) a b, x ?= a → x ?= b → a = b;

  求值 {A} : 偏 A → ℕ → A? where "x @ n" := (求值 x n);
  求值安定 {A} : ∀ x, 安定 (@求值 A x);
  求值规则 {A} : ∀ (x : 偏 A) a, x ?= a ↔ ∃ n, x @ n = Some a;

  偏μ : (ℕ ⇀ bool) ⇀ ℕ;
  偏μ规则 : ∀ (f : ℕ ⇀ bool) n, 偏μ f ?= n ↔ (f n ?= true ∧ ∀ m, m < n → f m ?= false);

  (* return *)
  有 {A} : A ⇀ A;
  有规则 {A} : ∀ (a : A), 有 a ?= a;

  (* undefined *)
  无 {A} : 偏 A;
  无规则 {A} : ∀ (a : A), ¬ 无 ?= a;

  (* bind *)
  绑定 {A B} : 偏 A → (A ⇀ B) ⇀ B where "x >>= f" := (绑定 x f);
  绑定规则 {A B} : ∀ (x : 偏 A) (f : A ⇀ B) y,
    x >>= f ?= y ↔ ∃ a, x ?= a ∧ f a ?= y;
}.

Notation "x ?= a" := (解包关系 x a) (at level 70).
Notation "x @ n" := (求值 x n) (at level 50).
Notation "x >>= f" := (绑定 x f) (at level 50).
Notation "A ⇀ B" := (A → 偏 B) (at level 10).

Section 给定偏函数模型.
Context {M : 偏函数模型}.

Section 给定类型A.
Context {A : Type}.

Definition 偏类型等词 (x y : 偏 A) := ∀ a, x ?= a ↔ y ?= a.

Instance 偏类型等词为等价关系 : Equivalence 偏类型等词.
Proof. firstorder. Qed.

Global Instance 偏类型外延 : 等价关系 (偏 A) := {| R := 偏类型等词 |}.

Lemma 有值解包_l (a b : A) : 有 a ?= b → a = b.
Proof. intros. eapply 解包关系单射. eapply 有规则. easy. Qed.

Lemma 有值解包_r (a b : A) : a = b → 有 a ?= b.
Proof. intros ->. apply 有规则. Qed.

Lemma 有值解包 (a b : A) : 有 a ?= b ↔ a = b.
Proof. split. apply 有值解包_l. apply 有值解包_r. Qed.

Lemma 有值求值 (a b : A) n : 有 a @ n = Some b → a = b.
Proof. intros. apply 有值解包, 求值规则. now exists n. Qed.

Definition 有值 (x : 偏 A) := ∃ a, x ?= a.

Lemma 有值则可求 (x : 偏 A) : 有值 x → Σ a, x ?= a.
Proof.
  intros Hx.
  assert (H: ∃ n, x @ n ≠ None). {
    destruct Hx as [a [n xn]%求值规则]. exists n. congruence.
  }
  apply constructive_indefinite_ground_description_nat in H as [n H].
  - destruct 求值 as [a|] eqn:E.
    + exists a. apply 求值规则. firstorder.
    + congruence.
  - intros. destruct 求值; firstorder congruence.
Qed.

Definition 解包 {x : 偏 A} (H : 有值 x) : A := projT1 (有值则可求 x H).
Definition 解包规则 (x : 偏 A) (H : 有值 x) : x ?= (解包 H) := projT2 (有值则可求 x H).

End 给定类型A.

Definition μ : (ℕ → bool) ⇀ ℕ := λ f, 偏μ (λ n, 有 (f n)).

Lemma μ规则 (f : ℕ → bool) n : μ f ?= n ↔ (f n = true ∧ ∀ m, m < n → f m = false).
Proof. unfold μ. rewrite 偏μ规则. now repeat setoid_rewrite 有值解包. Qed.

Lemma μ有值 (f : ℕ → bool) n : f n = true → 有值 (μ f).
Proof.
  intros. pose proof (自然数布尔大消除 f n H) as [m min].
  exists m. now apply μ规则.
Qed.

Definition 无' {A} (a : A) := μ (λ _, false) >>= (λ _, 有 a).

Lemma 无规则' {A} (a b : A) : ¬ 无' a ?= b.
Proof.
  intros H. apply 绑定规则 in H as [n [H _]].
  apply μ规则 in H as []. discriminate.
Qed.

End 给定偏函数模型.

Module PairView.
Import Nat NatEmbed.
Section 给定偏函数模型.
Context {M : 偏函数模型}.

(* 将偏函数的点枚举为可选配对 *)
Definition F (f : ℕ ⇀ ℕ) : ℕ → (ℕ * ℕ)? :=
  λ' ⟨x, n⟩, if f x @ n is Some y then Some (x, y) else None.

(* 从可选配对的枚举恢复偏函数 *)
Definition G (g : ℕ → (ℕ * ℕ)?) : ℕ ⇀ ℕ := λ x,
  μ (λ n, if g n is Some (x', _) then x =? x' else false) >>=
  (λ n, if g n is Some (_, y) then 有 y else 无).

Definition 函数性配对 (g : ℕ → (ℕ * ℕ)?) := ∀ n m x y z,
  g n = Some (x, y) → g m = Some (x, z) → y = z.

Lemma F规则 f x y : (f x ?= y) ↔ (∃ n, F f n = Some (x, y)).
Proof.
  unfold F. split.
  - intros. apply 求值规则 in H as [n H].
    exists ⟨x, n⟩. now rewrite GF, H.
  - intros [n H]. destruct ⎞n⎛ as [x' m].
    destruct 求值 eqn:E; inv H. apply 求值规则. eauto.
Qed.

Lemma G规则 g x y : (G g x ?= y) → (∃ n, g n = Some (x, y)).
Proof.
  unfold G. intros. apply 绑定规则 in H as [n [H1 H2]].
  apply μ规则 in H1 as [H1 _].
  destruct (g n) as [[x' y']|] eqn:E.
  - apply 有值解包 in H2. subst.
    apply EqNat.beq_nat_true in H1 as ->. eauto.
  - now apply 无规则 in H2.
Qed.

Local Lemma 小消除 (g : ℕ → (ℕ * ℕ)?) x y n : g n = Some (x, y) →
  let f := (λ n, if g n is Some (x', _) then x =? x' else false) in
  ∃ m, f m = true ∧ ∀ k : ℕ, k < m → f k = false.
Proof.
  intros gn f. assert (fn: f n = true). {
    unfold f. rewrite gn. now erewrite EqNat.beq_nat_refl.
  }
  pose proof (自然数布尔大消除 f n fn) as [m [H1 H2]].
  exists m. split; auto.
Qed.

Lemma G规则_反向 g x y n : 函数性配对 g → g n = Some (x, y) → G g x ?= y.
Proof.
  intros Fun gn. apply 绑定规则.
  pose proof (小消除 g x y n gn) as [m [H1 H2]].
  destruct (g m) eqn:E. 2:discriminate. exists m. split.
  - apply μ规则. split; auto. rewrite E. apply H1.
  - rewrite E. destruct p as [x' y'].
    apply EqNat.beq_nat_true in H1 as <-.
    apply 有值解包. eapply Fun; eauto.
Qed.

Fact G有值 g x : 有值 (G g x) ↔ ∃ n y, g n = Some (x, y).
Proof.
  split.
  - intros [y H]. apply G规则 in H as [n H]. now exists n, y.
  - intros [n [y gn]].
    pose proof (小消除 g x y n gn) as [m [H1 H2]].
    destruct (g m) eqn:E. 2:discriminate.
    destruct p as [x' y']. exists y'. apply 绑定规则. exists m. split.
    + apply μ规则. split; auto. rewrite E. apply H1.
    + rewrite E. now apply 有值解包.
Qed.

End 给定偏函数模型.
End PairView.


(*
abhishek@brixpro:~/parametricity/reflective-paramcoq/test-suite$ ./coqid.sh indFunArg
*)

Require Import SquiggleEq.terms.

Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.PIWNew.

Require Import Template.Template.

Inductive IWT (I A : Set) (B : A -> Set) (AI : A -> I)
(BI : forall (a : A), B a -> I) : forall (i:I), Prop :=
iwt : forall (a : A) (lim: forall b : B a, IWT I A B AI BI (BI a b)),
     IWT I A B AI BI (AI a).

Inductive WT (A : Set) :  Prop :=
wt : forall (lim: WT A),
     WT A.

Require Import ReflParam.indProp.
Run TemplateProgram (genParamIndPropAll [] "Top.IWP.WT").
Run TemplateProgram (genParamIndPropAll [] "Top.IWP.IWT").

Print Top_IWP_WT_pmtcty_RR0_iso.

Inductive multInd2 (A I : Set) (B: I-> Set) (f: A-> I) (g: forall i, B i)
  : forall (i:I) (b:B i), Prop  :=
mlind2 : forall a
(dd:forall (aa:A), multInd2 A I B f g (f aa) (g (f aa))),
multInd2 A I B f g (f a) (g (f a))

|mlind2d : forall aaaa
(ddd:forall (aaa:A), multInd2 A I B f g (f aaa) (g (f aaa))),
multInd2 A I B f g (f aaaa) (g (f aaaa)).

Run TemplateProgram (genParamIndProp [] true "Top.IWP.multInd2").
Print Top_IWP_multInd2_pmtcty_RR0_prop.


Require Export stores.
Require Export assertions_lemmas.

Section Program.

Context `{EnvSpec K} (Γ: env K) (δ: funenv K).

Definition var_points_to i mv: assert K :=
  match mv with
    None =>
    var i ↦{false, perm_full} - : sintT%BT
  | Some z =>
    var i ↦{false, perm_full} (# intV{sintT} z) : sintT%BT
  end.

Fixpoint assert_stack (st: store): assert K :=
  match st with
    [] => emp
  | mv::st =>
    var_points_to 0 mv ★ assert_stack st ↑
  end.

Lemma assert_stack_var st i:
  i < length st ->
  assert_stack st ⊆{Γ,δ}
  ((∃p, var i ⇓ inl p ∧ emp) ★ assert_stack st)%A.
Proof.
revert i.
induction st; simpl; intros.
- lia.
- destruct i.
  + rewrite (associative (★)%A).
    apply assert_sep_preserving; [|reflexivity].
    rename a into mv.
    destruct mv.
    * simpl.
      rewrite assert_singleton_l at 1.
      apply assert_exist_elim; intro p.
      rewrite assert_exist_sep.
      apply assert_exist_intro with (x:=p).
      rewrite emp_dup at 1.
      rewrite <- (associative (★)%A).
      apply assert_sep_preserving; [reflexivity|].
      rewrite assert_singleton_l_2.
      reflexivity.
    * simpl.
      rewrite assert_singleton_l_ at 1.
      apply assert_exist_elim; intro p.
      rewrite assert_exist_sep.
      apply assert_exist_intro with (x:=p).
      rewrite emp_dup at 1.
      rewrite <- (associative (★)%A).
      apply assert_sep_preserving; [reflexivity|].
      rewrite assert_singleton_l_2_.
      reflexivity.
  + rewrite (commutative (★)%A).
    rewrite (associative (★)%A).
    apply assert_sep_preserving; [|reflexivity].
    rewrite IHst with (i:=i) at 1; [|lia].
    rewrite assert_lift_sep.
    rewrite assert_lift_exists.
    apply assert_sep_preserving; [|reflexivity].
    apply assert_exist_elim; intro p.
    apply assert_exist_intro with (x:=p).
    rewrite assert_lift_and.
    rewrite stack_indep.
    apply assert_and_intro.
    * apply assert_and_elim_l.
      rewrite <- assert_lift_eval at 1.
      reflexivity.
    * apply assert_and_elim_r; reflexivity.
Qed.

Lemma assert_stack_load st i z:
  st !! i = Some (Some z) ->
  assert_stack st ⊆{Γ,δ} (load (var i) ⇓ inr (intV{sintT} z))%A.
Proof.
revert i.
induction st.
- discriminate.
- destruct i.
  + simpl; intros.
    injection H1; clear H1; intros; subst.
    rewrite <- assert_memext_l with (P:=(load (var 0) ⇓ inr (intV{sintT} z))%A) (Q:=(assert_stack st↑)%A).
    * apply assert_sep_preserving; try reflexivity.
      apply assert_singleton_eval.
      reflexivity.
    * auto with typeclass_instances.
  + simpl; intros.
    rewrite <- assert_memext_r with (Q:=var_points_to 0 a) (P:=(load (var (S i)) ⇓ inr (intV{sintT} z))%A); [|auto with typeclass_instances].
    apply assert_sep_preserving; [reflexivity|].
    rewrite IHst with (1:=H1).
    rewrite assert_lift_expr.
    reflexivity.
Qed.

Lemma var_points_to_unlock_indep i mv:
  (var_points_to i mv ⊆{Γ,δ} var_points_to i mv ◊)%A.
Proof.
destruct mv; unfold var_points_to.
* simpl.
  apply assert_singleton_unlock_indep.
  reflexivity.
* apply assert_exist_elim; intro v.
  rewrite assert_unlock_exists.
  apply assert_exist_intro with (x:=v).
  apply assert_singleton_unlock_indep.
  reflexivity.
Qed.

Lemma assert_stack_unlock_indep' st:
  assert_stack st ⊆{Γ,δ} (assert_stack st ◊)%A.
Proof.
revert Γ δ.
induction st; simpl; intros.
- rewrite <- unlock_indep.
  reflexivity.
- rewrite <- assert_unlock_sep.
  apply assert_sep_preserving.
  + rename a into mv.
    destruct mv; unfold var_points_to.
    * simpl.
      apply assert_singleton_unlock_indep.
      reflexivity.
    * apply assert_exist_elim; intro v.
      rewrite assert_unlock_exists.
      apply assert_exist_intro with (x:=v).
      apply assert_singleton_unlock_indep.
      reflexivity.
  + assert (UnlockIndep (assert_stack st)%A). exact IHst.
    apply unlock_indep.
Qed.

Lemma assert_stack_unlock_indep st:
  (assert_stack st↑)%A ⊆{Γ,δ} ((assert_stack st↑) ◊)%A.
Proof.
revert Γ δ.
induction st; simpl; intros.
- rewrite stack_indep.
  rewrite <- unlock_indep.
  reflexivity.
- rewrite assert_lift_sep.
  rewrite <- assert_unlock_sep.
  apply assert_sep_preserving.
  + rename a into mv.
    destruct mv; unfold var_points_to.
    * rewrite assert_lift_singleton.
      simpl.
      apply assert_singleton_unlock_indep.
      reflexivity.
    * rewrite assert_lift_exists.
      apply assert_exist_elim; intro v.
      rewrite assert_unlock_exists.
      apply assert_exist_intro with (x:=v).
      rewrite assert_lift_singleton.
      apply assert_singleton_unlock_indep.
      reflexivity.
  + assert (UnlockIndep (assert_stack st↑)%A). exact IHst.
    apply unlock_indep.
Qed.

End Program.