Require Import Monad.
Require Import Monoid.
Require Import Coq.Classes.EquivDec.

Class TypingContext (X A Ctx : Type) :=
  { singleton : X -> A -> Ctx
  ; validity : Ctx -> bool
  }.

(* partial typing context *)
Class PTypingContext (X A PCtx : Type) :=
  { singleton' : X -> A -> PCtx }.

Definition is_Some {Z} (x : option Z) := match x with
                        | Some _ => true
                        | None => false
                        end.

Instance PTypingCtx_to_TypingCtx X A PCtx `{PTypingContext X A PCtx}
    : TypingContext X A (option PCtx) :=
  { singleton := fun x a => Some (singleton' x a)
  ; validity := is_Some
  }.

Open Scope bool_scope.

Section bdec.

  Context X `{EqDec X eq}.

Lemma eq_bdec_true : forall x y, x = y -> x ==b y = true.
Proof. intros; cbv. destruct (H x y); congruence. Qed.

Lemma neq_bdec_false : forall x y, x <> y -> x ==b y = false.
Proof. intros; cbv. destruct (H x y); congruence. Qed.

Lemma eq_bdec_false : forall x y, x = y -> x <>b y = false.
Proof. intros; cbv. destruct (H x y); congruence. Qed.

Lemma neq_bdec_true : forall x y, x <> y -> x <>b y = true.
Proof. intros; cbv. destruct (H x y); congruence. Qed.

End bdec.

Class TypingContext_Laws X A Ctx `{EqDec X eq}
                                 `{PCM_Ctx : PCM_Laws Ctx}
                                 `{TypingContext X A Ctx} :=
  { validity3 : forall Γ1 Γ2 Γ3,
    validity (Γ1 ∙ Γ2 ∙ Γ3) =  validity (Γ1 ∙ Γ2)
                            && validity (Γ1 ∙ Γ3)
                            && validity (Γ2 ∙ Γ3)
  ; validity_reflection : forall Γ, validity Γ = false <-> Γ = ⊥
  ; validity_singleton : forall x a, validity (singleton x a) = true
  ; validity_top : validity ⊤ = true
  ; validity_singleton_merge : forall x y a b,
    validity (singleton x a ∙ singleton y b) = (x <>b y)
  }.

Class PTypingContext_Laws X A Ctx `{EqDec X eq}
                                  `{PPCM_Ctx : PPCM_Laws Ctx}
                                  `{PTypingContext X A Ctx} :=
  { pvalidity3 : forall Γ1 Γ2 Γ3,
        is_Some (do Γ ← m' Γ1 Γ2; m' Γ Γ3)
      = is_Some (m' Γ1 Γ2) && is_Some (m' Γ1 Γ3) && is_Some (m' Γ2 Γ3)
  ; validity_singleton_merge' : forall x y a b,
    m' (singleton' x a) (singleton' y b) = None <-> x = y
  }.

Instance PTypingContext_to_TypingContext_Laws X A Ctx `{PTypingContext_Laws X A Ctx}
                                            : TypingContext_Laws X A (option Ctx).
Proof.
  split.
  - destruct Γ1 as [Γ1 | ], Γ2 as [Γ2 | ], Γ3 as [Γ3 | ]; auto.
    * apply pvalidity3.
    * assert (merge_None : forall z, validity (Some z ∙ None) = false) by auto.
      rewrite merge_None.
      rewrite Bool.andb_false_r.
      simpl. destruct (m' Γ1 Γ2); auto.
  - destruct Γ; auto.
    * simpl. split; inversion 1.
    * simpl. split; auto.
  - intros; simpl; auto.
  - simpl; auto.
  - intros. simpl.
    unfold nequiv_decb, equiv_decb, equiv_dec.
    destruct (H x y) as [e | ne]; auto.
    * apply (validity_singleton_merge' x y a b) in e.
      rewrite e.  auto.
    * destruct (m' (singleton' x a) (singleton' y b)) as [ | z] eqn:eq'; auto.
      apply (validity_singleton_merge') in eq'. contradiction.
Qed.

Section TypingContexts.

Context X A Ctx `{TypingContext_Laws X A Ctx}.

Definition is_valid Γ := (validity Γ = true).

Lemma is_valid3 : forall Γ1 Γ2 Γ3,
    is_valid (Γ1 ∙ Γ2 ∙ Γ3) <->  is_valid (Γ1 ∙ Γ2)
                                 /\ is_valid (Γ1 ∙ Γ3)
                                 /\ is_valid (Γ2 ∙ Γ3).
Proof.
  unfold is_valid. intros.
  rewrite validity3. split; [intros eq | intros [eq1 [eq2 eq3] ] ].
  - destruct (validity (Γ1 ∙ Γ2)), (validity (Γ1 ∙ Γ3)), (validity (Γ2 ∙ Γ3)); auto.
  - rewrite eq1, eq2, eq3. auto.
Defined.

Lemma is_valid3_forward : forall Γ1 Γ2 Γ3,
      is_valid (Γ1 ∙ Γ2) ->
      is_valid (Γ1 ∙ Γ3) ->
      is_valid (Γ2 ∙ Γ3) ->
      is_valid (Γ1 ∙ Γ2 ∙ Γ3).
Proof. intros. apply is_valid3. auto. Qed.

Definition validity_reflection_true : forall Γ, validity Γ = true <-> Γ <> ⊥.
Proof.
  intros Γ. split; intros.
  - intros eq0. apply validity_reflection in eq0. rewrite eq0 in *.
    absurd (false = true); auto.
  - destruct (validity Γ) eqn:v_Γ; auto.
    apply validity_reflection in v_Γ. contradiction.
Qed.
Lemma singleton_is_valid : forall x a, is_valid (singleton x a).
Proof.
  apply validity_singleton.
Defined.

Lemma top_is_valid : is_valid ⊤.
Proof.
  apply validity_top.
Defined.
Lemma top_not_bottom : ⊤ <> ⊥.
Proof. apply validity_reflection_true. apply validity_top. Qed.

Lemma singleton_merge_is_valid : forall x y a b,
    is_valid (singleton x a ∙ singleton y b) <-> (x <> y).
Proof.
  intros. unfold is_valid.
  rewrite validity_singleton_merge.
  cbv. destruct (H x y); split; congruence.
Qed.

Lemma singleton_merge_invalid : forall x a b,
    ~ is_valid (singleton x a ∙ singleton x b).
Proof.
  intros. unfold is_valid.
  rewrite validity_singleton_merge.
  cbv. destruct (H x x); congruence.
Qed.

End TypingContexts.
About is_valid.
Arguments is_valid {X A Ctx TypingContext} : rename.

(***************************************************)
(* Tactics to solve goals of the form "is_valid Γ" *)
(***************************************************)

(* This is the naive tactic, but instead of working top down, we want to be a little smarter by working bottom up *)
Ltac validate_dumb :=
  repeat rewrite M_unit; repeat rewrite M_unit_l;
  repeat match goal with
  | [ H : is_valid ?Γ |- is_valid ?Γ ]              => exact H
  | [ |- is_valid ⊤ ]                               => apply top_is_valid
  | [ |- is_valid (singleton _ _) ]                 => eapply singleton_is_valid; auto
  | [ |- is_valid (singleton _ _ ∙ singleton _ _) ] => eapply singleton_merge_is_valid; auto
  | [ |- is_valid (_ ∙ _ ∙ _) ]                     => eapply is_valid3; auto
  | [ |- _ /\ _]                                    => split
  end.

Ltac introduce_valid_singletons :=
  repeat match goal with
  | [ |- context[singleton ?x ?a] ] =>
    assert (is_valid (singleton x a))
    by apply (@singleton_is_valid _ _ _ _ _ _ _ _);
    let Γ := fresh "Γ" in
    remember (singleton x a) as Γ (* so that we don't match this x again *)
  end; subst.

Ltac introduce_valid_term Γ :=
  match Γ with
  | _               => match goal with
                       [ H : is_valid Γ |- _ ] => idtac
                       end
  | ?Γ1 ∙ ?Γ2 ∙ ?Γ3 => let Γ12 := constr:(Γ1 ∙ Γ2) in
                       let Γ13 := constr:(Γ1 ∙ Γ3) in
                       let Γ23 := constr:(Γ2 ∙ Γ3) in
                       introduce_valid_term Γ12;
                       introduce_valid_term Γ13;
                       introduce_valid_term Γ23;
                       assert (is_valid Γ) by validate_dumb;
                       let Γ' := fresh "Γ" in
                       remember Γ as Γ'
  | _               => assert (is_valid Γ) by validate_dumb;
                       let Γ' := fresh "Γ" in
                       remember Γ as Γ'
  end; subst.

(*
Ltac validate :=
  repeat rewrite M_assoc;
  match goal with
  | [ |- is_valid ?Γ ] => introduce_valid_term Γ
  end; auto.
*)

(* This new tactic uses rewriting *)

Ltac eq_to_beq :=
  repeat match goal with
  | [H : ?x = ?y |- context[?x ==b ?y] ] =>
    rewrite (eq_bdec_true _ x y H)
  | [H : ?x = ?y |- context[?y ==b ?x] ] =>
    rewrite (eq_bdec_true _ y x (eq_sym H))
  | [H : ?x = ?y |- context[?x <>b ?y] ] =>
    rewrite (eq_bdec_false _ x y H)
  | [H : ?x = ?y |- context[?y <>b ?x] ] =>
    rewrite (eq_bdec_false _ y x (eq_sym H))
  | [H : ?x <> ?y |- context[?x <>b ?y] ] =>
    rewrite (neq_bdec_true _ x y H)
  | [H : ?x <> ?y |- context[?y <>b ?x] ] =>
    rewrite (neq_bdec_true _ y x (not_eq_sym H))
  | [ H : ?x <> ?y |- context[?x ==b ?y] ] =>
    rewrite (neq_bdec_false _ x y H)
  | [ H : ?x <> ?y |- context[?y ==b ?x] ] =>
    rewrite (neq_bdec_false _ y x (not_eq_sym H))
  end.

Ltac validate :=
  intros;
  unfold is_valid in *;
  repeat rewrite M_assoc;
  repeat rewrite M_unit;
  repeat rewrite validity3;
  repeat rewrite validity_top;
  repeat rewrite validity_singleton;
  repeat rewrite validity_singleton_merge;
  eq_to_beq; auto.

Section Tests.

Context X A Ctx `{TypingContext_Laws X A Ctx}.

Lemma test3 : forall x y z a b c, x <> y -> y <> z -> x <> z ->
             is_valid (singleton x a ∙ singleton y b ∙ singleton z c).
Proof.
  validate.
Qed.

Lemma test4 : forall x y z w a b c d, x <> y -> y <> z -> x <> z -> x <> w -> y <> w -> z <> w ->
             is_valid (singleton x a ∙ singleton y b ∙ singleton z c ∙ singleton w d).
Proof.
  validate.
Qed.

End Tests.

(* In the end, solve goals of this form *)
(* The unicode symbol is \uplus *)
Notation "Γ1 ⊎ Γ2 == Γ" := (Γ = Γ1 ∙ Γ2 /\ is_valid Γ) (at level 75).

Ltac solve_ctx :=
  repeat match goal with
  | [ |- _ /\ _ ] => split
  | [ |- is_valid ?Γ ] => validate
  | [ |- _ = _ ] => monoid
  end.


(** * Named Representation of Gallina *)
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.Notations.
Require Import Crypto.Util.LetIn.

Local Open Scope ctype_scope.
Local Open Scope expr_scope.
Delimit Scope nexpr_scope with nexpr.
Module Export Named.
  Section language.
    Context (base_type_code : Type)
            (interp_base_type : base_type_code -> Type)
            (op : flat_type base_type_code -> flat_type base_type_code -> Type)
            (Name : Type).

    Local Notation flat_type := (flat_type base_type_code).
    Local Notation type := (type base_type_code).
    Local Notation interp_type := (interp_type interp_base_type).
    Local Notation interp_flat_type_gen := interp_flat_type.
    Local Notation interp_flat_type := (interp_flat_type interp_base_type).

    Inductive exprf : flat_type -> Type :=
    | TT : exprf Unit
    | Var {t : base_type_code} : Name -> exprf (Tbase t)
    | Op {t1 tR} : op t1 tR -> exprf t1 -> exprf tR
    | LetIn : forall {tx}, interp_flat_type_gen (fun _ => Name) tx -> exprf tx -> forall {tC}, exprf tC -> exprf tC
    | Pair : forall {t1}, exprf t1 -> forall {t2}, exprf t2 -> exprf (Prod t1 t2).
    Bind Scope nexpr_scope with exprf.
    Inductive expr : type -> Type :=
    | Abs {src dst} : interp_flat_type_gen (fun _ => Name) src -> exprf dst -> expr (Arrow src dst).
    Bind Scope nexpr_scope with expr.
    Definition Abs_name {t} (e : expr t) : interp_flat_type_gen (fun _ => Name) (domain t)
      := match e with Abs _ _ n f => n end.
    Definition invert_Abs {t} (e : expr t) : exprf (codomain t)
      := match e with Abs _ _ n f => f end.

    Section with_val_context.
      Context (Context : Context Name interp_base_type)
              (interp_op : forall src dst, op src dst -> interp_flat_type src -> interp_flat_type dst).

      Fixpoint interpf
               {t} (ctx : Context) (e : exprf t)
        : option (interp_flat_type t)
        := match e in exprf t return option (interp_flat_type t) with
           | Var t' x => lookupb t' ctx x
           | TT => Some tt
           | Pair _ ex _ ey
             => match @interpf _ ctx ex, @interpf _ ctx ey with
                | Some xv, Some yv => Some (xv, yv)%core
                | None, _ | _, None => None
                end
           | Op _ _ opc args
             => option_map (@interp_op _ _ opc) (@interpf _ ctx args)
           | LetIn _ n ex _ eC
             => match @interpf _ ctx ex with
                | Some xv
                  => dlet x := xv in
                     @interpf _ (extend ctx n x) eC
                | None => None
                end
           end.

      Definition interp {t} (ctx : Context) (e : expr t)
        : interp_flat_type (domain t) -> option (interp_flat_type (codomain t))
        := fun v => @interpf _ (extend ctx (Abs_name e) v) (invert_Abs e).

      Definition Interp {t} (e : expr t)
        : interp_flat_type (domain t) -> option (interp_flat_type (codomain t))
        := interp empty e.
    End with_val_context.
  End language.
End Named.

Global Arguments TT {_ _ _}.
Global Arguments Var {_ _ _ _} _.
Global Arguments Op {_ _ _ _ _} _ _.
Global Arguments LetIn {_ _ _} _ _ _ {_} _.
Global Arguments Pair {_ _ _ _} _ {_} _.
Global Arguments Abs {_ _ _ _ _} _ _.
Global Arguments invert_Abs {_ _ _ _} _.
Global Arguments Abs_name {_ _ _ _} _.
Global Arguments interpf {_ _ _ _ _ interp_op t ctx} _.
Global Arguments interp {_ _ _ _ _ interp_op t ctx} _ _.
Global Arguments Interp {_ _ _ _ _ interp_op t} _ _.

Notation "'nlet' x := A 'in' b" := (LetIn _ x A%nexpr b%nexpr) : nexpr_scope.
Notation "'nlet' x : tx := A 'in' b" := (LetIn tx%ctype x%core A%nexpr b%nexpr) : nexpr_scope.
Notation "'λn'  x .. y , t" := (Abs x .. (Abs y t%nexpr) .. ) : nexpr_scope.
Notation "( x , y , .. , z )" := (Pair .. (Pair x%nexpr y%nexpr) .. z%nexpr) : nexpr_scope.
Notation "()" := TT : nexpr_scope.


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List.
Import ListNotations.
Require Import Alphabet.
Require Grammar Automaton Interpreter.
From Coq.ssr Require Import ssreflect.

Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A).

(** * Correctness of the interpreter **)

(** We prove that, in any case, if the interpreter accepts returning a
    semantic value, then this is a semantic value of the input **)

Section Init.

Variable init:initstate.

(** [word_has_stack_semantics] relates a word with a stack, stating that the
    word is a concatenation of words that have the semantic values stored in
    the stack. **)
Inductive word_has_stack_semantics:
  forall (word:list token) (stack:stack), Prop :=
  | Nil_stack_whss: word_has_stack_semantics [] []
  | Cons_stack_whss:
    forall (wordq:list token) (stackq:stack),
      word_has_stack_semantics wordq stackq ->

    forall (wordt:list token) (s:noninitstate)
           (pt:parse_tree (last_symb_of_non_init_state s) wordt),

    word_has_stack_semantics
       (wordq++wordt) (existT noninitstate_type s (pt_sem pt)::stackq).

(** [pop] preserves the invariant **)
Lemma pop_spec_ptl A symbols_to_pop action word_stk stk (res : A) stk' :
  pop_spec symbols_to_pop stk action stk' res ->
  word_has_stack_semantics word_stk stk ->
  exists word_stk' word_res (ptl:parse_tree_list symbols_to_pop word_res),
    (word_stk' ++ word_res = word_stk)%list /\
    word_has_stack_semantics word_stk' stk' /\
    ptl_sem ptl action = res.
Proof.
  intros Hspec. revert word_stk.
  induction Hspec as [stk sem|symbols_to_pop st stk action sem stk' res Hspec IH];
    intros word_stk Hword_stk.
  - exists word_stk, [], Nil_ptl. rewrite -app_nil_end. eauto.
  - inversion Hword_stk. subst_existT.
    edestruct IH as (word_stk' & word_res & ptl & ? & Hword_stk'' & ?); [eassumption|].
    subst. eexists word_stk', (word_res ++ _)%list, (Cons_ptl ptl _).
    split; [|split]=>//. rewrite app_assoc //.
Qed.

(** [reduce_step] preserves the invariant **)
Lemma reduce_step_invariant (stk:stack) (prod:production) Hv Hi word buffer :
  word_has_stack_semantics word stk ->
  match reduce_step init stk prod buffer Hv Hi with
  | Accept_sr sem buffer_new =>
    exists pt : parse_tree (NT (start_nt init)) word,
    buffer = buffer_new /\ pt_sem pt = sem
  | Progress_sr stk' buffer_new =>
    buffer = buffer_new /\ word_has_stack_semantics word stk'
  | Fail_sr => True
  end.
Proof.
  intros Hword_stk. unfold reduce_step.
  match goal with
  | |- context [pop_state_valid init ?stp stk ?x1 ?x2 ?x3 ?x4 ?x5] =>
    generalize (pop_state_valid init stp stk x1 x2 x3 x4 x5)
  end.
  destruct pop as [stk' sem] eqn:Hpop=>/= Hv'.
  apply pop_spec_ok in Hpop. apply pop_spec_ptl with (word_stk := word) in Hpop=>//.
  destruct Hpop as (word1 & word2 & ptl & <- & Hword1 & <-).
  generalize (reduce_step_subproof1 init stk prod Hv stk' (fun _ : True => Hv')).
  destruct goto_table as [[st' EQ]|].
  - intros _. split=>//.
    change (ptl_sem ptl (prod_action prod)) with (pt_sem (Non_terminal_pt prod ptl)).
    generalize (Non_terminal_pt prod ptl). rewrite ->EQ. intros pt. by constructor.
  - intros Hstk'. destruct Hword1; [|by destruct Hstk'].
    generalize (reduce_step_subproof0 init prod [] (fun _ : True => Hstk')).
    simpl in Hstk'. rewrite -Hstk' // => EQ. rewrite cast_eq.
    exists (Non_terminal_pt prod ptl). by split.
Qed.

(** [step] preserves the invariant **)
Lemma step_invariant stk word buffer safe Hi :
  word_has_stack_semantics word stk ->
  match step safe init stk buffer Hi with
  | Accept_sr sem buffer_new =>
    exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
      (word ++ buffer = word_new ++ buffer_new)%buf /\
      pt_sem pt = sem
  | Progress_sr stk_new buffer_new =>
    exists word_new,
      (word ++ buffer = word_new ++ buffer_new)%buf /\
      word_has_stack_semantics word_new stk_new
  | Fail_sr => True
  end.
Proof.
  intros Hword_stk. unfold step.
  generalize (reduce_ok safe (state_of_stack init stk)).
  destruct action_table as [prod|awt].
  - intros Hv.
    apply (reduce_step_invariant stk prod (fun _ => Hv) Hi word buffer) in Hword_stk.
    destruct reduce_step=>//.
    + destruct Hword_stk as (pt & <- & <-); eauto.
    + destruct Hword_stk as [<- ?]; eauto.
  - destruct buffer as [tok buffer]=>/=.
    move=> /(_ (token_term tok)) Hv. destruct (awt (token_term tok)) as [st EQ|prod|]=>//.
    + eexists _. split; [by apply app_buf_assoc with (l2 := [_])|].
      change (token_sem tok) with (pt_sem (Terminal_pt tok)).
      generalize (Terminal_pt tok). generalize [tok].
      rewrite -> EQ=>word' pt /=. by constructor.
    + apply (reduce_step_invariant stk prod (fun _ => Hv) Hi word (tok::buffer))
        in Hword_stk.
      destruct reduce_step=>//.
      * destruct Hword_stk as (pt & <- & <-); eauto.
      * destruct Hword_stk as [<- ?]; eauto.
Qed.

(** [step] preserves the invariant **)
Lemma parse_fix_invariant stk word buffer safe log_n_steps Hi :
  word_has_stack_semantics word stk ->
  match proj1_sig (parse_fix safe init stk buffer log_n_steps Hi) with
  | Accept_sr sem buffer_new =>
    exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
      (word ++ buffer = word_new ++ buffer_new)%buf /\
      pt_sem pt = sem
  | Progress_sr stk_new buffer_new =>
    exists word_new,
      (word ++ buffer = word_new ++ buffer_new)%buf /\
      word_has_stack_semantics word_new stk_new
  | Fail_sr => True
  end.
Proof.
  revert stk word buffer Hi.
  induction log_n_steps as [|log_n_steps IH]=>/= stk word buffer Hi Hstk;
    [by apply step_invariant|].
  assert (IH1 := IH stk word buffer Hi Hstk).
  destruct parse_fix as [[] Hi']=>/=; try by apply IH1.
  destruct IH1 as (word' & -> & Hstk')=>//. by apply IH.
Qed.

(** The interpreter is correct : if it returns a semantic value, then the input
    word has this semantic value.
**)
Theorem parse_correct safe buffer log_n_steps:
  match parse safe init buffer log_n_steps with
  | Parsed_pr sem buffer_new =>
    exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
      buffer = (word_new ++ buffer_new)%buf /\
      pt_sem pt = sem
  | _ => True
  end.
Proof.
  unfold parse.
  assert (Hparse := parse_fix_invariant [] [] buffer safe log_n_steps
                                        (parse_subproof init)).
  destruct proj1_sig=>//. apply Hparse. constructor.
Qed.

End Init.

End Make.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.metrics.IR_CPMSpace.

Section equivalent.
(**
** Equivalent Pseudo Metric Spaces
*)
(**
We say that two pseudo metric spaces are equivalent, when there exists a
bijective, structure-preserving function between them.
*)

Definition equivalent_psmetric (X : CSetoid) (d0 d1 : CSetoid_bin_fun X X IR)
  : CProp :=
  (is_CPsMetricSpace X d0 and is_CPsMetricSpace X d1)
  and {n : nat | forall x y : X, d0 x y[<=]nring (S n)[*]d1 x y}
      and {n : nat | forall x y : X, d1 x y[<=]nring (S n)[*]d0 x y}.

Definition isopsmetry (X Y : CPsMetricSpace) (f : CSetoid_fun X Y) :=
  bijective f
  and equivalent_psmetric X (cms_d (c:=X))
        (compose_CSetoid_bin_un_fun X Y IR (cms_d (c:=Y)) f).

Arguments isopsmetry [X Y].

Lemma isopsmetry_imp_bij :
 forall (X Y : CPsMetricSpace) (f : CSetoid_fun X Y),
 isopsmetry f -> bijective f.
Proof.
 intros X Y f H.
 unfold isopsmetry in H.
 elim H.
 intuition.
Qed.

Lemma isopsmetry_imp_lipschitz :
 forall (X Y : CPsMetricSpace) (f : CSetoid_fun X Y),
 isopsmetry f -> lipschitz' f.
Proof.
 intros X Y f.
 unfold isopsmetry in |- *.
 unfold equivalent_psmetric in |- *.
 intro H.
 elim H. clear H.
 intros H0 H1.
 elim H1. clear H1.
 intros H10 H11.
 elim H11. clear H11.
 intros H110 H111.
 unfold lipschitz' in |- *.
 elim H111. clear H111.
 simpl in |- *.
 intros n H111'.
 exists (S n).
 simpl in |- *.
 exact H111'.
Qed.

Lemma id_is_isopsmetry : forall X : CPsMetricSpace, isopsmetry (id_un_op X).
Proof.
 intro X.
 unfold isopsmetry in |- *.
 split.
  apply id_is_bij.
 unfold equivalent_psmetric in |- *.
 simpl in |- *.
 unfold id_un_op in |- *.
 split.
  split.
   apply CPsMetricSpace_is_CPsMetricSpace.
  apply Build_is_CPsMetricSpace.
     unfold com in |- *.
     intros x y.
     simpl in |- *.
     apply ax_d_com.
     apply CPsMetricSpace_is_CPsMetricSpace.
    unfold nneg in |- *.
    simpl in |- *.
    apply ax_d_nneg.
    apply CPsMetricSpace_is_CPsMetricSpace.
   unfold pos_imp_ap in |- *.
   simpl in |- *.
   apply ax_d_pos_imp_ap.
   apply CPsMetricSpace_is_CPsMetricSpace.
  unfold tri_ineq in |- *.
  simpl in |- *.
  apply ax_d_tri_ineq.
  apply CPsMetricSpace_is_CPsMetricSpace.
 split.
  exists 0.
  intros x y.
  simpl in |- *.
  astepr (OneR[*](x[-d]y)).
  astepr (x[-d]y).
  apply leEq_reflexive.
 exists 0.
 intros x y.
 simpl in |- *.
 astepr (OneR[*](x[-d]y)).
 astepr (x[-d]y).
 apply leEq_reflexive.
Qed.

Lemma comp_resp_isopsmetry :
 forall (X Y Z : CPsMetricSpace) (f : CSetoid_fun X Y) (g : CSetoid_fun Y Z),
 isopsmetry f -> isopsmetry g -> isopsmetry (compose_CSetoid_fun X Y Z f g).
Proof.
 intros X Y Z f g.
 unfold isopsmetry in |- *.
 intros H0 H1.
 elim H0.
 intros H00 H01.
 elim H1.
 intros H10 H11.
 split.
  apply comp_resp_bij.
   exact H00.
  exact H10.
 unfold equivalent_psmetric in |- *.
 split.
  split.
   apply CPsMetricSpace_is_CPsMetricSpace.
  unfold equivalent_psmetric in H01.
  elim H01.
  intros H010 H011.
  elim H010.
  intros H0100 H0101.
  elim H11.
  intros H110 H111.
  elim H110.
  intros H1100 H1101.
  apply Build_is_CPsMetricSpace.
     unfold com in |- *.
     simpl in |- *.
     intros x y.
     elim H1101.
     intros.
     generalize ax_d_com.
     unfold com in |- *.
     simpl in |- *.
     intro H2.
     apply H2.
    unfold nneg in |- *.
    intros x y.
    simpl in |- *.
    elim H1101.
    intros.
    generalize ax_d_nneg.
    unfold nneg in |- *.
    simpl in |- *.
    intro H2.
    apply H2.
   elim H1101.
   intros.
   generalize ax_d_pos_imp_ap.
   unfold pos_imp_ap in |- *.
   simpl in |- *.
   intros H2 x y H3.
   set (H5 := csf_strext X Y f) in *.
   generalize H5.
   unfold fun_strext in |- *.
   intro H6.
   apply H6.
   auto.
  unfold tri_ineq in |- *.
  simpl in |- *.
  intros x y z.
  elim H1101.
  intros.
  generalize ax_d_tri_ineq.
  unfold tri_ineq in |- *.
  simpl in |- *.
  intro H2.
  apply H2.
 split.
  unfold equivalent_psmetric in H01.
  elim H01.
  intros H010 H011.
  elim H011.
  intros H0110 H0111.
  unfold equivalent_psmetric in H11.
  elim H11.
  intros H110 H111.
  elim H111.
  intros H1110 H1111.
  elim H0110.
  simpl in |- *.
  intros n H0110'.
  elim H1110.
  simpl in |- *.
  intros m H1110'.
  exists (S m * S n).
  intros x y.
  apply leEq_transitive with ((nring n[+][1])[*](f x[-d]f y)).
   apply H0110'.
  apply leEq_transitive with ((nring n[+][1])[*](nring m[+][1])[*](g (f x)[-d]g (f y))).
   astepr ((nring n[+][1])[*]((nring m[+][1])[*](g (f x)[-d]g (f y)))).
   apply mult_resp_leEq_lft.
    apply H1110'.
   apply less_leEq.
   astepr (nring (R:=IR) (S n)).
   apply pos_nring_S.
  apply mult_resp_leEq_rht.
   apply leEq_transitive with (nring (R:=IR) (S m * S n)).
    apply eq_imp_leEq.
    astepl (nring (R:=IR) (S n)[*](nring m[+][1])).
    astepl (nring (R:=IR) (S n)[*]nring (S m)).
    astepl (nring (R:=IR) (S m)[*]nring (S n)).
    astepl (nring (R:=IR) (S m * S n)).
    apply eq_reflexive.
   astepr (nring (R:=IR) (S (S m * S n))).
   apply less_leEq.
   apply nring_less_succ.
  apply ax_d_nneg.
  apply CPsMetricSpace_is_CPsMetricSpace.
 unfold equivalent_psmetric in H01.
 elim H01.
 intros H010 H011.
 elim H011.
 intros H0110 H0111.
 unfold equivalent_psmetric in H11.
 elim H11.
 intros H110 H111.
 elim H111.
 intros H1110 H1111.
 elim H0111.
 simpl in |- *.
 intros n H0111'.
 elim H1111.
 simpl in |- *.
 intros m H1111'.
 exists (S m * S n).
 intros x y.
 apply leEq_transitive with (nring (R:=IR) (S m)[*](f x[-d]f y)).
  apply H1111'.
 apply leEq_transitive with (nring (S m)[*]nring (S n)[*](x[-d]y)).
  astepr (nring (S m)[*](nring (S n)[*](x[-d]y))).
  apply mult_resp_leEq_lft.
   apply H0111'.
  apply less_leEq.
  apply pos_nring_S.
 apply mult_resp_leEq_rht.
  apply leEq_transitive with (nring (R:=IR) (S m * S n)).
   apply eq_imp_leEq.
   astepl (nring (R:=IR) (S m * S n)).
   apply eq_reflexive.
  astepr (nring (R:=IR) (S (S m * S n))).
  apply less_leEq.
  apply nring_less_succ.
 apply ax_d_nneg.
 apply CPsMetricSpace_is_CPsMetricSpace.
Qed.

Lemma inv_isopsmetry :
 forall (X Y : CPsMetricSpace) (f : CSetoid_fun X Y) (H : isopsmetry f),
 isopsmetry (Inv f (isopsmetry_imp_bij X Y f H)).
Proof.
 intros X Y f H.
 unfold isopsmetry in |- *.
 split.
  apply Inv_bij.
 unfold isopsmetry in H.
 unfold equivalent_psmetric in H.
 elim H.
 intros.
 elim b.
 intros.
 elim a0.
 intros.
 elim b0.
 intros.
 unfold equivalent_psmetric in |- *.
 split.
  split.
   apply CPsMetricSpace_is_CPsMetricSpace.
  apply Build_is_CPsMetricSpace.
     unfold com in |- *.
     intros x y.
     unfold Inv in |- *.
     simpl in |- *.
     apply ax_d_com.
     exact a1.
    unfold nneg in |- *.
    intros x y.
    unfold Inv in |- *.
    simpl in |- *.
    apply ax_d_nneg.
    exact a1.
   unfold pos_imp_ap in |- *.
   intros x y.
   unfold Inv in |- *.
   simpl in |- *.
   intro H7.
   set (H6 := inv_strext) in *.
   set (H5 := H6 X Y f (isopsmetry_imp_bij X Y f (a, ((a1, b1), (a2, b2))))) in *.
   generalize H5.
   unfold fun_strext in |- *.
   intros H4.
   apply H4.
   set (H8 := ax_d_pos_imp_ap) in *.
   set (H9 := H8 X (cms_d (c:=X)) a1) in *.
   generalize H9.
   unfold pos_imp_ap in |- *.
   intro H10.
   apply H10.
   apply H7.
  unfold tri_ineq in |- *.
  unfold Inv in |- *.
  simpl in |- *.
  set (H3 := ax_d_tri_ineq) in *.
  set (H4 := H3 X (cms_d (c:=X)) a1) in *.
  generalize H4.
  unfold tri_ineq in |- *.
  intro H5.
  intros x y z.
  apply H5.
 split.
  elim b2.
  simpl in |- *.
  intros m P.
  exists m.
  intros y0 y1.
  elim a.
  intros.
  unfold surjective in b3.
  elim (b3 y0).
  intros x0 b4.
  elim (b3 y1).
  intros x1 b5.
  astepl (f x0[-d]y1).
  astepl (f x0[-d]f x1).
  apply leEq_transitive with (nring (S m)[*](x0[-d]x1)).
   simpl in |- *.
   apply P.
  simpl in |- *.
  apply eq_imp_leEq.
  apply mult_wdr.
  set (H4 := csbf_wd) in *.
  set (H5 := H4 X X IR (cms_d (c:=X))) in *.
  generalize H5.
  unfold bin_fun_wd in |- *.
  intro H6.
  apply H6.
   cut (invfun f (isopsmetry_imp_bij X Y f ((a3, b3),
     (pair (a1, b1) (pair a2 (existT (fun n : nat =>
       forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) (f x0)[=] invfun f
         (isopsmetry_imp_bij X Y f (pair (a3, b3)
           (pair (a1, b1) (pair a2 (existT (fun n : nat =>
             forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) y0).
    intros.
    astepr (invfun f (isopsmetry_imp_bij X Y f (pair (a3, b3)
      (pair (a1, b1) (pair a2 (existT (fun n : nat =>
        forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) (f x0)).
    apply eq_symmetric.
    apply inv2.
   set (H10 := csf_wd) in *.
   set (H7 := H10 Y X (Inv f (isopsmetry_imp_bij X Y f (pair (a3, b3)
     (pair (a1, b1) (pair a2 (existT (fun n : nat => forall x y : X,
       f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))))) in *.
   generalize H7.
   unfold fun_wd in |- *.
   unfold Inv in |- *.
   simpl in |- *.
   intro H8.
   apply H8.
   exact b4.
  cut (invfun f (isopsmetry_imp_bij X Y f (pair (a3, b3)
    (pair (a1, b1) (pair a2 (existT (fun n : nat =>
      forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) (f x1)[=] invfun f
        (isopsmetry_imp_bij X Y f (pair (a3, b3)
          (pair (a1, b1) (pair a2 (existT (fun n : nat =>
            forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) y1).
   intros.
   astepr (invfun f (isopsmetry_imp_bij X Y f (pair (a3, b3)
     (pair (a1, b1) (pair a2 (existT (fun n : nat =>
       forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) (f x1)).
   apply eq_symmetric.
   apply inv2.
  set (H10 := csf_wd) in *.
  set (H7 := H10 Y X (Inv f (isopsmetry_imp_bij X Y f (pair (a3, b3)
    (pair (a1, b1) (pair a2 (existT (fun n : nat => forall x y : X,
      f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))))) in *.
  generalize H7.
  unfold fun_wd in |- *.
  unfold Inv in |- *.
  simpl in |- *.
  intro H8.
  apply H8.
  exact b5.
 elim a2.
 simpl in |- *.
 intros m P.
 exists m.
 intros y0 y1.
 elim a.
 intros.
 unfold surjective in b3.
 elim (b3 y0).
 intros x0 b4.
 elim (b3 y1).
 intros x1 b5.
 astepr ((nring m[+][1])[*](f x0[-d]f x1)).
 apply leEq_transitive with (x0[-d]x1).
  2: apply P.
 apply eq_imp_leEq.
 set (H4 := csbf_wd) in *.
 set (H5 := H4 X X IR (cms_d (c:=X))) in *.
 generalize H5.
 unfold bin_fun_wd in |- *.
 intro H6.
 apply H6.
  cut (invfun f (isopsmetry_imp_bij X Y f (pair (pair a3 b3)
    (pair (pair a1 b1) (pair (existT (fun n : nat =>
      forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) y0[=] invfun f
        (isopsmetry_imp_bij X Y f (pair (pair a3 b3)
          (pair (pair a1 b1) (pair (existT (fun n : nat =>
            forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) (f x0)).
   intros.
   astepl (invfun f (isopsmetry_imp_bij X Y f (pair (pair a3 b3)
     (pair (pair a1 b1) (pair (existT (fun n : nat =>
       forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) (f x0)).
   apply inv2.
  set (H10 := csf_wd) in *.
  set (H7 := H10 Y X (Inv f (isopsmetry_imp_bij X Y f (pair (pair a3 b3)
    (pair (pair a1 b1) (pair (existT (fun n : nat => forall x y : X,
      x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))))) in *.
  generalize H7.
  unfold fun_wd in |- *.
  unfold Inv in |- *.
  simpl in |- *.
  intro H8.
  apply H8.
  apply eq_symmetric.
  exact b4.
 cut (invfun f (isopsmetry_imp_bij X Y f (pair (pair a3 b3)
   (pair (pair a1 b1) (pair (existT (fun n : nat =>
     forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) y1[=] invfun f
       (isopsmetry_imp_bij X Y f (pair (pair a3 b3)
         (pair (pair a1 b1) (pair (existT (fun n : nat =>
           forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) (f x1)).
  intros.
  astepl (invfun f (isopsmetry_imp_bij X Y f (pair (pair a3 b3)
    (pair (pair a1 b1) (pair (existT (fun n : nat =>
      forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) (f x1)).
  apply inv2.
 set (H10 := csf_wd) in *.
 set (H7 := H10 Y X (Inv f (isopsmetry_imp_bij X Y f (pair (pair a3 b3)
   (pair (pair a1 b1) (pair (existT (fun n : nat => forall x y : X,
     x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))))) in *.
 generalize H7.
 unfold fun_wd in |- *.
 unfold Inv in |- *.
 simpl in |- *.
 intro H8.
 apply H8.
 apply eq_symmetric.
 exact b5.
Qed.

Definition MSequivalent (X Y : CPsMetricSpace) :=
  {f : CSetoid_fun X Y | isopsmetry f}.

(**
Not all pseudo metric spaces are equivalent:
*)

Lemma MSequivalent_discr :
 Not (MSequivalent IR_as_CPsMetricSpace (zf_as_CPsMetricSpace IR)).
Proof.
 red in |- *.
 unfold MSequivalent in |- *.
 unfold isopsmetry in |- *.
 unfold equivalent_psmetric in |- *.
 intros H0.
 elim H0.
 intros f H0'.
 elim H0'.
 intros H1 H2.
 elim H2.
 intros H3 H4.
 elim H4.
 intros H5 H6.
 elim H5.
 intros n.
 simpl in |- *.
 unfold zero_fun in |- *.
 unfold dIR in |- *.
 intro H7.
 cut (OneR[<=][0]).
  rewrite -> leEq_def in |- *.
  intro H8.
  set (H9 := H8 (pos_one IR)) in *.
  exact H9.
 astepr ((nring (R:=IR) n[+][1])[*][0]).
 astepl (ABSIR ([1][-][0])).
  apply H7.
 unfold ABSIR in |- *.
 astepl (Max [--]([1][-][0]) ([1][-][0])).
  astepl (Max [--]([1][-][0]) [1]).
  apply leEq_imp_Max_is_rht.
  astepl ([--]OneR).
  astepl (ZeroR[-][1]).
  apply shift_minus_leEq.
  astepr (Two:IR).
  apply less_leEq.
  apply pos_two.
 apply Max_comm.
Qed.

End equivalent.