Constructive extensional model of finite set theory

From Undecidability.FOL Require Import FST Reductions.PCPb_to_FST.
From Undecidability.FOL Require Import Syntax Syntax_facts FullTarski_facts.
From Undecidability.TRAKHTENBROT Require Import hfs.
From Undecidability.Shared.Libs.DLW.Utils Require Import finite.

From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.

Instance hfs_interp :
  interp hfs.
Proof.
  split.
  - intros [].
    + intros _. exact hfs_empty.
    + intros v. exact (hfs_cons (Vector.hd v) (Vector.hd (Vector.tl v))).
  - intros [].
    + intros v. exact (hfs_mem (Vector.hd v) (Vector.hd (Vector.tl v))).
    + intros v. exact (Vector.hd v = Vector.hd (Vector.tl v)).
Defined.

Open Scope sem.

Lemma hfs_model :
  forall rho, rho FST.
Proof.
  intros rho phi [<-|[<-|[<-|[]]]]; cbn.
  - intros x y H1 H2. apply hfs_mem_ext. intuition.
  - intros x. apply hfs_empty_spec.
  - intros x y z. apply hfs_cons_spec.
Qed.

Lemma htrans_htrans x y :
  htrans x -> y x -> htrans y.
Proof.
  intros [H1 H2] H. split; try now apply H2.
  intros z Hz. apply H2. now apply (H1 y).
Qed.

Definition max {X} (L : list X) :
  forall (f : forall x, x el L -> nat), sig (fun n => forall x (H : x el L), f x H < n).
Proof.
  intros f. induction L; cbn.
  - exists 42. intros x [].
  - unshelve edestruct IHL as [n Hn].
    + intros x Hx. apply (f x). now right.
    + pose (na := f a (or_introl eq_refl)). exists ((S na) + n). intros x [->|H].
      * unfold na. apply NPeano.Nat.lt_lt_add_r. constructor.
      * specialize (Hn x H). cbn in Hn. now apply NPeano.Nat.lt_lt_add_l.
Qed.

Lemma hfs_model_standard x :
  htrans x -> sig (fun n => x = numeral n).
Proof.
  induction x using hfs_rect.
  intros Hx. destruct (hfs_mem_fin_t x) as [L HL].
  unshelve edestruct (@max _ L) as [N HN].
  - intros y Hy % HL. destruct (H y) as [n Hn]; auto. eapply htrans_htrans; eauto.
  - apply numeral_trans_sub with N.
    + apply hfs_model.
    + reflexivity.
    + intros a b. destruct (hfs_mem_dec a b); auto.
    + intros y Hy. destruct (H y Hy (htrans_htrans Hx Hy)) as [n Hn].
      rewrite Hn. apply numeral_lt; try apply hfs_model; try reflexivity.
      assert (HLy : y el L) by now apply HL. specialize (HN y HLy).
      cbn in HN. destruct H as [n' ->] in HN.
      erewrite numeral_inj at 1; try apply HN; try apply hfs_model; try reflexivity.
      now rewrite Hn.
    + apply (proj1 Hx).
Qed.

Lemma FST_model :
  exists V (M : interp V), extensional M /\ standard M /\ forall rho, rho FST.
Proof.
  exists hfs, hfs_interp. split; try reflexivity.
  split; try apply hfs_model.
  intros x Hx. destruct (hfs_model_standard Hx) as [n Hn]. now exists n.
Qed.

Definition list2hfs L :=
  fold_right hfs_cons hfs_empty L.

Lemma list2hfs_spec L x :
  hfs_mem x (list2hfs L) <-> x el L.
Proof.
  induction L; cbn.
  - apply hfs_empty_spec.
  - split.
    + intros [<-|H] % hfs_cons_spec; auto. right. now apply IHL.
    + intros [<-|H]; apply hfs_cons_spec; auto. right. now apply IHL.
Qed.

Lemma hfs_ind P :
  P hfs_empty -> (forall x y, P x -> P y -> P (hfs_cons x y)) -> forall x, P x.
Proof.
  intros H1 H2 x. induction (hfs_mem_wf x) as [x _ IH].
  destruct (hfs_mem_fin_t x) as [L HL].
  induction L in x, IH, HL |- *.
  - assert (x = hfs_empty) as ->; try apply H1.
    apply hfs_mem_ext. intros y. rewrite HL.
    rewrite hfs_empty_spec. cbn. tauto.
  - assert (x = hfs_cons a (list2hfs L)) as ->; try apply H2.
    + apply hfs_mem_ext. intros y.
      change (hfs_cons a (list2hfs L)) with (list2hfs (a :: L)).
      rewrite list2hfs_spec. apply HL.
    + apply IH. apply hfs_cons_spec. now left.
    + apply IHL.
      * intros x Hx. apply IH. apply hfs_cons_spec. now right.
      * apply list2hfs_spec.
Qed.

Lemma hfs_ax_ind phi rho :
  rho ax_ind phi.
Proof.
  cbn. intros H1 H2. apply hfs_ind.
  - apply sat_comp in H1. eapply sat_ext; try apply H1. now intros [].
  - setoid_rewrite sat_comp in H2. intros x y Hx Hy. eapply sat_ext; try apply (H2 y x).
    + now intros [].
    + eapply sat_ext; try apply Hx. now intros [].
    + eapply sat_ext; try apply Hy. now intros [].
Qed.

Lemma FSTI_model :
  exists V (M : interp V), extensional M /\ standard M /\ forall rho psi, FSTI psi -> rho psi.
Proof.
  exists hfs, hfs_interp. split; try reflexivity. split.
  - intros x Hx. destruct (hfs_model_standard Hx) as [n Hn]. now exists n.
  - intros rho psi []; try now apply hfs_model. apply hfs_ax_ind.
Qed.