(* Require Import AuxProp. *)
Require Import IndefiniteDescription.
Require Import PropExtensionality.
From hahn Require Import Hahn.
Require Import ClassicalDescription.
Require Import Lia.
Require Import Arith.

Definition set_size {A: Type} (S: A -> Prop): nat_omega :=
  match (excluded_middle_informative (set_finite S)) with
  | left FIN => (NOnum (length (undup (filterP S (proj1_sig (constructive_indefinite_description _ FIN))))))
  | right _ => NOinfinity
  end.

Lemma lt_size_of_finite A (s : A -> Prop) d
      (SUB: forall x, s x -> In x d) n :
  lt_size n s <-> n < length (undup (filterP s d)).
Proof using.
  unfold lt_size; split; ins; desf.
    eapply lt_le_trans, NoDup_incl_length; unfold incl; eauto.
    ins; rewrite in_undup_iff, in_filterP_iff; desf; eauto.
    exists (undup (filterP s d)); splits; ins.
    rewrite in_undup_iff, in_filterP_iff in *; desf; eauto.
Qed.

Lemma set_lt_size {A: Type} (S: A -> Prop) i:
  NOmega.lt_nat_l i (set_size S) <-> lt_size i S.
Proof using.
  unfold set_size. destruct (excluded_middle_informative _).
  2: { simpl. split; auto. ins. by apply lt_size_infinite. }
  destruct (constructive_indefinite_description _).
  simpl. symmetry. by apply lt_size_of_finite.
Qed.

Lemma enumeratesE' {A : Type} (f : nat -> A) (s : A -> Prop):
  enumerates f s <->
  let dom := fun i => NOmega.lt_nat_l i (set_size s) in
  ⟪INSET: forall i : nat, dom i -> s (f i)⟫ /\
  ⟪INJ: forall i : nat, dom i -> forall j : nat, dom j -> f i = f j -> i = j⟫ /\
  ⟪IND: forall a : A, s a -> exists i : nat, dom i /\ f i = a⟫.
Proof using.
  etransitivity.
  { apply enumeratesE. }
  pose proof (set_lt_size s) as EQUIV.
  split.
  { ins. desc. splits; ins.
    { by apply RNG, EQUIV. }
    { by apply INJ; [apply EQUIV | apply EQUIV| apply H1]. }
    { apply SUR in H. desc. exists i. split; auto. by apply EQUIV. }
  }
  { ins. desc. splits; ins.
    { by apply INSET, EQUIV. }
    { by apply INJ; [apply EQUIV | apply EQUIV| ]. }
    { apply IND in IN. desc. exists i. split; auto. by apply EQUIV. }
  }
Qed.

Lemma set_size_equiv {A: Type} (S1 S2: A -> Prop) (EQ: S1 ≡₁ S2):
  set_size S1 = set_size S2.
Proof using.
  cut (S1 = S2); [congruence| ].
  extensionality a. apply propositional_extensionality.
  by apply set_equiv_exp.
Qed.

Lemma set_size_empty {A: Type} (s: A -> Prop):
  set_size s = NOnum 0 <-> s ≡₁ ∅.
Proof.
  split; intros.
  { unfold set_size in H. destruct excluded_middle_informative; try by vauto.
    destruct constructive_indefinite_description. simpl in *.
    inversion H. apply length_zero_iff_nil in H1.
    destruct (classic (s ≡₁ ∅)) as [? | NEMPTY]; auto.
    apply set_nonemptyE in NEMPTY. desc.
    specialize (i _ NEMPTY).
    assert (In x0 nil); [| by vauto].
    rewrite <- H1. apply in_undup_iff. apply in_filterP_iff. auto. }
  erewrite set_size_equiv; eauto.
  unfold set_size. destruct excluded_middle_informative.
  2: { destruct n. by exists nil. }
  f_equal. destruct constructive_indefinite_description. simpl in *.
  rewrite (proj2 (filterP_eq_nil ∅ x)); vauto.
Qed.

Lemma set_size_finite {A: Type} (S: A -> Prop)
  (FIN: set_finite S):
  exists n, set_size S = NOnum n.
Proof using.
  unfold set_size. destruct (excluded_middle_informative _); by vauto.
Qed.


Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import Arith.

Require Import folProp.
Require Import folProof.
Require Import subProp.
Require Import folLogic3.
Require Import folReplace.
Require Import NN.
Require Import PAtheory.
Require Export LNN2LNT.
Require Import subAll.
Require Import ListExt.

Lemma NN2PA (f : fol.Formula LNN):
  folProof.SysPrf LNN NN f -> SysPrf PA (LNN2LNT_formula f).
Proof.
  intro H; apply translateProof with NN.
  - apply closedPA1.
  - intros f0 H0; unfold NN in H0.
    destruct H0 as [x H0| x H0].
    + destruct  H0 as [x H0| x H0].
      * destruct H0 as [x H0| x H0].
        -- destruct H0 as [x H0| x H0].
           ++ destruct H0 as [x H0| x H0].
              ** destruct H0 as [x H0| x H0].
                 destruct H0 as [x H0| x H0].
                 destruct H0 as [x H0| x H0].
                 destruct H0.
                 apply Axm; repeat (try right; constructor) || left.
                 destruct H0.
                 apply Axm; repeat (try right; constructor) || left.
                 destruct H0.
                 apply Axm; repeat (try right; constructor) || left.
                 destruct H0.
                 apply Axm; repeat (try right; constructor) || left.
              ** destruct H0.
                 apply Axm; repeat (try right; constructor) || left.
           ++ destruct H0.
              apply Axm; repeat (try right; constructor) || left.
        -- destruct H0.
           apply NN72PA.
      * destruct H0.
        apply NN82PA.
    + destruct H0.
      apply NN92PA.
  - apply H.
Qed.

Lemma PAboundedLT :
  forall (m : nat) (F : Formula) (x : nat),
    (forall n : nat,
        n < m -> SysPrf PA (substituteFormula LNT F x (natToTerm n))) ->
    SysPrf PA (LNN2LNT_formula ((v_ x)%nt < LNN.natToTerm m)%nn -> F)%nt.
Proof.
simple induction m.
- intros F x H; apply impI.
  apply contradiction with
    (LNN2LNT_formula (LNN.LT (var x) (LNN.natToTerm 0))).
  apply Axm; right; constructor.
  apply sysWeaken.
  replace (notH (LNN2LNT_formula (LNN.LT (var x) (LNN.natToTerm 0))))
    with
    (LNN2LNT_formula (notH  (LNN.LT (var x) (LNN.natToTerm 0)))).
  + apply NN2PA.
    apply nn7.
  + reflexivity.
- intros n H a x H0; apply impI.
  eapply orE.
  + apply impE with
      (LNN2LNT_formula (LNN.LT (var x) (LNN.natToTerm (S n)))).
    * apply sysWeaken.
      assert (H1: SysPrf PA (LNN2LNT_formula
                     ((v_ x < S_ (LNN.natToTerm n))%nn ->
                      (v_ x < LNN.natToTerm n)%nn \/
                        v_ x = LNN.natToTerm n)%nt)%nt)
      by (apply NN2PA, nn8).
      simpl in H1; simpl.
      unfold orH; apply H1.
    * apply Axm; right; constructor.
  + apply sysWeaken.
    simpl in H; apply H; auto.
  + apply sysWeaken, impI.
    rewrite <- (subFormulaId LNT a x).
    rewrite LNN2LNT_natToTerm.
    apply impE with (substituteFormula LNT a x (natToTerm n)).
    * apply (subWithEquals LNT).
      apply eqSym.
      apply Axm; right; constructor.
    * apply sysWeaken.
      apply H0.
      apply Nat.lt_succ_diag_r .
Qed.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Export Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Lists.List.
Import ListNotations.

Definition beq_string x y :=
  if string_dec x y then true else false.

Theorem beq_string_refl : forall s, true = beq_string s s.
Proof.
  intros s. unfold beq_string.
  destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.

Theorem beq_string_true_iff : forall x y :string,
  beq_string x y = true <-> x = y.
Proof.
  intros x y.
  unfold beq_string.
  destruct (string_dec x y) as [|Hs].
  - subst. split. reflexivity. reflexivity.
  - split.
    + intros contra. inversion contra.
    + intros H. inversion H. subst. destruct Hs. reflexivity.
Qed.

Theorem beq_string_false_iff : forall x y : string,
  beq_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- beq_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

Theorem false_beq_string : forall x y : string,
  x <> y -> beq_string x y
 = false.
Proof.
  intros x y. rewrite beq_string_false_iff.
  intros H. apply H. Qed.

Definition total_map (A : Type) := string -> A.

Definition t_empty { A : Type } (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A : Type} (m : total_map A)
  (x : string) (v : A) :=
  fun x' => if beq_string x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
            "bar" true.

Notation "{ --> d }" := (t_empty d) (at level 0).

Notation "m '&' { a --> x }" :=
  (t_update m a x) (at level 20).
Notation "m '&' { a --> x ; b --> y }" :=
  (t_update (m & { a --> x }) b y) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z }" :=
  (t_update (m & { a --> x ; b --> y }) c z) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z }) d t) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t ; e --> u }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z ; d --> t }) e u) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z ; d --> t ; e --> u }) f v) (at level 20).

Definition examplemap' :=
  { --> false } & { "foo" --> true; "bar" --> true }.

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
  ({ --> v } x) = v.
Proof.
  intros A x v. unfold t_empty. reflexivity.
Qed.

Lemma t_update_eq : forall A (m : total_map A) x v,
  (m & {x --> v}) x = v.
Proof.
  intros A m x v. unfold t_update.
  rewrite <- beq_string_refl. reflexivity.
Qed.

Theorem t_update_neq :
  forall (X : Type) v x1 x2 (m : total_map X),
  x1 <> x2 -> (m & {x1 --> v}) x2 = m x2.
Proof.
  intros X v x1 x2 m H. unfold t_update.
  rewrite -> false_beq_string.
  - reflexivity.
  - apply H.
Qed.

Lemma t_update_shadow : forall A (m : total_map A) v1 v2 x,
  m & { x --> v1 ; x --> v2 } = m & { x --> v2 }.
Proof.
  intros A m v1 v2 x.
  apply functional_extensionality.
  intros x0. unfold t_update .
  destruct (beq_string x x0).
  - reflexivity.
  - reflexivity.
Qed.

Lemma beq_stringP : forall x y, reflect (x = y) (beq_string x y).
Proof.
  intros x y. apply iff_reflect. rewrite beq_string_true_iff.
  reflexivity.
Qed.

Theorem t_update_same : forall X x (m : total_map X),
  m & { x --> m x } = m.
Proof.
  intros X x m.
  apply functional_extensionality.
  intros x0.
  unfold t_update.
  destruct (beq_stringP x x0).
  - rewrite <- e. reflexivity.
  - reflexivity.
Qed.

Theorem t_update_permute :
  forall X v1 v2 x1 x2 (m : total_map X),
  x2 <> x1 -> m & { x2 --> v2 ; x1 --> v1 }
  = m & { x1 --> v1 ; x2 --> v2 }.
Proof.
  intros X v1 v2 x1 x2 m H.
  apply functional_extensionality.
  intro x. unfold t_update.
  destruct (beq_stringP x1 x).
  - destruct (beq_stringP x2 x).
    + rewrite <- e0 in e. unfold not in H.
      symmetry in e. apply H in e. inversion e.
    + reflexivity.
  - reflexivity.
Qed.

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
  (x : string) (v : A) := m & {x --> (Some v)}.

Notation "m '&' {{ a --> x }}" :=
  (update m a x) (at level 20).
Notation "m '&' {{ a --> x ; b --> y }}" :=
  (update (m & {{ a --> x }}) b y) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z }}" :=
  (update (m & {{ a --> x ; b --> y }}) c z) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z }}) d t) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z ; d --> t }}) e u) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }}) f v) (at level 20).

Lemma apply_empty : forall (A: Type) (x: string), @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
    (m & {{ x --> v }}) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (m & {{ x2 --> v }}) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
    m & {{ x --> v1 ; x --> v2 }} = m & {{x --> v2}}.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  m & {{x --> v}} = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
  m & {{x2 --> v2 ; x1 --> v1}}
  = m & {{x1 --> v1 ; x2 --> v2}}.
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require real.Real.

(* Why3 comment *)
(* from_int is replaced with (Reals.Raxioms.IZR x) by the coq driver *)

(* Why3 goal *)
Lemma Zero : ((Reals.Raxioms.IZR 0%Z) = 0%R).
split.
Qed.

(* Why3 goal *)
Lemma One : ((Reals.Raxioms.IZR 1%Z) = 1%R).
split.
Qed.

(* Why3 goal *)
Lemma Add : forall (x:Z) (y:Z),
  ((Reals.Raxioms.IZR (x + y)%Z) = ((Reals.Raxioms.IZR x) + (Reals.Raxioms.IZR y))%R).
exact plus_IZR.
Qed.

(* Why3 goal *)
Lemma Sub : forall (x:Z) (y:Z),
  ((Reals.Raxioms.IZR (x - y)%Z) = ((Reals.Raxioms.IZR x) - (Reals.Raxioms.IZR y))%R).
exact minus_IZR.
Qed.

(* Why3 goal *)
Lemma Mul : forall (x:Z) (y:Z),
  ((Reals.Raxioms.IZR (x * y)%Z) = ((Reals.Raxioms.IZR x) * (Reals.Raxioms.IZR y))%R).
exact mult_IZR.
Qed.

(* Why3 goal *)
Lemma Neg : forall (x:Z),
  ((Reals.Raxioms.IZR (-x)%Z) = (-(Reals.Raxioms.IZR x))%R).
exact opp_IZR.
Qed.


From mathcomp Require Import all_ssreflect.
Require Import Ensembles.
Require Import Relations.
Require Import Equivalence.
Require Import Tactics.

Set Implicit Arguments.
Unset Strict Implicit.

Section Pretopology.

Arguments In {U}.
Arguments Included {U}.
Arguments Singleton {U}.
Arguments Union {U}.
Arguments Add {U}.
Arguments Intersection {U}.
Arguments Couple {U}.
Arguments Triple {U}.
Arguments Complement {U}.
Arguments Setminus {U}.
Arguments Subtract {U}.
Arguments Disjoint {U}.
Arguments Inhabited {U}.
Arguments Strict_Included {U}.
Arguments Same_set {U}.
Arguments Extensionality_Ensembles {U}.
Arguments Empty_set {U}.
Arguments Full_set {U}.

Notation "A >= B" := (Included B A).
Notation "A <= B" := (Included A B).
Notation "A == B" := (Same_set A B).
Notation "A && B" := (Intersection A B).
Notation "A || B" := (Union A B).
Notation "~~ A" := (Complement A).
Notation "x /in A" := (In A x) (at level 50).
Definition pow:= Ensemble.

Class Upward {T} (o: relation T) (u: pow T) := {
  upward (s t: T) : o s t -> u s -> u t;
}.

Class Nonempty {T} (u: pow T) := {
  nonempty: exists s, u s;
}.

Class Proper {T} (p: pow (pow T)) := {
  proper: ~ p Empty_set
}.

Class Directed {T} (o: relation T) (d: pow T) := {
  directed (s t: T) : d s -> d t -> exists u, (d u /\ o u s /\ o u t);
}.

Class Filter {T} (f: pow (pow T)) := {
  filter_nonempty :> Nonempty f; (* => implies having total set with upward property *)
  filter_upward :> Upward Included f;
  filter_directed :> Directed Included f;
  filter_preserve_intersection (s t: pow T) : f s -> f t -> f (s && t);
}.

Class Neighborhood {T} (n: T -> pow (pow T)) := {
  neighborhood_filters (x:T) : Filter (n x);
  neighborhood_point (x:T) (s: pow T) : n x s -> s x;
}.

Class Interior {T} (i: pow T -> pow T) := {
  interior_preserve_total : Full_set == i Full_set;
  interior_intensivity (s: pow T) : i s <= s;
  interior_isotonic (s t: pow T) : s <= t -> i s <= i t;
  interior_preserve_intersection (s t: pow T) : i (s && t) == (i s) && (i t);
}.

Lemma isotonic_implies_intersection T (i: pow T -> pow T): (forall s t: pow T, s <= t -> i s <= i t) -> (forall s t, i (s && t) <= (i s) && (i t)).
move => isotonic.
have: forall s t: pow T, s && t <= s.
- move => s t x stx.
  by case: stx.
move => incr.
have: forall s t: pow T, s && t <= t.
- move => s t x stx.
  by case: stx.
move => incl.
move => s t x istx.
split.
- by apply: (isotonic (s && t) s (incr s t)).
- by apply: (isotonic (s && t) t (incl s t)).
Qed.

Lemma and_in T (s t: pow T): forall x: T, s x -> t x -> (s && t) x.
move => x sx tx.
by constructor.
Qed.

Lemma iso2 (p : Prop -> Prop): (forall a b: Prop, (a -> b) -> p a -> p b) -> (forall a:Prop, p a -> a) -> (forall a b: Prop, (p a) /\ (p b) -> p (a /\ b)).
move => iso inc a b pab.
case: pab => pa pb.
move: (inc a pa) => ta.
move: (inc b pb) => tb.
apply: (iso (a) (a /\ b)).
move => ta2.
constructor.
by exact.
by exact.
by exact.
Qed.

Lemma iso3 (p : Prop -> Prop): (forall a b: Prop, (a -> b) -> p a -> p b) -> (forall a:Prop, p a -> a) -> (forall a b: Prop, p (a /\ b) -> (p a) /\ (p b)).
move => iso inc a b pab.
constructor.
apply: (iso (a /\ b) a).
move=> ab.
by case ab.
exact pab.
apply: (iso (a /\ b) b).
move=> ab.
by case ab.
exact pab.
Qed.

Class Closure {T} (c: pow T -> pow T) := {
  closure_preserve_empty : Empty_set == c Empty_set;
  closure_extensivity (s: pow T) : s <= c s;
  closure_isotonic (s t: pow T) : s <= t -> c s <= c t;
  closure_preserve_union (s t: pow T) : c (s || t) == (c s) || (c t);
}.

Lemma intersection_with_complement_of_itself_is_empty {T} (c: pow T -> pow T) : forall s: pow T, (s && ~~s) <= Empty_set.
move => s x sinsx.
case: sinsx => p sx nsx.
exfalso.
by apply nsx.
Qed.

Lemma union_complement_total_classic {T}: (forall s: pow T, Full_set <= (s || ~~s)) -> (forall s: pow T, (~~~~s) <= s).
have: (forall (v: pow T), (Full_set <= v) -> forall x: T, In v x).
- move => s p x.
  by apply p.
move => i u s x.
move: (i (s || ~~s) (u s) x) => sucsx.
by case: x / sucsx => x sx ccsx.
Qed.

Definition n2i {T} (v: T -> pow (pow T)) (s: pow T) (x:T) := v x s.
Definition i2n {T} (i: pow T -> pow T) (x:T) (s: pow T) := i s x.
Definition i2c {T} (i: pow T -> pow T) (s: pow T) := ~~ (i (~~ s)).
Definition c2i {T} (c: pow T -> pow T) (s: pow T) := ~~ (c (~~ s)).

Lemma projl {T} : forall s t : pow T, s && t <= s.
Proof.
move => s t x stx.
by case: stx => y sx tx.
Qed.

Lemma projr {T} : forall s t : pow T, s && t <= t.
Proof.
move => s t x stx.
by case: stx => y sx tx.
Qed.

Theorem neighborhood_derives_interior {T} (n: T->pow (pow T)): Neighborhood n -> Interior (n2i n).
Proof.
  move => neighborhood.
  case: neighborhood => filters base.
  constructor.
  - constructor.
    + move => x fx.
      move: (filters x) => filter.
      case: filter => nonempty upward directed intersection; case: upward => upward; case: nonempty => nonempty; case: directed => directed.
      case: nonempty => s nxs.
      apply: (fun g => (upward s Full_set) g nxs).
      by constructor.
    + move => x n2in.
      by constructor.
  - move => s x nxs.
    case: (filters x)=> nonempty upward directed interseciton.
    case: upward => upward.
    by apply: (base x s).
  - move => s t s_included_t x nxs.
    case: (filters x) => nonemtpy upward directed intersection.
    case: upward => upward.
    by apply: (upward s t s_included_t).
  - move => s t.
    constructor.
    + move => x nxst.
      move: (filters x) => filter.
      case: filter => nonempty upward directed intersection; case: upward => upward; case: nonempty => nonempty; case: directed => directed.
      constructor.
      * move: (projl (T:=T) (s:=s) (t:=t)) => projl.
        apply: (upward (s && t) s projl).
        by apply: nxst.
      * move: (projr(T:=T) (s:=s) (t:=t)) => projr.
        apply: (upward (s && t) t projr).
        by apply: nxst.
    + move => x nsntx.
      case: x /nsntx => x l r.
      move: (filters x) => filter.
      case: filter => nonempty upward directed intersection; case: upward => upward; case: nonempty => nonempty; case: directed => directed.
      by apply: (intersection s t l r).
Qed.

Theorem interior_derives_neighborhood {T} (i: pow T -> pow T): Interior i -> Neighborhood (i2n i).
Proof.
  move => interior.
  case: interior => preserve_total intensive isotonic intersection.
  constructor.
  - move => x.
    constructor.
    + constructor.
      exists Full_set.
      apply: (proj1 preserve_total).
      by constructor.
    + constructor.
      move => s t s_included_t isx.
      apply: (isotonic s t s_included_t).
      by apply: isx.
    + constructor.
      move => s t isx itx.
      exists (s && t).
      - constructor.
        compute.
        apply: (proj2 (intersection s t)).
        by constructor.
      - constructor.
        + by apply: projl.
        + by apply: projr.
    + move => s t isx itx.
      apply: (proj2 (intersection s t)).
      by constructor.
  - move => x s isx.
    by apply: intensive.
Qed.

Theorem contra {T} (s t: pow T) : s <= t -> ~~t <= ~~s.
Proof.
  move => s_implies_t x ctx sx.
  apply: ctx.
  by apply: s_implies_t.
Qed.

Theorem contra2 {T} (s t: pow T) : s <= ~~t -> t <= ~~s.
Proof.
  move => s_implies_ct x tx sx.
  by apply: (s_implies_ct x sx).
Qed.

Lemma injl {T} : forall s t : pow T, s <= s || t.
Proof.
move => s t x stx.
by constructor 1.
Qed.

Lemma injr {T} : forall s t : pow T, t <= s || t.
Proof.
move => s t x stx.
by constructor 2.
Qed.

Lemma b {T} : forall s: pow T, s <= ~~~~s.
move => a x ax cax.
by contradiction cax.
Qed.

Theorem demorgan1 {T} (s t : pow T) : (~~(s || t)) <= (~~s) && (~~t).
Proof.
  move => x nstx.
  constructor.
  - move => sx.
    apply: nstx.
    by constructor 1.
  - move => tx.
    apply: nstx.
    by constructor 2.
Qed.

Axiom cc: forall (T:Type) (s: pow T), ~~~~s <= s.
Theorem pem {T} (s : pow T) : (~~s) && s <= Empty_set.
move => x nss.
case nss => y nsy sy.
by contradiction nsy.
Qed.
Theorem dual {T} (s t : pow T) : ~~s <= ~~t -> t <= s. (* classic *)
Proof.
move => l x g.
apply: (cc (s:=s)).
move => a.
by apply: (l x a g).
Qed.
Theorem em {T}: (~~Full_set (U:=T) ) <= Empty_set.
move => x nfx.
contradiction nfx.
constructor.
Qed.

Theorem dual2 {T} (s t : pow T) : ~~ (s && t) <= (~~s) || (~~t).  (* classic *)
Proof.
  move=> x nstx.
  apply: cc.
  move=> nnsntx.
  apply: nstx.
  constructor.
  - apply: cc.
    move=> nsx.
    apply: nnsntx.
    by constructor 1.
  - apply: cc.
    move=> nsx.
    apply: nnsntx.
    by constructor 2.
Qed.
Theorem dual3 {T} (s t : pow T) : ~~ (s || t) <= (~~ s) && (~~t).
Proof.
  move => x nstx.
  constructor.
  - move => sx.
    apply: nstx.
    by apply: injl sx.
  - move => tx.
    apply: nstx.
    by apply: injr tx.
Qed.

Theorem dual4 {T} (s t : pow T) : ((~~ s) && (~~t)) <= ~~ (s || t).
Proof.
  move => x nsntx.
  destruct nsntx as [x L R].
  move => nstx.
  destruct nstx as [x LL |x RR].
  by apply: L.
  by apply: R.
Qed.
Theorem iso {T} (i: pow T -> pow T): Interior i -> forall s: pow T, i s <= c2i (i2c i) s.
Proof.
  move => interior s.
  rewrite /i2c /c2i.
  move => x isx ninnsx.
  apply: ninnsx.
  destruct interior.
  move: (interior_isotonic0 s (~~~~s)) => d.
  assert (s <= (~~~~s)).
  - move => v sv nsv.
    by apply: nsv.
  by apply: (d H).
Qed.

Theorem interior_derives_closure {T} (i: pow T -> pow T): Interior i -> Closure (i2c i).
Proof.
  move => interior.
  case: interior => preserve_total intensive isotonic intersection.
  assert (extensivity: forall u: pow T, u <= i2c i u).
  + move => u x ux icux.
    by apply: (intensive (~~u) x icux).
  assert (isotonic_c: forall s t : pow T, s <= t -> i2c i s <= i2c i t).
  + move => s t s_implies_t.
    apply: contra.
    apply: (isotonic (~~t) (~~s)).
    by apply: contra.
  constructor.
  - constructor.
    + move => x empx.
      by contradiction empx.
    + move => x iempx.
      contradiction iempx.
      rewrite /In.
      assert (empfull: i Full_set <= i (~~Empty_set)).
      * apply: isotonic.
        move => y fully empy.
        by contradiction empy.
      apply: empfull.
      apply: (proj1 preserve_total).
      assert (sf: Singleton x <= Full_set).
      * move => y singy.
       by constructor.
      apply: sf.
      by constructor.
  - by apply: extensivity.
  - by apply: isotonic_c.
  - move => s t.
    constructor.
    + move => x nst.
      apply: dual2.
      move => nnsnst.
      apply: nst.
      apply: (isotonic ((~~ s) && (~~t)) (~~(s||t))).
      by apply: dual4.
      by apply: (proj2 (intersection (~~s) (~~t))).
    + rewrite /i2c.
      move => x nst instx.
      destruct nst as [x p| x p].
      - apply: p.
        apply: (isotonic (~~( s || t)) (~~s)).
        apply: dual.
        move => p mm mmm.
        apply mm.
        move => mmmm.
        apply: mmm.
        by constructor 1.
        by [].
      - apply: p.
        apply: (isotonic (~~ (s || t)) (~~t)).
        apply: dual.
        move => p mm mmm.
        apply mm.
        move => mmmm.
        apply: mmm.
        by constructor 2.
        by [].
Qed.

Definition image {X Y} (f: X -> Y) (preimage : pow X) := fun y: Y => exists x:X, preimage x /\ (f x = y).
Definition preimage {X Y} (f: X -> Y) (image : pow Y) := fun x: X => exists y:Y, image y /\ (f x = y).
Definition filter_image {X Y} (f: X -> Y) (F : pow (pow X)) := fun fA: pow Y => exists A: pow X, F A /\ image f A <= fA.

Definition converge {T} (f: pow (pow T)) (n: T -> pow (pow T)) (x: T) := n x <= f.
Definition continuous {X Y} (nx: X -> pow (pow X)) (ny: Y -> pow (pow Y)) (f: X -> Y) (x: X):=
  forall fx : pow (pow X), converge fx nx x -> converge (filter_image f (fx)) ny (f x).

Definition ultrafilter {T} (f: pow (pow T)):= forall g: pow (pow T), f <= g -> f == g.
Definition compact {T} (n: T -> pow (pow T)) := forall g: pow (pow T), ultrafilter g -> exists x:T, converge g n x.
Definition weakest_topology {X Y} (f: X -> Y) (ny: Y -> pow (pow Y)) := fun x: X => fun sx:pow X => ny (f x) (image f sx).
Definition strongest_topology {X Y} (f: X -> Y) (nx: X -> pow (pow X)) := fun y: Y => fun sy:pow Y => sy y /\ exists x:X, nx x (preimage f sy).

Definition multspace {I} {X: I -> Type} (nxi: forall i:I, X i -> pow (pow (X i))) (i: I) := weakest_topology (fun x: X i => x) (nxi i).
End Pretopology.


Require Import Coq.Arith.Arith.
Require Import Lt.
Require Import Omega.

Axiom lt_ge_dec : forall x y : nat, { x < y } + { x >= y }.
(*Proof.
  intros.
  elim (le_lt_dec y x) ; intros ; auto with arith.
Defined.
*)
Require Import Coq.subtac.FixSub.
Require Import Wf_nat.

Lemma preda_lt_a : forall a, 0 < a -> pred a < a.
auto with arith.
Qed.

Program Fixpoint id_struct (a : nat) : nat :=
  match a with
  0 => 0
  | S n => S (id_struct n)
  end.

Check struct_rec.

  if (lt_ge_dec O a)
  then S (wfrec (pred a))
  else O.

Program Fixpoint wfrec (a : nat) { wf a lt } : nat :=
  if (lt_ge_dec O a)
  then S (wfrec (pred a))
  else O.
intros.
apply preda_lt_a ; auto.

Defined.

Extraction wfrec.
Extraction Inline proj1_sig.
Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive sumbool => "bool" [ "true" "false" ].
Extract Inlined Constant lt_ge_dec => "<".

Extraction wfrec.
Extraction Inline lt_ge_dec le_lt_dec.
Extraction wfrec.

Program Fixpoint structrec (a : nat) { wf a lt } : nat :=
  match a with
   S n => S (structrec n)
   | 0 => 0
   end.
intros.
unfold n0.
omega.
Defined.

Print structrec.
Extraction structrec.
Extraction structrec.

Definition structrec_fun (a : nat) : nat := structrec a (lt_wf a).
Print structrec_fun.


Require Import Iron.Language.SystemF2Data.Base.

(********************************************************************)
(* Data Constructors
   Carries a data constructor tag and an arity. *)
Inductive datacon : Type :=
 | DataCon    : nat -> nat -> datacon.
Hint Constructors datacon.

(* The unit data constructor. *)
Definition dcUnit := DataCon   0 0.
Hint Unfold dcUnit.

(********************************************************************)
Fixpoint datacon_beq t1 t2 :=
  match t1, t2 with
  | DataCon n11 n12, DataCon n21 n22
  => beq_nat n11 n21 && beq_nat n12 n22
  end.

(* Boolean equality for data constructors. *)
Lemma datacon_beq_eq
 :  forall dc dc'
 ,  true = datacon_beq dc dc'
 -> dc = dc'.
Proof.
 intros.
 destruct dc.
 destruct dc'.
 snorm.
Qed.

(* Boolean negation for data constructors. *)
Lemma datacon_beq_false
 :  forall dc
 ,  false = datacon_beq dc dc
 -> False.
Proof.
 intro.
 destruct dc.
 snorm.
 inverts H.
  induction n.  false. auto.
  induction n0. false. auto.
Qed.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

From Coq Require Import Bool.Bvector.
From Coq Require Import NArith.Ndigits.
From Coq Require Import ZArith.
Require Import Omega Lia.
Require Import Vector.

(* An n-bit adder *)

Local Open Scope N_scope.

Definition vectorAdd {aWidth bWidth: nat} (cWidth: nat)
                     (a: Bvector aWidth) (b: Bvector bWidth) : Bvector cWidth :=
  let aN := Bv2N aWidth a in
  let bN := Bv2N bWidth b in
  let c := (aN + bN) mod 2^(N.of_nat cWidth) in
  N2Bv_sized cWidth c.

Compute Bv2N (vectorAdd 8 (N2Bv_sized 8 5) (N2Bv_sized 8 12)).
Compute Bv2N (vectorAdd 8 (N2Bv_sized 8 5) (N2Bv_sized 8 254)).

Definition vectorAddGrowth {width: nat}
           (a: Bvector width) (b: Bvector width) :
           Bvector (1 + width) :=
  let aN : N := Bv2N width a in
  let bN : N := Bv2N width b in
  let c : N := aN + bN in
  N2Bv_sized (1 + width) c.

Definition vectorAdd4Growth {width: nat}
                            (a: Bvector width)
                            (b: Bvector width)
                            (c: Bvector width)
                            (d: Bvector width) :
                            Bvector (2 + width) :=
  let a_plus_b := vectorAddGrowth a b in
  let c_plus_d := vectorAddGrowth c d in
  vectorAddGrowth a_plus_b c_plus_d.

Definition vectorAddGrowth2 {aWidth bWidth: nat}
           (a: Bvector aWidth) (b: Bvector bWidth) :
           Bvector (1 + max aWidth bWidth) :=
  let aN : N := Bv2N aWidth a in
  let bN : N := Bv2N bWidth b in
  let c : N := aN + bN in
  N2Bv_sized (1 + max aWidth bWidth) c.

Definition vectorAdd3Growth {aWidth bWidth cWidth: nat}
                            (a: Bvector aWidth)
                            (b: Bvector bWidth)
                            (c: Bvector cWidth) :
                            Bvector (1 + max (1 + max aWidth bWidth) cWidth) :=
  let a_plus_b := vectorAddGrowth2 a b in
  vectorAddGrowth2 a_plus_b c.

Local Open Scope vector_scope.

Lemma bv_p_0 : forall n, Bvector (n + 0) = Bvector n . intros. f_equal. omega. Qed.
Lemma v_p_0 : forall n T, Vector.t T (n + 0) = Vector.t T n . intros. f_equal. omega. Qed.
Lemma bv_p_1 : forall a b, Bvector (a + S b) = Bvector (1 + (a + b)) . intros. f_equal. omega. Qed.

Fixpoint adderTree {n w} (i: Vector.t (Bvector w) (2^n)) : Bvector (w + n).
destruct n.
- rewrite bv_p_0.
  exact (hd i).
- refine ( let (a, b) := splitat (2 ^ n) i in _).
  rewrite v_p_0 in b.
  fold Nat.pow in b.
  refine (
    let lhs := adderTree n _ a in
    let rhs := adderTree n _ b in
    _
  ).
  rewrite bv_p_1.
  exact ( vectorAddGrowth lhs rhs ).
Defined.

Definition i0 : Bvector 8 := N2Bv_sized 8.
Definition v0 : Vector.t (Bvector 8) 1 := [i0].

Compute adderTree v0.


(** * compiler_opts: certifying compiler optimisations *)

(** To illustrate some usage of the kat and hkat tactics, we formalise
   most of the compiler optimisations studied in the following paper:

   Dexter Kozen and Maria-Cristina Patron.
   Certification of compiler optimizations using Kleene algebra with tests.
   In Proc. 1st Int. Conf. Computational Logic (CL2000),
   Vol. 1861 of LNAI, pages 568-582, July 2000. Springer-Verlag.

   Most goals are solved with one single call to [kat] or [hkat].

   The remaining cases correspond to situations where one has to
   exploit permutations of some Kleene variables (the Horn theory of
   KA with such commutation hypotheses is undecidable). *)

From RelationAlgebra Require Import kat normalisation rewriting kat_tac.
Set Implicit Arguments.

(** in this module, we prefer the ";" notation for composition *)
Infix " ;" := (dot _ _ _) (left associativity, at level 40): ra_terms.

(** ** preliminary lemmas  *)

Lemma lemma_1 `{L: monoid.laws} `{Hl: BKA ≪ l} n (x y: X n n):
  x;y ≡ x;y;x -> x;y^* ≡ x;(y;x)^*.
Proof.
  intro H. apply antisym. apply str_ind_r'. ka.
  rewrite str_dot, <-dotA. rewrite H at 2. ka.
  rewrite str_dot. apply str_ind_l'. ka.
  rewrite str_unfold_l. ra_normalise. rewrite <-H. ka.
Qed.

Lemma lemma_1' `{L: monoid.laws} `{Hl: BKA ≪ l} n (x y: X n n):
  y;x ≡ x;(y;x) -> y^*;x ≡ (x;y)^*;x.
Proof. monoid.dual @lemma_1. Qed.

Lemma lemma_1'' `{L: monoid.laws} `{Hl: BKA ≪ l} n (p q r: X n n):
  p;q ≡ q;p -> p;r ≡ r -> (p;q)^*;r ≡ q^*;r.
Proof.
  intros Hpq Hpr. apply antisym.
  rewrite Hpq. apply str_ind_l'. ka. apply str_move in Hpq. mrewrite Hpq. mrewrite Hpr. ka.
  apply str_ind_l'. ka. rewrite <-str_snoc at 2. rewrite Hpq at 2 3. mrewrite Hpr. ka.
Qed.

Lemma lemma_2 `{L: laws} n b (q: X n n):
  [b];q ≡ q;[b] -> [b];q^* ≡ [b];(q;[b])^*.
Proof. hkat. Qed.

(** ** 3.1 Deadcode elimination  *)

Lemma opti_3_1_a `{L: laws} n (a: tst n) (p q: X n n):
  p ≡ p;[!a] -> p;([a];q+[!a]) ≡ p.
Proof. hkat. Qed.

Lemma opti_3_1_b `{L: laws} n (a: tst n) (p q: X n n):
  p ≡ p;[!a] -> p;([a];q)^*;[!a] ≡ p.
Proof. hkat. Qed.

(** ** 3.2 Common sub-expression elimination  *)

Lemma opti_3_2 `{L: laws} n (a b: tst n) (p q r w: X n n):
  p ≡ p;[a] ->
  [a];q ≡ [a];q;[b] ->
  [b];r ≡ [b] ->
  r ≡ w;r ->
  q;w ≡ w ->
  p;q ≡ p;r.
Proof.
  intros Hpa Haq Hbr Hr Hw.
  rewrite Hr, <-Hw. mrewrite <-Hr.
  hkat.
Qed.

(** ** 3.3 Copy propagation *)

Lemma opti_3_3 `{L: laws} n (a b: tst n) (p q r s v w: X n n):
  q ≡ q;[a] ->
  [a];r ≡ [a];r;[b] ->
  [b];s ≡ [b] ->
  s ≡ w;s ->
  r;w ≡ w ->
  s;v ≡ v;s ->
  q;v ≡ v ->
  p;q;r;v ≡ p;s;v.
Proof.
  intros Hqa Har Hbs Hs Hw Hsv Hv.
  mrewrite Hsv. rewrite <-Hv at 2. mrewrite <-Hsv.
  rewrite Hs, <-Hw. mrewrite <-Hs.
  hkat.
Qed.

(** ** 3.4 Loop Hoisting *)

Lemma opti_3_4i `{L: laws} n (a b: tst n) (p q r s u w: X n n):
  u;[b] ≡ u ->
  [b];u ≡ [b] ->
  [b];q ≡ q;[b] ->
  [b];s ≡ s;[b] ->
  [b];r ≡ r;[b] ->
  [a];w ≡ w;[a] ->
  u;r ≡ q ->
  u;w ≡ w ->
  q;s;w ≡ w;q;s ->
  p;u;([a];r;s)^*;[!a];w ≡ p;([a];q;s)^*;[!a];w.
Proof.
  intros ? ? ? ? ? ? Hur Huw Hqsw.
  transitivity (p;u;[b];([a];[b];(u;r);s)^*;[!a];w). hkat. rewrite Hur.
  transitivity (p;u;([a];q;s)^*;w;[!a]). hkat.
  assert (E: w;([a];q;s)^* ≡ ([a];q;s)^*;w) by (apply str_move; mrewrite Hqsw; hkat).
  mrewrite <-E. mrewrite Huw. mrewrite E. hkat.
Qed.

Lemma opti_3_4ii `{L: laws} n (a: tst n) (p q u w: X n n):
  u ≡ w;u ->
  u;w ≡ w ->
  w;p;q ≡ p;q;w ->
  w;[a] ≡ [a];w ->
  ([a];u;p;q)^*;[!a];u ≡ ([a];p;q)^*;[!a];u.
Proof.
  intros Hwu Huw Hpq Hw. rewrite Hwu at 1 2. transitivity (w;([a];u;(p;q;w))^*;[!a];u). hkat.
  rewrite <-Hpq. mrewrite Huw. mrewrite Hpq. rewrite <-lemma_1.
  rewrite (str_move (z:=[a];p;q)). rewrite Hwu at 2. hkat. mrewrite <-Hpq. hkat.
  mrewrite <-Hpq. rewrite <-Huw at 1. rewrite Hwu. mrewrite Huw. hkat.
  (* intros Hwu Huw Hpq Hw. rewrite Hwu at 1 2. transitivity (w;([a];u;(p;q;w))^*;[!a];u). hkat. *)
  (* rewrite <-Hpq. mrewrite Huw. mrewrite Hpq. transitivity ((w;[a];p;q)^*;[!a];(w;u)). hkat.  *)
  (* rewrite <-3dotA, lemma_1'', <-Hwu. ra. mrewrite <-Hpq. hkat. rewrite <-Hwu at 1. hkat.  *)
Qed.

(** ** 3.5 Induction variable elimination *)

Lemma opti_3_5 `{L: laws} n (a b c: tst n) (p q r: X n n):
  q ≡ q;[b] ->
  [b] ≡ [b];q ->
  [c];r ≡ [c];r;[b] ->
  [b];p ≡ [b];p;[c] ->
  [c];q ≡ [c];r ->
  q;([a];p;q)^* ≡ q;([a];p;r)^*.
Proof.
  intros Hq Hb Hr Hbp Hcq.
  assert (E: [b];p;q ≡ [b];p;r) by (rewrite Hbp; mrewrite Hcq; hkat).
  transitivity (q;([a];([b];p;q))^*;[b]). hkat. rewrite E. hkat.
Qed.

(** ** (3.6 and 3.7 are void) *)

(** ** 3.8 Loop unrolling *)

Lemma lemma_3 `{L: monoid.laws} `{Hl: BKA ≪ l} n (u: X n n): u^* ≡ (1+u);(u;u)^*.
Proof. ka. Qed.

Lemma opti_3_8 `{L: laws} n a (p: X n n):
  ([a];p)^*;[!a] ≡ ([a];p;([a];p+[!a]))^*;[!a].
Proof. kat. Qed.

(** ** 3.9 Redundant loads and stores *)

Lemma opti_3_9 `{L: laws} n a (p q: X n n):
  p ≡ p;[a] -> [a];q ≡ [a] -> p;q ≡ p.
Proof. intros Hp Hq. hkat. Qed.

(** ** 3.10 Array bounds check elimination *)

Lemma opti_3_10'i `{L: laws} n (a b: tst n) (u v p q s: X n n):
  u;[a] ≡ u ->
  [a ⊓ b];p ≡ p;[a ⊓ b] ->
  [a];([b];p;q;v) ≡ ([b];p;q;v);[a] ->
  u;([b];p;([a ⊓ b];q+[!(a ⊓ b)];s);v)^*;[!b] ≡ u;([b];p;q;v)^*;[!b].
Proof. hkat. Qed.

Lemma opti_3_10' `{L: laws} n (a b c: tst n) (u v p q s: X n n):
  a ⊓ b ≡ c ->
  u;[a] ≡ u ->
  [c];p ≡ p;[c] ->
  [a];([b];p;q;v) ≡ ([b];p;q;v);[a] ->
  u;([b];p;([c];q+[!c];s);v)^*;[!b] ≡ u;([b];p;q;v)^*;[!b].
Proof. hkat. Qed.

(** ** 3.11 Introduction of sentinels *)

Lemma opti_3_11 `{L: laws} n (a b c d: tst n) (u p q s t: X n n):
  u;[c] ≡ u ->
  [c];p ≡ p;[c] ->
  [c];q ≡ q;[c] ->
  p;[d] ≡ p ->
  [a];q;[d] ≡ [a];q ->
  c ⊓ d ⊓ b ≦ a ->
  u;p;([a ⊓ b];q)^*;[!(a ⊓ b)];([a];t+[!a];s) ≡ u;p;([b];q)^*;[!b];([a];t+[!a];s).
Proof. hkat. Qed.

(* note that it takes about 2s to solve this last one, thus
   illustrating the limits of our very basic algorithm *)