Require Export Suboccurrences.
Import ListNotations Arith Bool.

Local Open Scope eqb_scope.

(** STRUCTURE *)

Inductive Tree: Type :=
  | leaf: Occurrence -> Tree
  | unary: Tree -> Occurrence -> Tree
  | binary: Tree -> Tree -> Occurrence -> Tree.

Instance tree_eqb: Eqb Tree :=
  fix tree_eqb T1 T2 :=
  match T1, T2 with
  | leaf o1, leaf o2 => (o1 =? o2)
  | unary T1 o1, unary T2 o2 => (o1 =? o2) &&& (tree_eqb T1 T2)
  | binary T1 T1' o1, binary T2 T2' o2 => (o1 =? o2) &&& (tree_eqb T1 T2) &&& (tree_eqb T1' T2')
  | _, _ => false
  end.

Definition getOccurrence (T:Tree): Occurrence :=
  match T with
  | leaf o => o
  | unary _ o => o
  | binary _ _ o => o
  end.

(* This property juste traduces the fact that:
      -> Addresses are well connected between nodes.
      -> Binary nodes are only bound to Op formulas
      -> Unary nodes are only bound to Quant formulas
      -> Leaf nodes are only bound to Nullary formulas
 *)

Inductive ValidTree:Tree -> Prop :=
  | VLeaf (F:formula)(A:address): In F [⊤;⊥;ø; !] \/ (exists v, F = Var v) -> ValidTree (leaf { F, A })
  | VUnary (o:Occurrence)(T:Tree): ValidTree T
                                                                    -> (o ⇀ (getOccurrence T))
                                                                    -> ValidTree (unary T o)
  | VBinary (o:Occurrence)(T1 T2: Tree): ValidTree T1 -> ValidTree T2
                                                                                -> (o ⇀ (getOccurrence T1))
                                                                                -> (o ⇀ (getOccurrence T2))
                                                                                -> ValidTree (binary T1 T2 o)
  .

Definition Psi: formula := ν(µ((%0 # %1) & ø ))
.

Definition TreeExample: Tree :=
  unary (
                unary (
                               binary (
                                              binary (
                                                              leaf { (%0), [l;l;i;i] } )
                                                          (
                                                              leaf { (%1), [r;l;i;i] } )
                                               { (%0 # %1)%form, [l;i;i] }
                                               )
                                              (
                                              leaf { ø, [r;i;i] }
                                              )
                               { ((%0 # %1) & ø )%form, [i;i] }
                               )
                { (µ((%0 # %1) & ø ))%form, [i] }
                )
  { Psi,[] }.

(*                                       -> Y
                                -> #
                                          -> X
nu X -> mu Y -> &
                                -> ø

*)

Theorem ValidExample: ValidTree TreeExample.
Proof.
  constructor; constructor; constructor; constructor; constructor; intuition.
  - right; exists (BVar 0); reflexivity.
  - right; exists (BVar 1); reflexivity.
Qed.

(** THE TREE OF A FORMULA *)

Fixpoint formulaTreeRec (F:formula)(A:address): Tree:=
  match F with
  | ⊤ | ⊥ | ø | ! | Var _ => leaf { F, A }
  | Quant q F' => unary (formulaTreeRec F' (i::A)) { F, A }
  | Op o F1 F2 => binary (formulaTreeRec F1 (l::A)) (formulaTreeRec F2 (r::A)) { F, A }
  end.

Definition formulaTree (F:formula) := formulaTreeRec F [].

Definition TreeExampleBis := formulaTree Psi.

Compute TreeExampleBis =? TreeExample.

(** COMPUTING THE ACCESS TO BOUND VARIABLES DEFINITIONS **)

(* RETURNS THE LIST(ADDRESS*FORMULA) OF ALL BINDING OCCURRENCES IN [T] *)
Fixpoint BindingOccurrences (T:Tree) : list (address*formula) :=
  match T with
  | leaf _ => []
  | unary T' o => let '{ F, A }:=o in ( BindingOccurrences T' ++ [(A,F)] )
  | binary T1 T2 _ => BindingOccurrences T1 ++ BindingOccurrences T2
  end.

(* GET ALL SUB-ADDRESSES OF [a0] IN [D] *)
Fixpoint filter_sub_addresses (a0:address)(D:list(address*formula)) : list(address*formula) :=
  match D with
    | (a,F)::D' => if (sub_addressb a a0) then (a,F)::(filter_sub_addresses a0 D')
                                                              else filter_sub_addresses a0 D'
    | nil        => []
    end.

(* GET ALL SUB-ADDRESSES OF [a0] IN T's OCCURRENCE ADDRESSES *)
Definition tree_filter (a0:address)(T:Tree) : list(address*formula) := filter_sub_addresses a0 (BindingOccurrences T).

Local Open Scope string_scope.

Definition Example_sub_filtering : formula := µ (//"X" # ν(%1 & (%2 & !))).

Definition Tree_Prev := formulaTree Example_sub_filtering.

Compute Tree_Prev.

Compute tree_filter [l; r; i; r; i] Tree_Prev.

(* GET THE DEFINITION OF [%n] KNOWING ITS ADDRESS [a] *)
Definition getDef (a:address)(n:nat)(T:Tree) := nth_error (tree_filter a T) (pred n).

Compute getDef [l; i; r; i] 1 Tree_Prev.
Compute getDef [l; r; i; r; i] 2 Tree_Prev.


From S5 Require Export inference.

Lemma ax_s5_box_dni (G : form_set) (f : form) :
  ax_s5 G (Impl (Box f) (Box (Neg (Neg f)))).
Proof.
  eapply mp.
  - apply a_k.
  - apply nec, ax_s5_dni.
Qed.

Lemma ax_s5_box_dni_infer (G : form_set) (f : form) :
  ax_s5 G (Box f) -> ax_s5 G (Box (Neg (Neg f))).
Proof.
  intros H. apply (mp _ (Box f)).
  - apply ax_s5_box_dni.
  - assumption.
Qed.

Lemma ax_s5_box_dne (G : form_set) (f : form) :
  ax_s5 G (Impl (Box (Neg (Neg f))) (Box f)).
Proof.
  eapply mp.
  - apply a_k.
  - apply nec. apply ax_s5_dne.
Qed.

Lemma ax_s5_box_dne_infer (G : form_set) (f : form) :
  ax_s5 G (Box (Neg (Neg f))) -> ax_s5 G (Box f).
Proof.
  intros H. apply (mp _ (Box (Neg (Neg f)))).
  - apply ax_s5_box_dne.
  - assumption.
Qed.

Lemma ax_s5_df_box (f : form) G :
  ax_s5 G (Box f) <-> ax_s5 G (Neg (Diamond (Neg f))).
Proof.
  unfold Diamond. split; intros H.
  - apply ax_s5_dni_infer, ax_s5_box_dni_infer, H.
  - apply ax_s5_dne_infer in H. apply ax_s5_box_dne_infer, H.
Qed.

Lemma ax_s5_impl_box_dne (f g : form) (G : form_set) :
  ax_s5 G (Impl f (Box g)) -> ax_s5 G (Impl f (Box (Neg (Neg g)))).
Proof.
  intros H. eapply mp.
  - eapply mp.
    + apply a_2.
    + eapply mp.
      * apply a_1.
      * apply ax_s5_box_dni.
  - assumption.
Qed.

Lemma ax_s5_t_diamond (G : form_set) (f : form) :
  ax_s5 G f -> ax_s5 G (Diamond f).
Proof.
  intros H. eapply mp.
  - apply a_t.
  - eapply mp.
    + apply a_b.
    + assumption.
Qed.

Lemma ax_s5_4_diamond (G : form_set) (f : form) :
  ax_s5 G (Diamond (Diamond f)) -> ax_s5 G (Diamond f).
Proof.
  apply mp, ax_s5_mt, ax_s5_impl_box_dne, a_4.
Qed.


Require Export Relation_Definitions.

Implicit Arguments reflexive [[A]].
Implicit Arguments transitive [[A]].
Implicit Arguments symmetric [[A]].
Implicit Arguments antisymmetric [[A]].
Implicit Arguments equiv [[A]].
Implicit Arguments preorder [[A]].
Implicit Arguments Build_preorder [[A]].
Implicit Arguments preord_refl [[A] [R]].
Implicit Arguments preord_trans [[A] [R]].
Implicit Arguments order [[A]].
Implicit Arguments Build_order [[A]].
Implicit Arguments ord_refl [[A] [R]].
Implicit Arguments ord_trans [[A] [R]].
Implicit Arguments ord_antisym [[A] [R]].
Implicit Arguments equivalence [[A]].
Implicit Arguments Build_equivalence [[A]].
Implicit Arguments equiv_refl [[A] [R]].
Implicit Arguments equiv_trans [[A] [R]].
Implicit Arguments equiv_sym [[A] [R]].
Implicit Arguments PER [[A]].
Implicit Arguments Build_PER [[A]].
Implicit Arguments per_sym [[A] [R]].
Implicit Arguments per_trans [[A] [R]].
Implicit Arguments inclusion [[A]].
Implicit Arguments same_relation [[A]].
Implicit Arguments commut [[A]].


(* Proof (A /\ (B -> ~A)) -> (A /\ ~B) *)

Theorem Ex05 (A B : Prop): (A /\ (B -> ~A)) -> (A /\ ~B).
Proof.
  intros.
  destruct H.
  split.
  exact H.
  unfold not.
  intro.
  apply  H0 in H1.
  apply H1.
  exact H.
Qed.


Require Import externals.QuantumLib.Quantum.
Require Export ZX.

Local Open Scope ZX_scope.

Theorem ket_plus_state : ZX_semantics (Z_Spider 0 1 0) = √ 2 .* hadamard × (ket 0).
Proof.
  simpl.
  unfold_spider.
  autorewrite with Cexp_db.
  solve_matrix.
Qed.

Theorem ket_minus_state : ZX_semantics (Z_Spider 0 1 PI) = √ 2 .* hadamard × (ket 1).
Proof.
  simpl.
  unfold_spider.
  autorewrite with Cexp_db.
  solve_matrix.
Qed.

Theorem ket_0_state : ZX_semantics (X_Spider 0 1 0) = √ 2 .* (ket 0).
Proof.
  simpl.
  unfold X_semantics; simpl.
  rewrite kron_1_l; try auto with wf_db.
  unfold Z_semantics; simpl.
  autorewrite with Cexp_db.
  solve_matrix.
  rewrite <- Csqrt2_sqrt.
  rewrite <- Cmult_assoc.
  rewrite Cinv_r; try nonzero.
  rewrite Cmult_1_r; reflexivity.
Qed.

Theorem ket_1_state : ZX_semantics (X_Spider 0 1 PI) = √ 2 .* (ket 1).
Proof.
  simpl.
  unfold X_semantics; simpl.
  rewrite kron_1_l; try auto with wf_db.
  unfold Z_semantics; simpl.
  autorewrite with Cexp_db.
  solve_matrix.
  C_field_simplify; try lca; try apply Csqrt2_neq_0.
Qed.

Theorem bra_plus_state : ZX_semantics (Z_Spider 1 0 0) = √ 2 .* (hadamard × (ket 0))†.
Proof.
  simpl.
  unfold Z_semantics; simpl.
  autorewrite with Cexp_db.
  solve_matrix.
Qed.

Theorem bra_minus_state : ZX_semantics (Z_Spider 1 0 PI) = √ 2 .* (hadamard × (ket 1))†.
Proof.
  simpl.
  unfold_spider.
  autorewrite with Cexp_db.
  solve_matrix.
Qed.

Theorem bra_0_state : ZX_semantics (X_Spider 1 0 0) = √ 2 .* (bra 0).
Proof.
  simpl.
  unfold_spider; try auto with wf_db.
  autorewrite with Cexp_db.
  solve_matrix.
  C_field_simplify; try reflexivity; try apply Csqrt2_neq_0.
Qed.

Theorem bra_1_state : ZX_semantics (X_Spider 1 0 PI) = √ 2 .* (bra 1).
Proof.
  simpl.
  unfold_spider; unfold_spider.
  autorewrite with Cexp_db.
  solve_matrix.
  C_field_simplify; try lca; try apply Csqrt2_neq_0.
Qed.

Local Close Scope ZX_scope.


Require Import Statement ImprovedPredicative Wfd.

Require Import Lia.

Open Scope stmt_scope.

Definition spec := ⟨fun '(i,n) '(i',n') => i <= n /\ i' = n /\ n = n'⟩.

Definition prog := WWhile (fun '(i,n) => i <> n) Do $(i,n) := (i+1,n) Done.

(* Proof of correctness by induction on n *)
Theorem correctness : prog ⊑ spec.
Proof.
  intros (i,n) ((u,v),(HHin,_)); clear u v.
  split.
  { intros (i',n') HHwhile.
    generalize HHin; clear HHin; simpl.
    cut ((fun '(i,n) '(i',n') =>  i <= n -> i <= n /\ i' = n /\ n = n') (i,n) (i',n')); auto.
    apply HHwhile; clear.
    intros (i,n) (i',n'); simpl.
    intros [ (HHin,HHind) | (HHin,HHeq) ] HHin'.
    { lia. }
    { inversion HHeq; subst i n; clear HHeq. lia. }
  }
  { generalize i HHin; clear i HHin; induction n; simpl in *.
    { exists (0,0); apply while_construct; right; split.
      { lia. }
      { f_equal; lia. }
    }
    { intros i HHiSn.
      apply Lt.le_lt_or_eq in HHiSn.
      destruct HHiSn as [ HHiSn | HHiSn ].
      { assert (i <= n) as HHin by lia.
        destruct (IHn _ HHin) as ((i',n'),HHwhile).
        set (Whl := while _ _) in *.
        exists (S i',S n').
        cut ((fun '(i,n) '(i',n') => i <= n -> Whl (i, S n) (S i', S n')) (i,n) (i',n')).
        { intros; auto. }
        apply (while_ind _ _ _ _ _ HHwhile).
        intros (j,m) (j',m'); simpl.
        intros.
        apply while_construct; fold Whl; simpl.
        destruct H.
        { destruct H.
          left; split; try lia.
          apply H1; lia.
        }
        { destruct H.
          inversion H1; subst j' m'.
          left; split; try lia.
          apply while_construct; right; split; try lia.
          f_equal; lia.
        }
      }
      { exists (S n,S n); apply while_construct; right; split; try lia.
        subst i; f_equal; lia.
      }
    }
  }
Qed.

(* Proof of correctness where well-founded-ness is proved by showing inclusion in a well founded relation*)

Theorem correctness2 : prog ⊑ spec.
Proof.
  set (new_body := (IIf (fun '(i,n) => i <= n) Then $(i,n) := (i+1,n) Else Statement.Void End)).
  eapply (refines_trans _ _ _ _ _ (While_monotonic_refines _ _ _ new_body _)).
  apply (refines_extensionality_left _ _ _ spec).
  { apply (wfd_fix_while _ _ (pred spec)).
    { clear.
      apply (Wfd.by_inclusion _ _ (fun '(i',n') '(i,n) => i < i' <= n /\ n' = n)).
      { intros (i,n).
        constructor; intros (i',n').
        remember (n-i) as v.
        generalize i i' n n' Heqv; clear i i' n n' Heqv.
        pattern v; apply (well_founded_ind Wf_nat.lt_wf).
        clear v; intros v HHind i i' n n' HHv HHin.
        assert (n-i' < v) by lia.
        pose proof (HHind (n-i') H).
        constructor; intros (i'',n'') HHi''n''.
        apply (H0 i' _ n); lia.
      }
      { intros (i,n) (i',n'); subst new_body; simpl.
        intros (HHin,[(HHi'n',HHeq) | (_,HHfalse)]).
        { inversion HHeq; clear HHeq; subst i n; lia. }
        { contradiction. }
      }
    }
    { intros (i,n) (i',n'); simpl; split.
      { intros (HHin,(HHi'n,HHnn')); subst i' n'.
        apply Lt.le_lt_or_eq in HHin.
        destruct HHin; try lia.
        subst i; right; auto.
      }
      { intros [HH | (HHin,HHeq)].
        { firstorder. }
        { inversion HHeq; clear HHeq; subst i n. lia. }
      }
    }
  }
  { apply refines_reflexive. }
  Unshelve.
  firstorder.
Qed.

(* Proof of correctness with the aid of a variant *)

Theorem correctness3 : prog ⊑ spec.
Proof.
  set (new_body := (IIf (fun '(i,n) => i <= n) Then $(i,n) := (i+1,n) Else Statement.Void End)).
  eapply (refines_trans _ _ _ _ _ (While_monotonic_refines _ _ _ new_body _)).
  apply (refines_extensionality_left _ _ _ spec).
  { apply (wfd_fix_while _ _ (pred spec)).
    { clear.
      apply (Wfd.by_inclusion _ _ (fun '(i',n') '(i,n) => i < i' <= n /\ n' = n)).
      { apply (Wfd.by_variant _ _ _ (fun '(i,n) => n - i) _ Wf_nat.lt_wf).
        intros (i',n') (i,n); simpl. lia.
      }
      { intros (i,n) (i',n'); subst new_body; simpl.
        intros (HHin,[(HHi'n',HHeq) | (_,HHfalse)]).
        { inversion HHeq; clear HHeq; subst i n; lia. }
        { contradiction. }
      }
    }
    { intros (i,n) (i',n'); simpl; split.
      { intros (HHin,(HHi'n,HHnn')); subst i' n'.
        apply Lt.le_lt_or_eq in HHin.
        destruct HHin; try lia.
        subst i; right; auto.
      }
      { intros [HH | (HHin,HHeq)].
        { firstorder. }
        { inversion HHeq; clear HHeq; subst i n. lia. }
      }
    }
  }
  { apply refines_reflexive. }
  Unshelve.
  firstorder.
Qed.

Theorem while_refines : forall {T : Type} {C} {P : @Stmt T T} Kw K S,
    well_founded (fun s s' => C s' /\ pred Kw s' s)
    -> refines P Kw
    -> (forall s s', pred K s s' <-> ((C s /\ pred_seq Kw (pred K) s s') \/ (~ C s /\ s = s')))
    -> refines K S
    -> (WWhile C Do P Done ⊑ S).
Proof.
  intros T C P Kw K S HHwfd HHpkw HHk HHks.
  apply (refines_trans _ _ _ _ _ (While_monotonic_refines _ _ _ Kw HHpkw)).
  apply (refines_extensionality_left _ _ _ K).
  { apply (wfd_fix_while _ _ (pred K)); auto. }
  { exact HHks. }
Qed.

Theorem correctness4 : prog ⊑ spec.
Proof.
  apply (while_refines (IIf (fun '(i,n) => i <= n) Then $(i,n) := (i+1,n) Else Statement.Void End) spec).
  { apply (Wfd.by_inclusion _ _ (fun '(i',n') '(i,n) => i < i' <= n /\ n' = n)).
    { apply (Wfd.by_variant _ _ _ (fun '(i,n) => n - i) _ Wf_nat.lt_wf).
      intros (i',n') (i,n); simpl. lia.
    }
    { intros (i,n) (i',n'); simpl.
      intros (HHin,[(HHi'n',HHeq) | (_,HHfalse)]).
      { inversion HHeq; clear HHeq; subst i n; lia. }
      { contradiction. }
    }
  }
  { firstorder. }
  { intros (i,n) (i',n'); simpl; split.
    { intros (HHin,(HHi'n,HHnn')); subst i' n'.
      apply Lt.le_lt_or_eq in HHin.
      destruct HHin; try lia.
      subst i; right; auto.
    }
    { intros [HH | (HHin,HHeq)].
      { firstorder. }
      { inversion HHeq; clear HHeq; subst i n. lia. }
    }
  }
  { apply refines_reflexive. }
Qed.

Theorem while_refines' : forall {T : Type} {C} {P : @Stmt T T} Kw K S,
    let Body := IIf (fun s => exists s', pred Kw s s') Then P Else Statement.Void End in
    well_founded (fun s s' => C s' /\ pred Kw s' s)
    -> (forall s s', pred Body s s' -> pred Kw s s')
    -> refines P Body
    -> (forall s s', pred K s s' <-> ((C s /\ pred_seq Body (pred K) s s') \/ (~ C s /\ s = s')))
    -> refines K S
    -> (WWhile C Do P Done ⊑ S).
Proof.
  intros T C P Kw K S Body HHwfd HHbkw HHpb HHk HHks.
  apply (refines_trans _ _ _ _ _ (While_monotonic_refines _ _ _ Body HHpb)).
  apply (refines_extensionality_left _ _ _ K).
  { apply (wfd_fix_while _ _ (pred K)); auto.
    apply (Wfd.by_inclusion _ _ _ HHwfd).
    intros s s' (HHc,HHb); split; auto.
  }
  { exact HHks. }
Qed.

Theorem correctness5 : prog ⊑ spec.
Proof.
  apply (while_refines' ⟨fun '(i,n) '(i',n') => i < i' <= n /\ n' = n⟩ spec).
  { apply (Wfd.by_variant _ _ _ (fun '(i,n) => n - i) _ Wf_nat.lt_wf).
    intros (i',n') (i,n); simpl. lia.
  }
  { intros (i,n) (i',n'); simpl.
    intros [(((j',m'),HHj'm'),HHeq) | (_,HHfalse)].
    { inversion HHeq; clear HHeq; subst i' n'. lia. }
    { contradiction. }
  }
  { firstorder. }
  { intros (i,n) (i',n'); simpl; split.
    { intros (HHin,(HHi'n,HHnn')); subst i' n'.
      apply Lt.le_lt_or_eq in HHin.
      destruct HHin.
      { left; split; try lia.
        left; split; try lia.
        exists (n,n); lia.
      }
      { subst i; right; auto. }
    }
    { intros [HH | (HHin,HHeq)].
      { firstorder. }
      { inversion HHeq; clear HHeq; subst i n. lia. }
    }
  }
  { apply refines_reflexive. }
Qed.

Close Scope stmt_scope.


From Nominal Require Import Nominal.

Section SupportedFunctions.
  Context (X Y: Type) `{Nominal X, Nominal Y}.

  Record FunSupp: Type := mkFunSupp {
    f_car :> X → Y;
    f_supp: NameSet; (* Function support *)
    f_proper: Proper ((≡@{X}) ⟹ (≡@{Y})) f_car;
    f_supp_spec: ∀ (a b: Name), a ∉ f_supp → b ∉ f_supp →
        ∀ (x: X), (⟨a,b⟩ • (f_car (⟨a,b⟩ • x))) ≡@{Y} f_car x
  }.
End SupportedFunctions.

Arguments mkFunSupp {_ _ _ _ _ _} _ _ {_ _}.
Arguments f_supp {_ _ _ _ _ _} _.
#[export] Existing Instance f_proper.

Notation "'λₛ' x .. y , t" :=
  (@mkFunSupp _ _ _ _ _ _ (λ x, .. (@mkFunSupp _ _ _ _ _ _ (λ y, t) _ _ _) ..) _ _ _)
  (at level 200, x binder, y binder, right associativity).

Notation " A '→ₛ' B " := (FunSupp A B) (at level 99, B at level 200, right associativity).

Section FunSuppProperties.
    Context `{Nominal X, Nominal Y}.

    #[global] Instance fun_supp_equiv: Equiv (X →ₛ Y) := λ f g, ∀ (x: X), f x ≡@{Y} g x.
    #[global] Instance fun_supp_equiv_equivalence: Equivalence fun_supp_equiv.
    Proof. split; repeat intro; [reflexivity | symmetry | etransitivity]; eauto. Qed.

    #[global] Instance fun_supp_proper: Proper (fun_supp_equiv ⟹ (≡@{X}) ⟹ (≡@{Y})) (f_car X Y).
    Proof. intros ? ? HH1 ? ? HH2; rewrite HH2; apply HH1. Qed.

    #[refine] Instance fun_supp_act: PermAction (X →ₛ Y) :=
      λ (p: Perm) (f: X →ₛ Y), (λₛ (x: X), p • f((-p) • x)).
    Proof.
      all:try (assumption || typeclasses eauto).
      - exact ((f_supp f) ∪ (perm_dom p)).
      - intros ? ? HH; rewrite HH; reflexivity.
      - intros; rewrite perm_comm; [apply perm_inj | set_solver | set_solver];
        (* see https://github.com/coq/coq/issues/8872 *)
        setoid_rewrite <-perm_comm; [rewrite f_supp_spec | apply perm_dom_inv | apply perm_dom_inv];
        set_solver.
    Defined.

    #[global] Instance fun_supp_perm: PermT (X →ₛ Y).
    Proof.
      split.
      - apply fun_supp_equiv_equivalence.
      - intros ? ? EE f g EF ?; simpl; rewrite EE, EF; reflexivity.
      - unfold equiv, fun_supp_equiv; intros; simpl; rewrite gact_id, grp_inv_neutral, gact_id;
        reflexivity.
      - unfold equiv, fun_supp_equiv; intros; simpl; rewrite perm_op_inv, 2!gact_compat;
        reflexivity.
    Qed.

    #[global] Instance fun_supp_support: Support (X →ₛ Y) := λ fs, f_supp fs.

    #[global] Instance fun_supp_nominal: Nominal (X →ₛ Y).
    Proof.
      split.
      - apply fun_supp_perm.
      - intros f ? ? ? x; unfold support, fun_supp_support, action, fun_supp_act, equiv, fun_supp_equiv in *;
        simpl; intros; rewrite <-perm_inv; apply f_supp_spec; assumption.
    Qed.
End FunSuppProperties.

From Nominal Require Import Fresh.

Lemma fresh_fun_supp `{Nominal X, Nominal Y} (f: X →ₛ Y):
  ∀ (a: Name) (x: X), a # f → a # x → a # f x.
Proof.
  intros; apply some_any_iff in H3,H4;
  destruct (exist_fresh (support f ∪ support x ∪ support (f x))) as [b];
    apply not_elem_of_union in H5 as [[? ?]%not_elem_of_union ?].
  exists b; split; auto;
  unfold freshP_a, action, fun_supp_act, equiv, fun_supp_equiv in H3; simpl in *;
  specialize (H3 b H5 x); specialize (H4 b H6); rewrite <-perm_inv, H4 in H3; assumption.
Qed.


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

(* typeddensem.v
   Calculus specification and its denotational semantics
*)

Require Import ssreflect ssrfun seq.
Set Automatic Coercions Import.
Require Export monads.
Require Export Program.Basics.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Types and contexts *)

Parameter baseType : Type.

Inductive Ty := Base (o : baseType) | Arrow (ty1 ty2 : Ty) | Prod (ty1 ty2 : Ty).
Infix " --> " := Arrow (at level 55, right associativity).
Infix " ** " := Prod (at level 55).
Definition Env := seq Ty.

Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..) : list_scope.

(* Typed terms in context *)

Parameter Const : Ty -> Type.

Inductive Var : Env -> Ty -> Type :=
| ZVAR : forall env ty, Var (ty :: env) ty
| SVAR : forall env ty ty', Var env ty -> Var (ty' :: env) ty.

Inductive Exp : Env -> Ty -> Type :=
| TCONST : forall env ty, Const ty -> Exp env ty
| TVAR :> forall env ty, Var env ty -> Exp env ty
| TABS : forall env ty1 ty2,
    Exp (ty1 :: env) ty2 -> Exp env (ty1 --> ty2)
| TAPP : forall env ty1 ty2,
    Exp env (ty1 --> ty2) -> Exp env ty1 -> Exp env ty2
| TPAIR : forall env ty1 ty2,
    Exp env ty1 -> Exp env ty2 -> Exp env (ty1 ** ty2)
| TFST : forall env ty1 ty2, Exp env (ty1 ** ty2) -> Exp env ty1
| TSND : forall env ty1 ty2, Exp env (ty1 ** ty2) -> Exp env ty2
| TLET : forall env ty1 ty2, Exp env ty1 -> Exp (ty1 :: env) ty2 -> Exp env ty2.

Definition CExp t := Exp nil t.

Implicit Arguments TCONST [env].

(* Semantics of types and contexts *)

Section Semantics.

Variable T : monadType.

Parameter semBase : baseType -> monadType -> Type.

Fixpoint SemTy ty :=
  match ty with
    | Base o => semBase o T
    | ty1 --> ty2 => SemTy ty1 -> T (SemTy ty2)
    | ty1 ** ty2 => (SemTy ty1 * SemTy ty2)%type
  end.

Fixpoint SemEnv env : Type :=
  match env with
    | nil => unit
    | ty :: env => (SemEnv env * SemTy ty)%type
  end.

Fixpoint SemVar env ty (var : Var env ty) : SemEnv env -> SemTy ty :=
  match var with
    | ZVAR _ _ => @snd _ _
    | SVAR _ _ _ v => (SemVar v) \o @fst _ _
  end.

(* Semantics of constants as a parameter *)
Parameter SemConst : forall ty, Const ty -> SemTy ty.

(* Semantics of values and expressions *)

Notation curry := prod_uncurry.

Fixpoint SemExp env ty (e : Exp env ty) : SemEnv env -> T (SemTy ty) :=
  match e with
    | TCONST _ _ c => const (tval T (SemConst c))
    | TVAR _ _ v => (@tval T _) \o (SemVar v)
    | TABS _ _ _ e => compose (@tval T _) (curry (SemExp e))
    | TAPP _ _ _ e1 e2 =>
        fun eta => (tbind (SemExp e1 eta)) (tbind (SemExp e2 eta))
    | TPAIR eta0 t1 t2 e1 e2 =>
        fun eta =>
          tbind (SemExp e1 eta)
          ((tbind (SemExp e2 eta)) \o (curry (@tval T _)))
    | TFST _ _ _ e =>
        fun eta => tbind (SemExp e eta) ((@tval T _) \o (@fst _ _))
    | TSND _ _ _ e =>
        fun eta => tbind (SemExp e eta) ((@tval T _) \o (@snd _ _))
    | TLET _ _ _ e1 e2 =>
        fun eta => tbind (SemExp e1 eta) (curry (SemExp e2) eta)
  end.

End Semantics.


(** Coq coding by choukh, Mar 2021 **)

Set Warnings "-unrecognized-unicode".

Require Import Relation_Definitions.
Require Import RelationClasses.
Require Import ZFC.Lib.Real.
Require Export ZFC.Elements.EST7_3.

Declare Scope LoStruct_scope.
Delimit Scope LoStruct_scope with lo.
Open Scope LoStruct_scope.

Record LoStruct : Type := constr {
  A : set;
  R : set;
  lo : loset A R;
}.
Global Hint Immediate lo : core.

Lemma empty_loset : loset ∅ ∅.
Proof with auto.
  repeat split.
  - intros x H. exfalso0.
  - intros x y z H. exfalso0.
  - intros x H. exfalso0.
Qed.

Notation "ø̃" := (constr ∅ ∅ empty_loset).
Notation "ℕ̃" := (constr ω Lt (proj1 Lt_wellOrder)).
Notation "ℤ̃" := (constr ℤ IntLt intLt_linearOrder).
Notation "ℚ̃" := (constr ℚ RatLt ratLt_linearOrder).
Notation "ℝ̃" := (constr ℝ RealLt realLt_linearOrder).

Lemma eq_intro : ∀ S T, A S = A T → R S = R T → S = T.
Proof.
  intros S T HA HR. destruct S. destruct T.
  simpl in *. subst. f_equal. apply proof_irrelevance.
Qed.

(* 序嵌入双射 *)
Definition order_embedding_bijection := λ f S T, f: A S ⟺ A T ∧
  ∀ x y ∈ A S, (x <ᵣ y) (R S) ↔ (f[x] <ᵣ f[y]) (R T).
Notation "f :ₒₑ S ⟺ T" := (order_embedding_bijection f S T)
  (at level 70) : LoStruct_scope.

Definition isomorphic : relation LoStruct :=
  λ S T, ∃ f, f :ₒₑ S ⟺ T.

Notation "S ≅ T" := ( isomorphic S T) (at level 60) : LoStruct_scope.
Notation "S ≇ T" := (¬isomorphic S T) (at level 60) : LoStruct_scope.

Definition SubStruct := λ S T, A S ⊆ A T ∧ R S = R T ⥏ A S.
Notation "S ⊑ T" := (SubStruct S T) (at level 70) : LoStruct_scope.

Local Lemma loset_is_binRel : ∀ A R, loset A R → is_binRel R A.
Proof. intros. apply H. Qed.

Local Definition br := λ S, loset_is_binRel (A S) (R S) (lo S).
Definition parent := λ S, OrderedStruct.constr (A S) (R S) (br S).

Lemma parent_iso : ∀ S T,
  S ≅ T ↔ OrderedStruct.isomorphic (parent S) (parent T).
Proof.
  split; intros [f [Hf Hoe]]; exists f; split; auto.
Qed.

Lemma parent_lo : ∀ S, OrderedStruct.lo (parent S).
Proof. intros. apply lo. Qed.

Theorem iso_refl : Reflexive isomorphic.
Proof.
  intros S. apply parent_iso. apply OrderedStruct.iso_refl.
Qed.

Theorem iso_symm : Symmetric isomorphic.
Proof.
  intros S T H. rewrite parent_iso in H. apply parent_iso.
  apply OrderedStruct.iso_symm; auto.
Qed.

Theorem iso_trans : Transitive isomorphic.
Proof.
  intros S T U H1 H2. rewrite parent_iso in H1, H2.
  apply parent_iso. eapply OrderedStruct.iso_trans; eauto.
Qed.

Theorem iso_equiv : Equivalence isomorphic.
Proof.
  split. apply iso_refl. apply iso_symm. apply iso_trans.
Qed.
Existing Instance iso_equiv.


Require Export XR_R.
Require Export XR_Rlt.
Local Open Scope R_scope.
Definition Rle (r1 r2:R) : Prop := r1 < r2 \/ r1 = r2.
Infix "<=" := Rle : R_scope.
Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope.
Notation "x <= y < z"  := (x <= y /\ y <  z) : R_scope.
Notation "x < y < z"   := (x <  y /\ y <  z) : R_scope.
Notation "x < y <= z"  := (x <  y /\ y <= z) : R_scope.


From PetitC Require Import Memory Output Values Ids Permutation.

From Coq Require Import Lists.List ZArith.
Import ListNotations.
Open Scope Z_scope.

Definition zero_offset_if_on_heap (ptr : ptr_value) : Prop :=
  match ptr with
  | HeapPtr _ offset     => offset = 0
  | StackPtr _ | NullPtr => True
  end.

Definition valid_ptr (mem : memory) (ptr : ptr_value) : Prop :=
  exists value, read mem ptr value.

Inductive in_block : memory -> ptr_value -> value -> Prop :=
  | IBStack stack heap offset value :
        OffsetMap.find offset stack = Some value ->
      in_block (stack, heap) (StackPtr offset) value
  | IBHeap stack heap block_id block offset offset' value :
        BlockIdMap.find block_id heap = Some block ->
        OffsetMap.find offset block = Some value ->
      in_block (stack, heap) (HeapPtr block_id offset') value.

Definition closed_under_access (mem : memory) (ptrs : list ptr_value) : Prop :=
  forall ptr ptr',
    In ptr ptrs ->
    in_block mem ptr (PtrValue ptr') ->
      In ptr' ptrs.

Section SubsetEquivalent.

Variable (corresponding_ptrs : list (ptr_value * ptr_value)).

Inductive values_equivalent : value -> value -> Prop :=
  | VEIntValue (val val' : int_value) :
      values_equivalent (IntValue val)
                        (IntValue val')

  | VEUndef :
      values_equivalent Undef
                        Undef

  | VEHeapPtr block_id block_id' offset :
        In (HeapPtr block_id 0, HeapPtr block_id' 0) corresponding_ptrs ->
      values_equivalent (PtrValue (HeapPtr block_id offset))
                        (PtrValue (HeapPtr block_id' offset))

  | VEStackPtr offset offset' :
        In (StackPtr offset, StackPtr offset') corresponding_ptrs ->
      values_equivalent (PtrValue (StackPtr offset))
                        (PtrValue (StackPtr offset')).

Inductive blocks_equivalent : memory -> ptr_value -> memory -> ptr_value -> Prop :=
  | BEStack heap heap' stack stack' offset offset' value value' :
        OffsetMap.find offset stack = Some value ->
        OffsetMap.find offset' stack' = Some value' ->
        values_equivalent value value' ->
      blocks_equivalent (stack, heap) (StackPtr offset)
                        (stack', heap') (StackPtr offset')

  | BEHeap heap heap' stack stack' block_id block_id' block block' ptr_offset ptr_offset' :
        BlockIdMap.find block_id heap = Some block ->
        BlockIdMap.find block_id' heap' = Some block' ->
        forall offset, (OffsetMap.In offset block <-> OffsetMap.In offset block') /\
                       (forall value value', OffsetMap.find offset block = Some value ->
                                             OffsetMap.find offset block' = Some value' ->
                                               values_equivalent value value') ->
      blocks_equivalent (stack, heap) (HeapPtr block_id ptr_offset)
                        (stack', heap') (HeapPtr block_id' ptr_offset').

Definition memory_subsets_equivalent (mem mem' : memory) : Prop :=
  let '(stack, heap) := mem in
  let '(stack', heap') := mem' in
  let ptrs  := map fst corresponding_ptrs in
  let ptrs' := map snd corresponding_ptrs in
  Forall (valid_ptr mem) ptrs /\
  Forall (valid_ptr mem') ptrs' /\
  Forall zero_offset_if_on_heap ptrs /\
  Forall zero_offset_if_on_heap ptrs' /\
  NoDup ptrs /\
  NoDup ptrs' /\
  Permutation ptrs ptrs' /\
  Forall (fun '(ptr, ptr') => blocks_equivalent mem ptr mem' ptr')
         corresponding_ptrs.

End SubsetEquivalent.

Definition accessible_equivalent (corresponding_access_ptrs : list (ptr_value * ptr_value))
                                 (mem mem' : memory) : Prop :=
  exists additional_corresponding_ptrs,
    let corresponding_ptrs := corresponding_access_ptrs ++ additional_corresponding_ptrs in
    closed_under_access mem  (map fst corresponding_ptrs) /\
    closed_under_access mem' (map snd corresponding_ptrs) /\
    memory_subsets_equivalent corresponding_ptrs mem mem'.


Require Import List String Ascii ZArith.
Require error micheline_parser.
Require Import micheline_tokens location.
Import error.Notations.

Definition char_is_num (c : ascii) :=
  match c with
  | "0"%char | "1"%char | "2"%char | "3"%char | "4"%char | "5"%char
  | "6"%char | "7"%char | "8"%char | "9"%char => true
  | _ => false
  end.

Definition char_is_annot (c : ascii) :=
  match c with
  | "%"%char | "@"%char | ":"%char => true
  | _ => false
  end.

Check (eq_refl : char_is_num "a"%char = false).
Check (eq_refl : char_is_num "z"%char = false).
Check (eq_refl : char_is_num "A"%char = false).
Check (eq_refl : char_is_num "Z"%char = false).
Check (eq_refl : char_is_num "_"%char = false).
Check (eq_refl : char_is_num "0"%char = true).
Check (eq_refl : char_is_num "9"%char = true).

Definition eqb_ascii (a b : ascii) : bool :=
 match a, b with
 | Ascii a0 a1 a2 a3 a4 a5 a6 a7,
   Ascii b0 b1 b2 b3 b4 b5 b6 b7 =>
    Bool.eqb a0 b0 && Bool.eqb a1 b1 && Bool.eqb a2 b2 && Bool.eqb a3 b3
    && Bool.eqb a4 b4 && Bool.eqb a5 b5 && Bool.eqb a6 b6 && Bool.eqb a7 b7
 end.

Definition char_is_alpha (c : ascii) :=
  let leb a b := (N.leb (N_of_ascii a) (N_of_ascii b)) in
  orb (andb (leb "a"%char c) (leb c "z"%char))
      (orb (andb (leb "A"%char c) (leb c "Z"%char))
           (eqb_ascii "_"%char c)).

Definition char_is_dot (c : ascii) := eqb_ascii "."%char c.

Definition char_is_hex (c : ascii) :=
  let leb a b := (N.leb (N_of_ascii a) (N_of_ascii b)) in
  orb (andb (leb "a"%char c) (leb c "f"%char))
      (orb (andb (leb "A"%char c) (leb c "F"%char))
           (char_is_num c)).

Check (eq_refl : char_is_alpha "a"%char = true).
Check (eq_refl : char_is_alpha "z"%char = true).
Check (eq_refl : char_is_alpha "A"%char = true).
Check (eq_refl : char_is_alpha "Z"%char = true).
Check (eq_refl : char_is_alpha "_"%char = true).
Check (eq_refl : char_is_alpha "0"%char = false).
Check (eq_refl : char_is_alpha "9"%char = false).

Definition Z_of_char (c : ascii) (acc : Z) : Z :=
  match c with
  | "0"%char => (10 * acc)%Z
  | "1"%char => (10 * acc + 1)%Z
  | "2"%char => (10 * acc + 2)%Z
  | "3"%char => (10 * acc + 3)%Z
  | "4"%char => (10 * acc + 4)%Z
  | "5"%char => (10 * acc + 5)%Z
  | "6"%char => (10 * acc + 6)%Z
  | "7"%char => (10 * acc + 7)%Z
  | "8"%char => (10 * acc + 8)%Z
  | "9"%char => (10 * acc + 9)%Z
  | c => 0%Z
  end.

Definition string_snoc s c := (s ++ String c "")%string.

Fixpoint lex_micheline (input : string) (loc : location) : error.M (list (location.location * location.location * token)) :=
  match input with
  | String first_char input =>
    let nloc := location_incr loc in
    match first_char with
    | "{"%char =>
      let! l := lex_micheline input loc in
      error.Return (cons (loc, nloc, LBRACE) l)
    | "}"%char =>
      let! l := lex_micheline input loc in
      error.Return (cons (loc, nloc, RBRACE) l)
    | "("%char =>
      let! l := lex_micheline input loc in
      error.Return (cons (loc, nloc, LPAREN) l)
    | ")"%char =>
      let! l := lex_micheline input loc in
      error.Return (cons (loc, nloc, RPAREN) l)
    | ";"%char =>
      let! l := lex_micheline input loc in
      error.Return (cons (loc, nloc, SEMICOLON) l)
    | """"%char =>
      lex_micheline_string input ""%string loc nloc
    | "#"%char =>
      lex_micheline_inline_comment input nloc
    | " "%char =>
      lex_micheline input nloc
    | "010"%char (* newline *) =>
      lex_micheline input (location_newline loc)
    | "/"%char =>
      match input with
      | String "*"%char s =>
        lex_micheline_multiline_comment s (location_incr nloc)
      | _ =>
        error.Failed _ (error.Lexing loc)
      end
    | "-"%char =>
      let loc := location_incr loc in
      (fix lex_micheline_number (input : string) (acc : Z) start loc :=
         match input with
         | String c s =>
           if char_is_num c then
             let loc := location_incr loc in
             lex_micheline_number s (Z_of_char c acc) start loc
           else
            let! l := lex_micheline input loc in
            error.Return (cons (start, loc, NUMBER (- acc)%Z) l)
         | EmptyString => error.Return (cons (start, loc, NUMBER (- acc)%Z) nil)
         end) input 0%Z loc loc
    | "0"%char =>
      match input with
      | String "x" s =>
        (fix lex_micheline_bytes (input : string) (acc : string) start loc :=
           match input with
           | String c s =>
             if char_is_hex c then
               let loc := location_incr loc in
               lex_micheline_bytes s (string_snoc acc c) start loc
             else
              let! l := lex_micheline input loc in
              error.Return (cons (start, loc, BYTES acc) l)
           | EmptyString => error.Return (cons (start, loc, BYTES acc) nil)
           end) s EmptyString loc (location_incr (location_incr loc))
      | String c s =>
        if char_is_num c then error.Failed _ (error.Lexing loc)
        else
          let! l := lex_micheline input loc in
          error.Return (cons (loc, location_incr loc, NUMBER 0%Z) l)
      | EmptyString => error.Return (cons (loc, location_incr loc, NUMBER 0%Z) nil)
      end
    | c =>
      if char_is_num c then
        (fix lex_micheline_number (input : string) (acc : Z) start loc :=
           match input with
           | String c s =>
             if char_is_num c then
               let loc := location_incr loc in
               lex_micheline_number s (Z_of_char c acc) start loc
             else
              let! l := lex_micheline input loc in
              error.Return (cons (start, loc, NUMBER acc) l)
           | EmptyString => error.Return (cons (start, loc, NUMBER acc) nil)
           end) input (Z_of_char c 0%Z) loc loc
      else
        if char_is_alpha c then
          (fix lex_micheline_prim (input : string) (acc : string) start loc :=
             match input with
             | String c s =>
               if orb (char_is_alpha c) (char_is_num c) then
                 let loc := location_incr loc in
                 lex_micheline_prim s (string_snoc acc c) start loc
               else
                let! l := lex_micheline input loc in
                error.Return (cons (start, loc, PRIM acc) l)
             | EmptyString => error.Return (cons (start, loc, PRIM acc) nil)
             end) input (String c ""%string) loc loc
        else
          if char_is_annot c then (* Annotations are ignored *)
            (fix lex_micheline_annot input loc :=
               match input with
               | String c s =>
                 if (orb (char_is_alpha c)
                         (orb (char_is_num c)
                              (orb (char_is_annot c)
                                   (char_is_dot c)))) then
                   let loc := location_incr loc in
                   lex_micheline_annot s loc
                 else
                   lex_micheline input loc
               | EmptyString => error.Return nil
               end) input loc
          else
            error.Failed _ (error.Lexing loc)
    end
  | EmptyString => error.Return nil
  end
with
lex_micheline_string (input : string) (acc : string) start loc :=
  match input with
  | String """"%char s =>
    let loc := location_incr loc in
    let! l := lex_micheline s loc in
    error.Return (cons (start, loc, STR acc) l)
  | String c s =>
    let loc := location_incr loc in
    lex_micheline_string s (string_snoc acc c) start loc
  | EmptyString =>
    error.Failed _ (error.Lexing loc)
  end
with
lex_micheline_inline_comment (input : string) loc :=
  match input with
  | String "010"%char (* newline *) s => lex_micheline s (location_newline loc)
  | String _ s =>
    let loc := location_incr loc in
    lex_micheline_inline_comment s loc
  | Empty_string => error.Return nil
  end
with
lex_micheline_multiline_comment (input : string) loc :=
  match input with
  | String "*"%char (String "/" s) =>
    let loc := location_incr loc in
    let loc := location_incr loc in
    lex_micheline s loc
  | String "010"%char (* newline *) s =>
    let loc := location_newline loc in
    lex_micheline_multiline_comment s loc
  | String _ s =>
    let loc := location_incr loc in
    lex_micheline_multiline_comment s loc
  | Empty_string => error.Failed _ (error.Lexing loc)
  end.

CoFixpoint const_buffer (t : micheline_parser.Aut.Gram.token) : micheline_parser.MenhirLibParser.Inter.buffer :=
  micheline_parser.MenhirLibParser.Inter.Buf_cons t (const_buffer t).

Fixpoint tokens_to_parser (ts : list (location * location * token)) : error.M micheline_parser.MenhirLibParser.Inter.buffer :=
  match ts with
  | nil => error.Return (const_buffer (token_to_parser (location_start, location_start, EOF)))
  | cons t ts =>
    let! s := tokens_to_parser ts in
    error.Return (micheline_parser.MenhirLibParser.Inter.Buf_cons (token_to_parser t) s)
  end.

Definition lex_micheline_to_parser (input : string)
  : error.M micheline_parser.MenhirLibParser.Inter.buffer :=
  let! ts := lex_micheline input location_start in
  tokens_to_parser ts.

(* Some interesting lemmas *)

Lemma eqb_ascii_eq n m : (eqb_ascii n m) = true <-> n = m.
Proof.
  split; intros.
  + unfold eqb_ascii in H. destruct n; destruct m.
    repeat rewrite Bool.andb_true_iff in H.
    destruct H as [[[[[[[H H0] H1] H2] H3] H4] H5] H6].
    f_equal; apply Bool.eqb_prop; assumption.
  + rewrite H. unfold eqb_ascii. destruct m.
    destruct b; destruct b0; destruct b1; destruct b2;
      destruct b3; destruct b4; destruct b5; destruct b6; reflexivity.
Qed.

Inductive char_not_in_string : ascii -> string -> Prop :=
| CharNotInEmpty : forall c, char_not_in_string c ""
| CharNotInString : forall c c' s,
    c <> c' ->
    char_not_in_string c s ->
    char_not_in_string c (String c' s).

Lemma lex_string_end : forall s start loc,
    lex_micheline_string """" s start loc =
    error.Return ((start, location_incr loc, (micheline_tokens.STR s)) :: nil).
Proof.
  intros s start loc.
  reflexivity.
Qed.

Lemma append_empty_right : forall s, (String.append s "") = s.
Proof.
  induction s.
  - reflexivity.
  - simpl. rewrite IHs. reflexivity.
Qed.

Lemma append_assoc : forall s1 s2 s3,
    ((s1 ++ s2) ++ s3)%string = (s1 ++ (s2 ++ s3))%string.
Proof.
  induction s1; intros.
  - reflexivity.
  - simpl. rewrite IHs1. reflexivity.
Qed.

Lemma append_string_empty_left : forall a s, (String a "" ++ s)%string = String a s.
Proof. reflexivity. Qed.

Lemma lex_string_aux : forall s2 start loc,
    char_not_in_string """" s2 ->
    forall s1, lex_micheline_string (s2++"""") s1 start loc =
               error.Return ((start, location_add loc ((String.length s2)+1),
                              (micheline_tokens.STR (s1++s2))) :: nil).
Proof.
  induction s2; intros.
  - (* Empty string *) simpl. rewrite append_empty_right. reflexivity.
  - (* c :: s *)
    simpl. inversion H; subst.
    specialize (IHs2 start (location_incr loc) H4 (string_snoc s1 a)).
    unfold string_snoc in *. rewrite IHs2. simpl.
    unfold string_snoc; simpl.
    rewrite location.location_add_incr_S.
    rewrite append_assoc. rewrite append_string_empty_left.
    case_eq a. intros. case_eq b; case_eq b0; case_eq b1; case_eq b2; case_eq b3; case_eq b4; case_eq b5; case_eq b6; try reflexivity.
    intros. subst b; subst b0; subst b1; subst b2; subst b3; subst b4; subst b5; subst b6. symmetry in H0. contradiction.
Qed.

Corollary lex_string : forall s start,
    char_not_in_string """" s ->
    lex_micheline (""""++s++"""") start =
    error.Return ((start, location_add start ((String.length s)+2),
                   (micheline_tokens.STR s)) :: nil).
Proof.
  intros. simpl.
  specialize (lex_string_aux s start (location_incr start) H "").
  simpl. intro.
  rewrite <- location.location_add_incr_S in H0.
  assert (S (length s + 1) = (length s + 2)) as Hlen by omega.
  rewrite Hlen in H0. assumption.
Qed.


(**

This file formalizes basic examples from standard Separation Logic,
as described in Arthur Charguéraud's lecture notes.

Author: Arthur Charguéraud.
License: MIT.

*)

Set Implicit Arguments.
Require LibListZ.
Require Import LambdaCF TLCbuffer.
Open Scope trm_scope.
Open Scope heap_scope.
Open Scope charac.

Ltac auto_star ::= jauto.

Local Open Scope fmap_scope.

Implicit Types t : trm.
Implicit Types v : val.
Implicit Types f : field.
Implicit Type l p q : loc.
Implicit Types n : int.

(* ********************************************************************** *)
(* ################################################################# *)
(* * Derived basic functions *)

(* ---------------------------------------------------------------------- *)
(** Increment function *)

Definition val_incr :=
  Vars P, N, M in
  ValFun P :=
    Let N := val_get P in
    Let M := val_add N 1 in
    val_set P M.

(** Same proof using characteristic formulae with advanced tactics *)

Lemma rule_incr : forall p n,
  triple (val_incr p)
    (p ~~~> n)
    (fun r => \[r = val_unit] \* (p ~~~> (n+1))).
Proof using.
  xcf. xapps. xapps. xapps. hsimpl~.
Qed.

Hint Extern 1 (Register_spec val_incr) => Provide rule_incr.

(* ---------------------------------------------------------------------- *)
(** Negation *)

Definition val_not :=
  Vars N in
  ValFun N := If_ val_eq N true Then false Else true.

Lemma rule_not : forall (b:bool),
  triple (val_not b)
    \[]
    (fun r => \[r = !b]).
Proof using.
  xcf. xapps. xif; => C.
  { xvals. inverts~ C. }
  { xvals. fequals. destruct b; auto_false. }
Qed.

Hint Extern 1 (Register_spec val_not) => Provide rule_not.

(* ---------------------------------------------------------------------- *)
(** Disequality test *)

Definition val_neq :=
  Vars M, N, X in
  ValFun M N :=
    Let X := val_eq M N in
    val_not X.

Lemma rule_neq : forall v1 v2,
  triple (val_neq v1 v2)
    \[]
    (fun r => \[r = isTrue (v1 <> v2)]).
Proof using.
  xcf. xapps. xapps. hsimpl. isubst. rew_isTrue~.
Qed.

Hint Extern 1 (Register_spec val_neq) => Provide rule_neq.

(* ********************************************************************** *)
(* ################################################################# *)
(* * Formalisation of records *)

(* ---------------------------------------------------------------------- *)
(** Read to a record field *)

Definition val_get_field (f:field) :=
  Vars P, Q in
  ValFun P :=
    Let Q := val_ptr_add P (nat_to_Z f) in
    val_get Q.

Lemma rule_get_field : forall l f v,
  triple ((val_get_field f) l)
    (l `.` f ~~~> v)
    (fun r => \[r = v] \* (l `.` f ~~~> v)).
Proof using.
  intros. applys rule_app_fun. reflexivity. simpl.
  applys rule_let. { xapplys rule_ptr_add_nat. }
  intros r. simpl. xpull. intro_subst.
  rewrite hfield_eq_fun_hsingle.
  xpull ;=> N. xapplys~ rule_get.
Qed.

(* ---------------------------------------------------------------------- *)
(** Write to a record field *)

Definition val_set_field (f:field) :=
  Vars P, Q, V in
  ValFun P V :=
    Let Q := val_ptr_add P (nat_to_Z f) in
    val_set Q V.

Lemma rule_set_field : forall v' l f v,
  triple ((val_set_field f) l v)
    (l `.` f ~~~> v')
    (fun r => \[r = val_unit] \* (l `.` f ~~~> v)).
Proof using.
  intros. applys rule_app_fun2. reflexivity. auto. simpl.
  applys rule_let. { xapplys rule_ptr_add_nat. }
  intros r. simpl. xpull. intro_subst.
  rewrite hfield_eq_fun_hsingle.
  xpull ;=> N. xapplys~ rule_set.
Qed.

Arguments rule_set_field : clear implicits.

(* ********************************************************************** *)
(* ################################################################# *)
(* * Formalisation of arrays *)

(* ---------------------------------------------------------------------- *)
(** Representation *)

Fixpoint Array (L:list val) (p:loc) : hprop :=
  match L with
  | nil => \[]
  | x::L' => (p ~~~> x) \* (Array L' (S p))
  end.

Lemma Array_nil_eq : forall p,
  Array nil p = \[].
Proof using. auto. Qed.

Lemma Array_cons_eq : forall p x L,
  Array (x::L) p = (p ~~~> x) \* Array L (S p).
Proof using. auto. Qed.

Lemma Array_one_eq : forall p x,
  Array (x::nil) p = (p ~~~> x).
Proof using. intros. rewrite Array_cons_eq, Array_nil_eq. rew_heap~. Qed.

Lemma Array_concat_eq : forall p L1 L2,
  Array (L1++L2) p = Array L1 p \* Array L2 (p + length L1)%nat.
Proof using.
  Transparent loc.
  intros. gen p. induction L1; intros; rew_list.
  { rewrite Array_nil_eq. rew_heap. fequals. unfold loc; math. }
  { do 2 rewrite Array_cons_eq. rewrite IHL1. rew_heap. do 3 fequals.
    unfold loc; math. }
Qed.

Lemma Array_last_eq : forall p x L,
  Array (L&x) p = Array L p \* ((p + length L)%nat ~~~> x).
Proof using. intros. rewrite Array_concat_eq. rewrite~ Array_one_eq. Qed.

Lemma Array_middle_eq : forall n p L,
  0 <= n < length L ->
  Array L p = Hexists L1 x L2, \[L = L1++x::L2] \* \[length L1 = n :> int] \*
    Array L1 p \* (abs(p+n) ~~~> x) \* Array L2 (p + length L1 + 1)%nat.
Proof using.
  (* TODO: simplify the Z/nat math, by using a result from LibListZ directly *)
  introv N. applys himpl_antisym.
  { forwards (L1&x&L2&E&M): list_middle_inv (abs n) L.
    asserts (N1&N2): (0 <= abs n /\ (abs n < length L)%Z).
    { split; rewrite abs_nonneg; math. } math.
    lets M': eq_int_of_eq_nat M. rewrite abs_nonneg in M'; [|math].
    hsimpl~ (>> L1 x L2). subst L. rewrite Array_concat_eq, Array_cons_eq.
    rew_nat. hsimpl. rewrite M. rewrite~ abs_nat_plus_nonneg. math. }
  { hpull ;=> L1 x L2 M E. subst n.
    subst L. rewrite Array_concat_eq, Array_cons_eq.
    rew_nat. hsimpl. applys_eq himpl_refl 1. fequals.
    rewrite abs_nat_plus_nonneg; [|math]. rewrite~ abs_nat. }
Qed.

Global Opaque Array.

(* ---------------------------------------------------------------------- *)
(** Array allocation *)

Lemma Array_of_Alloc : forall k l,
  Alloc k l ==>
  Hexists (L : list val), \[length L = k] \* Array L l.
Proof using.
  intros. gen l. induction k; intros.
  { rew_Alloc. hsimpl (@nil val). rew_list~. }
  { rew_Alloc. hpull ;=> v. hchange IHk. hpull ;=> L E.
    hsimpl (v::L).
    { rewrite Array_cons_eq. hsimpl~. }
    { rew_list. math. } }
Qed.

Lemma rule_alloc_array : forall n,
  n >= 0 ->
  triple (val_alloc n)
    \[]
    (fun r => Hexists (p:loc) (L:list val), \[r = val_loc p] \*
              \[length L = n :> int] \* Array L p).
Proof using.
  introv N. xapp. math.
  intros r. hpull ;=> l (E&Nl). subst r.
  hchange Array_of_Alloc. hpull ;=> L HL.
  hsimpl~. rewrite HL. rewrite~ abs_nonneg.
Qed.

(* -------------------------------------------------------------------------- *)
(** Accesses *)

Import LibListZ.
Implicit Types i ofs len : int.

(* ---------------------------------------------------------------------- *)
(** Array get *)

Definition val_array_get : val :=
  Vars P, I, N in
  ValFun P I :=
    Let N := val_ptr_add P I in
    val_get N.

Lemma rule_array_get : forall p i L,
  index L i ->
  triple (val_array_get p i)
    (Array L p)
    (fun r => \[r = L[i]] \* Array L p).
Proof using.
  introv N. rewrite index_eq_inbound in N.
  xcf. xapps. { math. }
  rewrites (>> Array_middle_eq i). { math. }
  xpull ;=> L1 x L2 EL HL.
  xapp. hpull ;=> r. intro_subst.
  hsimpl; auto. { subst. rewrite~ read_middle. }
Qed.

Hint Extern 1 (Register_spec val_array_get) => Provide rule_array_get.

Notation "'Array'' p `[ i ]" := (trm_app (trm_app (trm_val val_array_get) p) i)
  (at level 69, p at level 0, no associativity,
   format "'Array''  p `[ i ]") : charac.

(* ---------------------------------------------------------------------- *)
(** Array set *)

Definition val_array_set : val :=
  Vars P, I, X, N in
  ValFun P I X :=
    Let N := val_ptr_add P I in
    val_set N X.

Lemma rule_array_set : forall p i v L,
  index L i ->
  triple (val_array_set p i v)
    (Array L p)
    (fun r => \[r = val_unit] \* Array (L[i:=v]) p).
Proof using.
  introv N. rewrite index_eq_inbound in N.
  xcf. xapps. { math. }
  rewrites (>> Array_middle_eq i). { math. }
  xpull ;=> L1 x L2 EL HL.
  xapp. hpull ;=> r. intro_subst.
  rewrites (>> Array_middle_eq i (L[i := v])).
   { rewrite <- length_eq in *. rew_array. math. }
  hsimpl; auto. { subst. rewrite~ update_middle. rew_list~. }
Qed.

Hint Extern 1 (Register_spec val_array_set) => Provide rule_array_set.

Notation "'Array'' p `[ i ] `<- x" := (trm_app (trm_app (trm_app (trm_val val_array_set) p) i) x)
  (at level 69, p at level 0, no associativity,
   format "'Array''  p `[ i ]  `<-  x") : charac.

(* ---------------------------------------------------------------------- *)
(** Array make *)

Definition val_array_make : val :=
  Vars N, V, P, B, I in
  ValFun N V :=
    Let P := val_alloc N in
    Let B := val_sub N 1 in
    For I := 0 To B Do  (* todo: allow inlining of B *)
      Array' P`[I] `<- V
    Done;;
    P.

Lemma rule_array_make : forall n v,
  n >= 0 ->
  triple (val_array_make n v)
    \[]
    (fun r => Hexists p L, \[r = val_loc p] \* \[L = make n v] \* Array L p).
Proof using.
  introv N. xcf. xapp~ rule_alloc_array ;=> r p L Er EL. subst r.
  xapps. xseq.
  { (* todo: xfor tactic *)
    applys local_erase. esplit; esplit; splits; [reflexivity|reflexivity|].
    intros S LS EF M. subst EF. simpl in M.
    cuts G: (forall i L', i >= 0 -> length L' = n-i ->
       S i (Array ((make i v)++L') p) (fun r => \[r = '()] \* (Array (make n v) p))).
    { applys_eq (>> G L) 2. math. math. rewrite make_zero. rew_list~. }
    intros i. induction_wf IH: (upto n) i. intros L' Ei EL'.
    applys (rm M). case_if.
    { xapp~. { rewrite index_eq_inbound. rew_list. rewrite length_make; math. }
      destruct L' as [|x L']. { false. rew_list in EL'. math. }
      rewrite~ update_middle; [| rewrite length_make; math ].
      rew_list. xapplys (>> IH L').
      { auto with maths. }
      { rew_list; math. }
      { rew_list in *; math. }
      { applys LS. }
      { rewrite make_succ_r; [|math]. rew_list. hsimpl~. }
      { auto. } }
    { xval. math E: (i = LibList.length L).
      asserts: (L' = nil). { applys length_zero_inv. math. }
      subst. rew_list. hsimpl~. } }
  { xval. subst n. hsimpl~. }
Qed.

Hint Extern 1 (Register_spec val_array_make) => Provide rule_array_make.

(* ---------------------------------------------------------------------- *)
(** Array init *)


Require Import List.
Require Import Bool.

Open Scope list_scope.

(* See http://learnyouahaskell.com/functors-applicative-functors-and-monoids#monoids *)

Section AnyAll.

  Variable A : Set.
  Variable p : A -> bool.

  Fixpoint foldl {A B} a0 f (l : list A) : B :=
    match l with
    | nil => a0
    | x::xs => foldl (f a0 x) f xs
    end.

  Definition any := foldl false (fun b x => b || p x).

  Lemma any' l : {y | y = any l}.
    unfold any.
    generalize false l; fix aux 2.
    destruct l0 as [|x xs].
    - simpl. eexists; reflexivity.
    - simpl. case b.
      + Search (true || _). rewrite orb_true_l.
        replace (foldl _ _ _) with true.
        * eexists; reflexivity.
        * induction xs. simpl. reflexivity.
          simpl. apply IHxs.
      + edestruct aux as [r R].
        rewrite <- R.
        eexists; reflexivity.
  Defined.

  (* 'all' is actually boring; just negb any (negb..) *)
End AnyAll.

Extraction any'.

Section Compare.

  Inductive Ordering := LT | EQ | GT.

  Definition mappend a b :=
    match a with
    | LT => LT
    | EQ => b
    | GT => GT
    end.

  Variable A : Set.
  Variable cmp : A -> A -> Ordering.

  Fixpoint zip {A B} (l1 : list A) (l2 : list B) :=
    match (l1, l2) with
    | (x1::xs1, x2::xs2) => (x1,x2) :: zip xs1 xs2
    | _ => nil
    end.

  Definition uncurry2 {A B C} (f : A -> B -> C) xy := f (fst xy) (snd xy).

  Definition lex_cmp l1 l2 := foldl EQ mappend (map (uncurry2 cmp) (zip l1 l2)).

  Lemma lex_cmp' l1 l2 : {y | y = lex_cmp l1 l2}.
    unfold lex_cmp.
    generalize EQ l1 l2; fix aux 2.
    destruct l0; intro.
    - simpl. eexists; reflexivity.
    - destruct l3.
      + simpl. eexists; reflexivity.
      + simpl. unfold uncurry2; simpl.
        case o.
        * replace (foldl _ _ _) with LT.
          eexists; reflexivity.
          generalize (zip l0 l3). induction l.
          unfold mappend; simpl; reflexivity.
          apply IHl.
        * unfold mappend at 1; simpl.
          apply aux.
        * replace (foldl _ _ _) with GT.
          eexists; reflexivity.
          generalize (zip l0 l3). induction l.
          unfold mappend; simpl; reflexivity.
          apply IHl.
  Defined.

End Compare.

Extraction lex_cmp'.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(*********************************************************)
(**          Complements for the real numbers            *)
(*                                                       *)
(*********************************************************)

Require Import Rbase.
Require Import R_Ifp.
Require Import Fourier.
Local Open Scope R_scope.

Implicit Type r : R.

(*******************************)
(** *        Rmin              *)
(*******************************)

(*********)
Definition Rmin (x y:R) : R :=
  match Rle_dec x y with
    | left _ => x
    | right _ => y
  end.

(*********)
Lemma Rmin_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmin r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmin; case (Rle_dec r1 r2); auto.
Qed.

(*********)
Lemma Rmin_case_strong : forall r1 r2 (P:R -> Type),
  (r1 <= r2 -> P r1) -> (r2 <= r1 -> P r2) -> P (Rmin r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmin; destruct (Rle_dec r1 r2); auto with real.
Qed.

(*********)
Lemma Rmin_Rgt_l : forall r1 r2 r, Rmin r1 r2 > r -> r1 > r /\ r2 > r.
Proof.
  intros r1 r2 r; unfold Rmin; case (Rle_dec r1 r2) as [Hle|Hnle]; intros.
  split.
  assumption.
  unfold Rgt; exact (Rlt_le_trans r r1 r2 H Hle).
  split.
  generalize (Rnot_le_lt r1 r2 Hnle); intro; exact (Rgt_trans r1 r2 r H0 H).
  assumption.
Qed.

(*********)
Lemma Rmin_Rgt_r : forall r1 r2 r, r1 > r /\ r2 > r -> Rmin r1 r2 > r.
Proof.
  intros; unfold Rmin; case (Rle_dec r1 r2); elim H; clear H; intros;
    assumption.
Qed.

(*********)
Lemma Rmin_Rgt : forall r1 r2 r, Rmin r1 r2 > r <-> r1 > r /\ r2 > r.
Proof.
  intros; split.
  exact (Rmin_Rgt_l r1 r2 r).
  exact (Rmin_Rgt_r r1 r2 r).
Qed.

(*********)
Lemma Rmin_l : forall x y:R, Rmin x y <= x.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); intro H1;
    [ right; reflexivity | auto with real ].
Qed.

(*********)
Lemma Rmin_r : forall x y:R, Rmin x y <= y.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); intro H1;
    [ assumption | auto with real ].
Qed.

(*********)
Lemma Rmin_left : forall x y, x <= y -> Rmin x y = x.
Proof.
  intros; apply Rmin_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rmin_right : forall x y, y <= x -> Rmin x y = y.
Proof.
  intros; apply Rmin_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rle_min_compat_r : forall x y z, x <= y -> Rmin x z <= Rmin y z.
Proof.
  intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma Rle_min_compat_l : forall x y z, x <= y -> Rmin z x <= Rmin z y.
Proof.
  intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma Rmin_comm : forall x y:R, Rmin x y = Rmin y x.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); case (Rle_dec y x); intros;
    try reflexivity || (apply Rle_antisym; assumption || auto with real).
Qed.

(*********)
Lemma Rmin_stable_in_posreal : forall x y:posreal, 0 < Rmin x y.
Proof.
  intros; apply Rmin_Rgt_r; split; [ apply (cond_pos x) | apply (cond_pos y) ].
Qed.

(*********)
Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y.
Proof.
  intros; unfold Rmin.
  case (Rle_dec x y); intro; assumption.
Qed.

(*********)
Lemma Rmin_glb : forall x y z:R, z <= x -> z <= y -> z <= Rmin x y.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); intro; assumption.
Qed.

(*********)
Lemma Rmin_glb_lt : forall x y z:R, z < x -> z < y -> z < Rmin x y.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); intro; assumption.
Qed.

(*******************************)
(** *        Rmax              *)
(*******************************)

(*********)
Definition Rmax (x y:R) : R :=
  match Rle_dec x y with
    | left _ => y
    | right _ => x
  end.

(*********)
Lemma Rmax_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmax r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto.
Qed.

(*********)
Lemma Rmax_case_strong : forall r1 r2 (P:R -> Type),
  (r2 <= r1 -> P r1) -> (r1 <= r2 -> P r2) -> P (Rmax r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto with real.
Qed.

(*********)
Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2.
Proof.
  intros; split.
  unfold Rmax; case (Rle_dec r1 r2); intros; auto.
  intro; unfold Rmax; case (Rle_dec r1 r2) as [|Hnle]; elim H; clear H; intros;
    auto.
  apply (Rle_trans r r1 r2); auto.
  generalize (Rnot_le_lt r1 r2 Hnle); clear Hnle; intro; unfold Rgt in H0;
    apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)).
Qed.

Lemma Rmax_comm : forall x y:R, Rmax x y = Rmax y x.
Proof.
  intros p q; unfold Rmax; case (Rle_dec p q); case (Rle_dec q p); auto;
    intros H1 H2; apply Rle_antisym; auto with real.
Qed.

(* begin hide *)
Notation RmaxSym := Rmax_comm (only parsing).
(* end hide *)

(*********)
Lemma Rmax_l : forall x y:R, x <= Rmax x y.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro H1;
    [ assumption | auto with real ].
Qed.

(*********)
Lemma Rmax_r : forall x y:R, y <= Rmax x y.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro H1;
    [ right; reflexivity | auto with real ].
Qed.

(* begin hide *)
Notation RmaxLess1 := Rmax_l (only parsing).
Notation RmaxLess2 := Rmax_r (only parsing).
(* end hide *)

(*********)
Lemma Rmax_left : forall x y, y <= x -> Rmax x y = x.
Proof.
  intros; apply Rmax_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rmax_right : forall x y, x <= y -> Rmax x y = y.
Proof.
  intros; apply Rmax_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rle_max_compat_r : forall x y z, x <= y -> Rmax x z <= Rmax y z.
Proof.
  intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma Rle_max_compat_l : forall x y z, x <= y -> Rmax z x <= Rmax z y.
Proof.
  intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma RmaxRmult :
  forall (p q:R) r, 0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q.
Proof.
  intros p q r H; unfold Rmax.
  case (Rle_dec p q); case (Rle_dec (r * p) (r * q)); auto; intros H1 H2; auto.
  case H; intros E1.
  case H1; auto with real.
  rewrite <- E1; repeat rewrite Rmult_0_l; auto.
  case H; intros E1.
  case H2; auto with real.
  apply Rmult_le_reg_l with (r := r); auto.
  rewrite <- E1; repeat rewrite Rmult_0_l; auto.
Qed.

(*********)
Lemma Rmax_stable_in_negreal : forall x y:negreal, Rmax x y < 0.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro;
    [ apply (cond_neg y) | apply (cond_neg x) ].
Qed.

(*********)
Lemma Rmax_lub : forall x y z:R, x <= z -> y <= z -> Rmax x y <= z.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro; assumption.
Qed.

(*********)
Lemma Rmax_lub_lt : forall x y z:R, x < z -> y < z -> Rmax x y < z.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro; assumption.
Qed.

Lemma Rmax_Rlt : forall x y z,
  Rmax x y < z <-> x < z /\ y < z.
Proof.
intros x y z; split.
 unfold Rmax; case (Rle_dec x y).
  intros xy yz; split;[apply Rle_lt_trans with y|]; assumption.
  intros xz xy; split;[|apply Rlt_trans with x;[apply Rnot_le_gt|]];assumption.
 intros [h h']; apply Rmax_lub_lt; assumption.
Qed.

(*********)
Lemma Rmax_neg : forall x y:R, x < 0 -> y < 0 -> Rmax x y < 0.
Proof.
  intros; unfold Rmax.
  case (Rle_dec x y); intro; assumption.
Qed.

(*******************************)
(** *        Rabsolu           *)
(*******************************)

(*********)
Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}.
Proof.
  intro; generalize (Rle_dec 0 r); intro X; elim X; intro H; clear X.
  right; apply (Rle_ge 0 r H).
  left; fold (0 > r); apply (Rnot_le_lt 0 r H).
Qed.

(*********)
Definition Rabs r : R :=
  match Rcase_abs r with
    | left _ => - r
    | right _ => r
  end.

(*********)
Lemma Rabs_R0 : Rabs 0 = 0.
Proof.
  unfold Rabs; case (Rcase_abs 0); auto; intro.
  generalize (Rlt_irrefl 0); intro; exfalso; auto.
Qed.

Lemma Rabs_R1 : Rabs 1 = 1.
Proof.
unfold Rabs; case (Rcase_abs 1); auto with real.
intros H; absurd (1 < 0); auto with real.
Qed.

(*********)
Lemma Rabs_no_R0 : forall r, r <> 0 -> Rabs r <> 0.
Proof.
  intros; unfold Rabs; case (Rcase_abs r); intro; auto.
  apply Ropp_neq_0_compat; auto.
Qed.

(*********)
Lemma Rabs_left : forall r, r < 0 -> Rabs r = - r.
Proof.
  intros; unfold Rabs; case (Rcase_abs r); trivial; intro;
    absurd (r >= 0).
  exact (Rlt_not_ge r 0 H).
  assumption.
Qed.

(*********)
Lemma Rabs_right : forall r, r >= 0 -> Rabs r = r.
Proof.
  intros; unfold Rabs; case (Rcase_abs r) as [Hlt|Hge].
  absurd (r >= 0).
  exact (Rlt_not_ge r 0 Hlt).
  assumption.
  trivial.
Qed.

Lemma Rabs_left1 : forall a:R, a <= 0 -> Rabs a = - a.
Proof.
  intros a H; case H; intros H1.
  apply Rabs_left; auto.
  rewrite H1; simpl; rewrite Rabs_right; auto with real.
Qed.

(*********)
Lemma Rabs_pos : forall x:R, 0 <= Rabs x.
Proof.
  intros; unfold Rabs; case (Rcase_abs x) as [Hlt|Hge].
  generalize (Ropp_lt_gt_contravar x 0 Hlt); intro; unfold Rgt in H;
    rewrite Ropp_0 in H; left; assumption.
  apply Rge_le; assumption.
Qed.

Lemma Rle_abs : forall x:R, x <= Rabs x.
Proof.
  intro; unfold Rabs; case (Rcase_abs x); intros; fourier.
Qed.

Definition RRle_abs := Rle_abs.

Lemma Rabs_le : forall a b, -b <= a <= b -> Rabs a <= b.
Proof.
intros a b; unfold Rabs; case Rcase_abs.
 intros _ [it _]; apply Ropp_le_cancel; rewrite Ropp_involutive; exact it.
intros _ [_ it]; exact it.
Qed.

(*********)
Lemma Rabs_pos_eq : forall x:R, 0 <= x -> Rabs x = x.
Proof.
  intros; unfold Rabs; case (Rcase_abs x) as [Hlt|Hge];
    [ generalize (Rgt_not_le 0 x Hlt); intro; exfalso; auto | trivial ].
Qed.

(*********)
Lemma Rabs_Rabsolu : forall x:R, Rabs (Rabs x) = Rabs x.
Proof.
  intro; apply (Rabs_pos_eq (Rabs x) (Rabs_pos x)).
Qed.

(*********)
Lemma Rabs_pos_lt : forall x:R, x <> 0 -> 0 < Rabs x.
Proof.
  intros; destruct (Rabs_pos x) as [|Heq]; auto.
  apply Rabs_no_R0 in H; symmetry in Heq; contradiction.
Qed.

(*********)
Lemma Rabs_minus_sym : forall x y:R, Rabs (x - y) = Rabs (y - x).
Proof.
  intros; unfold Rabs; case (Rcase_abs (x - y)) as [Hlt|Hge];
    case (Rcase_abs (y - x)) as [Hlt'|Hge'].
  apply Rminus_lt, Rlt_asym in Hlt; apply Rminus_lt in Hlt'; contradiction.
  rewrite (Ropp_minus_distr x y); trivial.
  rewrite (Ropp_minus_distr y x); trivial.
  destruct Hge; destruct Hge'.
  apply Ropp_lt_gt_0_contravar in H; rewrite (Ropp_minus_distr x y) in H;
    apply Rlt_asym in H0; contradiction.
  apply Rminus_diag_uniq in H0 as ->; trivial.
  apply Rminus_diag_uniq in H as ->; trivial.
  apply Rminus_diag_uniq in H0 as ->; trivial.
Qed.

(*********)
Lemma Rabs_mult : forall x y:R, Rabs (x * y) = Rabs x * Rabs y.
Proof.
  intros; unfold Rabs; case (Rcase_abs (x * y)) as [Hlt|Hge];
    case (Rcase_abs x) as [Hltx|Hgex];
    case (Rcase_abs y) as [Hlty|Hgey]; auto.
  apply Rmult_lt_gt_compat_neg_l with (r:=x), Rlt_asym in Hlty; trivial.
    rewrite Rmult_0_r in Hlty; contradiction.
  rewrite (Ropp_mult_distr_l_reverse x y); trivial.
  rewrite (Rmult_comm x (- y)); rewrite (Ropp_mult_distr_l_reverse y x);
    rewrite (Rmult_comm x y); trivial.
  destruct Hgex as [| ->], Hgey as [| ->].
  apply Rmult_lt_compat_l with (r:=x), Rlt_asym in H0; trivial.
    rewrite Rmult_0_r in H0; contradiction.
  rewrite Rmult_0_r in Hlt; contradiction (Rlt_irrefl 0).
  rewrite Rmult_0_l in Hlt; contradiction (Rlt_irrefl 0).
  rewrite Rmult_0_l in Hlt; contradiction (Rlt_irrefl 0).
  rewrite (Rmult_opp_opp x y); trivial.
  destruct Hge. destruct Hgey.
  apply Rmult_lt_compat_r with (r:=y), Rlt_asym in Hltx; trivial.
    rewrite Rmult_0_l in Hltx; contradiction.
  rewrite H0, Rmult_0_r in H; contradiction (Rlt_irrefl 0).
  rewrite <- Ropp_mult_distr_l, H, Ropp_0; trivial.
  destruct Hge. destruct Hgex.
  apply Rmult_lt_compat_l with (r:=x), Rlt_asym in Hlty; trivial.
    rewrite Rmult_0_r in Hlty; contradiction.
  rewrite H0, 2!Rmult_0_l; trivial.
  rewrite <- Ropp_mult_distr_r, H, Ropp_0; trivial.
Qed.

(*********)
Lemma Rabs_Rinv : forall r, r <> 0 -> Rabs (/ r) = / Rabs r.
Proof.
  intro; unfold Rabs; case (Rcase_abs r) as [Hlt|Hge];
    case (Rcase_abs (/ r)) as [Hlt'|Hge']; auto;
    intros.
  apply Ropp_inv_permute; auto.
  rewrite <- Ropp_inv_permute; trivial.
  destruct Hge' as [| ->].
  apply Rinv_lt_0_compat, Rlt_asym in Hlt; contradiction.
  rewrite Ropp_0; trivial.
  destruct Hge as [| ->].
  apply Rinv_0_lt_compat, Rlt_asym in H0; contradiction.
  contradiction (refl_equal 0).
Qed.

Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x.
Proof.
  intro; replace (-x) with (-1 * x) by ring.
  rewrite Rabs_mult.
  replace (Rabs (-1)) with 1.
  apply Rmult_1_l.
  unfold Rabs; case (Rcase_abs (-1)).
  intro; ring.
  rewrite <- Ropp_0.
  intro H0; apply Ropp_ge_cancel in H0.
  elim (Rge_not_lt _ _ H0).
  apply Rlt_0_1.
Qed.

(*********)
Lemma Rabs_triang : forall a b:R, Rabs (a + b) <= Rabs a + Rabs b.
Proof.
  intros a b; unfold Rabs; case (Rcase_abs (a + b)) as [Hlt|Hge];
    case (Rcase_abs a) as [Hlta|Hgea];
    case (Rcase_abs b) as [Hltb|Hgeb].
  apply (Req_le (- (a + b)) (- a + - b)); rewrite (Ropp_plus_distr a b);
    reflexivity.
(**)
  rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b);
    unfold Rle; elim Hgeb; intro.
  left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro;
    elim (Rplus_ne (- b)); intros v w; rewrite v in H0;
      clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H).
  right; rewrite H; apply Ropp_0.
(**)
  rewrite (Ropp_plus_distr a b); rewrite (Rplus_comm (- a) (- b));
    rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a);
      unfold Rle; elim Hgea; intro.
  left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro;
    elim (Rplus_ne (- a)); intros v w; rewrite v in H0;
      clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H).
  right; rewrite H; apply Ropp_0.
(**)
  exfalso; generalize (Rplus_ge_compat_l a b 0 Hgeb); intro;
    elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
      generalize (Rge_trans (a + b) a 0 H Hgea); intro; clear H;
        unfold Rge in H0; elim H0; intro; clear H0.
  unfold Rgt in H; generalize (Rlt_asym (a + b) 0 Hlt); intro; auto.
  absurd (a + b = 0); auto.
  apply (Rlt_dichotomy_converse (a + b) 0); left; assumption.
(**)
  exfalso; generalize (Rplus_lt_compat_l a b 0 Hltb); intro;
    elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
      generalize (Rlt_trans (a + b) a 0 H Hlta); intro; clear H;
        destruct Hge.
  unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro;
    apply (Rlt_irrefl (a + b)); assumption.
  rewrite H in H0; apply (Rlt_irrefl 0); assumption.
(**)
  rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b);
    apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a));
      unfold Rminus; rewrite (Ropp_involutive a);
        generalize (Rplus_lt_compat_l a a 0 Hlta); clear Hge Hgeb;
          intro; elim (Rplus_ne a); intros v w; rewrite v in H;
            clear v w; generalize (Rlt_trans (a + a) a 0 H Hlta);
              intro; apply (Rlt_le (a + a) 0 H0).
(**)
  apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b));
    unfold Rminus; rewrite (Ropp_involutive b);
      generalize (Rplus_lt_compat_l b b 0 Hltb); clear Hge Hgea;
        intro; elim (Rplus_ne b); intros v w; rewrite v in H;
          clear v w; generalize (Rlt_trans (b + b) b 0 H Hltb);
            intro; apply (Rlt_le (b + b) 0 H0).
(**)
  unfold Rle; right; reflexivity.
Qed.

(*********)
Lemma Rabs_triang_inv : forall a b:R, Rabs a - Rabs b <= Rabs (a - b).
Proof.
  intros; apply (Rplus_le_reg_l (Rabs b) (Rabs a - Rabs b) (Rabs (a - b)));
    unfold Rminus; rewrite <- (Rplus_assoc (Rabs b) (Rabs a) (- Rabs b));
      rewrite (Rplus_comm (Rabs b) (Rabs a));
        rewrite (Rplus_assoc (Rabs a) (Rabs b) (- Rabs b));
          rewrite (Rplus_opp_r (Rabs b)); rewrite (proj1 (Rplus_ne (Rabs a)));
            replace (Rabs a) with (Rabs (a + 0)).
  rewrite <- (Rplus_opp_r b); rewrite <- (Rplus_assoc a b (- b));
    rewrite (Rplus_comm a b); rewrite (Rplus_assoc b a (- b)).
  exact (Rabs_triang b (a + - b)).
  rewrite (proj1 (Rplus_ne a)); trivial.
Qed.

(* ||a|-|b||<=|a-b| *)
Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b).
Proof.
  cut
    (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)).
  intros; destruct (Rtotal_order (Rabs a) (Rabs b)) as [Hlt| [Heq| Hgt]].
  rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b));
    do 2 rewrite Ropp_minus_distr.
  apply H; left; assumption.
  rewrite Heq; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
    apply Rabs_pos.
  apply H; left; assumption.
  intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b).
  apply Rabs_triang_inv.
  rewrite (Rabs_right (Rabs a - Rabs b));
    [ reflexivity
      | apply Rle_ge; apply Rplus_le_reg_l with (Rabs b); rewrite Rplus_0_r;
        replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a);
        [ assumption | ring ] ].
Qed.

(*********)
Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a.
Proof.
  unfold Rabs; intros; case (Rcase_abs x); intro.
  generalize (Ropp_lt_gt_contravar (- a) x H0); unfold Rgt;
    rewrite Ropp_involutive; intro; assumption.
  assumption.
Qed.

(*********)
Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x.
Proof.
  unfold Rabs; intro x; case (Rcase_abs x) as [Hlt|Hge]; intros.
  generalize (Ropp_gt_lt_0_contravar x Hlt); unfold Rgt; intro;
    generalize (Rlt_trans 0 (- x) a H0 H); intro; split.
  apply (Rlt_trans x 0 a Hlt H1).
  generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x);
    unfold Rgt; trivial.
  fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H Hge); intro;
    generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a);
      generalize (Rge_gt_trans x 0 (- a) Hge H1); unfold Rgt;
        intro; split; assumption.
Qed.

Lemma RmaxAbs :
  forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r).
Proof.
  intros p q r H' H'0; case (Rle_or_lt 0 p); intros H'1.
  repeat rewrite Rabs_right; auto with real.
  apply Rle_trans with r; auto with real.
  apply RmaxLess2; auto.
  apply Rge_trans with p; auto with real; apply Rge_trans with q;
    auto with real.
  apply Rge_trans with p; auto with real.
  rewrite (Rabs_left p); auto.
  case (Rle_or_lt 0 q); intros H'2.
  repeat rewrite Rabs_right; auto with real.
  apply Rle_trans with r; auto.
  apply RmaxLess2; auto.
  apply Rge_trans with q; auto with real.
  rewrite (Rabs_left q); auto.
  case (Rle_or_lt 0 r); intros H'3.
  repeat rewrite Rabs_right; auto with real.
  apply Rle_trans with (- p); auto with real.
  apply RmaxLess1; auto.
  rewrite (Rabs_left r); auto.
  apply Rle_trans with (- p); auto with real.
  apply RmaxLess1; auto.
Qed.

Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Z.abs z).
Proof.
  intros z; case z; unfold Z.abs.
  apply Rabs_R0.
  now intros p0; apply Rabs_pos_eq, (IZR_le 0).
  unfold IZR at 1.
  intros p0; rewrite Rabs_Ropp.
  now apply Rabs_pos_eq, (IZR_le 0).
Qed.

Lemma abs_IZR : forall z, IZR (Z.abs z) = Rabs (IZR z).
Proof.
  intros.
  now rewrite Rabs_Zabs.
Qed.

Lemma Ropp_Rmax : forall x y, - Rmax x y = Rmin (-x) (-y).
intros x y; apply Rmax_case_strong.
 now intros w; rewrite Rmin_left;[ | apply Rge_le, Ropp_le_ge_contravar].
now intros w; rewrite Rmin_right; [ | apply Rge_le, Ropp_le_ge_contravar].
Qed.

Lemma Ropp_Rmin : forall x y, - Rmin x y = Rmax (-x) (-y).
intros x y; apply Rmin_case_strong.
 now intros w; rewrite Rmax_left;[ | apply Rge_le, Ropp_le_ge_contravar].
now intros w; rewrite Rmax_right; [ | apply Rge_le, Ropp_le_ge_contravar].
Qed.

Lemma Rmax_assoc : forall a b c, Rmax a (Rmax b c) = Rmax (Rmax a b) c.
Proof.
intros a b c.
unfold Rmax; destruct (Rle_dec b c); destruct (Rle_dec a b);
  destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real;
  match goal with
  | id :  ~ ?x <= ?y, id2 : ?x <= ?z |- _ =>
   case id; apply Rle_trans with z; auto with real
  | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ =>
   case id; apply Rle_trans with z; auto with real
  end.
Qed.

Lemma Rminmax : forall a b, Rmin a b <= Rmax a b.
Proof.
intros a b; destruct (Rle_dec a b).
 rewrite Rmin_left, Rmax_right; assumption.
now rewrite Rmin_right, Rmax_left; assumption ||
  apply Rlt_le, Rnot_le_gt.
Qed.

Lemma Rmin_assoc : forall x y z, Rmin x (Rmin y z) =
  Rmin (Rmin x y) z.
Proof.
intros a b c.
unfold Rmin; destruct (Rle_dec b c); destruct (Rle_dec a b);
  destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real;
  match goal with
  | id :  ~ ?x <= ?y, id2 : ?x <= ?z |- _ =>
   case id; apply Rle_trans with z; auto with real
  | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ =>
   case id; apply Rle_trans with z; auto with real
  end.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   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 list.List.
Require list.Length.
Require list.Mem.
Require list.Append.
Require list.Reverse.

(* Why3 goal *)
Lemma rev_append_def1 : forall {a:Type} {a_WT:WhyType a},
  forall (s:(list a)) (t:(list a)),
   ((Lists.List.rev_append s t) = match s with
                                  | (Init.Datatypes.cons x r) =>
                                      (Lists.List.rev_append r (Init.Datatypes.cons x t))
                                  | Init.Datatypes.nil => t
                                  end).
intros a a_WT s t.
destruct s; simpl; auto.
Qed.

(* Why3 goal *)
Lemma rev_append_append_l :
forall {a:Type} {a_WT:WhyType a},
forall (r:(list a)) (s:(list a)) (t:(list a)),
 ((Lists.List.rev_append (Init.Datatypes.app r s) t) = (Lists.List.rev_append s (Lists.List.rev_append r t))).
Proof.
intros a a_WT r s.
induction r as [|rh rt IHr].
easy.
now simpl.
Qed.

(* Why3 goal *)
Lemma rev_append_length :
forall {a:Type} {a_WT:WhyType a},
forall (s:(list a)) (t:(list a)),
 ((list.Length.length (Lists.List.rev_append s t)) = ((list.Length.length s) +
 (list.Length.length t))%Z).
Proof.
intros a a_WT s.
induction s as [|sh st IHs].
easy.
intros t.
simpl List.rev_append.
rewrite IHs.
change (Length.length (sh :: t)) with (1 + Length.length t)%Z.
change (Length.length (sh :: st)) with (1 + Length.length st)%Z.
ring.
Qed.

(* Why3 goal *)
Lemma rev_append_def :
forall {a:Type} {a_WT:WhyType a},
forall (r:(list a)) (s:(list a)),
 ((Lists.List.rev_append r s) = (Init.Datatypes.app (Lists.List.rev r) s)).
Proof.
induction r; simpl.
now auto.
intro s; rewrite IHr.
rewrite <- Append.Append_assoc.
simpl. reflexivity.
Qed.

(* Why3 goal *)
Lemma rev_append_append_r :
forall {a:Type} {a_WT:WhyType a},
forall (r:(list a)) (s:(list a)) (t:(list a)),
 ((Lists.List.rev_append r (Init.Datatypes.app s t)) = (Lists.List.rev_append (Lists.List.rev_append s r) t)).
Proof.
intros a a_WT r s t.
revert r.
induction s as [|sh st IHs].
easy.
intros r.
simpl.
now rewrite <- IHs.
Qed.


Set Implicit Arguments.

Require Coq.Arith.Compare_dec.

Require Import Coq.Structures.OrderedType.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.FSets.FSetAVL.
Require Import Coq.Arith.Peano_dec.
Require Import Omega.

Require Import Aniceto.Map.

Require Coq.FSets.FMapFacts.

Inductive mid := memid : nat -> mid.

Definition mid_nat r := match r with | memid n => n end.

Definition mid_first := memid 0.

Definition mid_next m := memid (S (mid_nat m)).

Module MID <: UsualOrderedType.
  Definition t := mid.
  Definition eq := @eq t.
  Definition lt x y := lt (mid_nat x) (mid_nat y).
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.
  Lemma lt_trans: forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    intros.
    unfold lt in *.
    destruct x, y, z.
    simpl in *.
    omega.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    unfold lt in *.
    intros.
    destruct x, y.
    simpl in *.
    unfold not; intros.
    inversion H0.
    subst.
    apply Lt.lt_irrefl in H.
    inversion H.
  Qed.

  Import Coq.Arith.Compare_dec.
  Lemma compare:
    forall x y, Compare lt eq x y.
  Proof.
    intros.
    destruct x, y.
    destruct (Nat_as_OT.compare n n0);
    eauto using LT, GT.
    apply EQ.
    unfold Nat_as_OT.eq in *.
    subst.
    intuition.
  Qed.

  Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
  Proof.
    intros.
    unfold eq.
    destruct x, y.
    destruct (eq_nat_dec n n0).
    - subst; eauto.
    - right.
      unfold not.
      intros.
      contradiction n1.
      inversion H; auto.
  Qed.
End MID.

Lemma mid_eq_rw:
  forall x y, MID.eq x y <-> x = y.
Proof.
  intros.
  auto with *.
Qed.

Definition eqb (x y:mid) := if MID.eq_dec x y then true else false.

Module MM := FMapAVL.Make MID.
Module MM_Facts := FMapFacts.Facts MM.
Module MM_Extra := MapUtil MM.

Module SM := FSetAVL.Make MID.
Definition set_mid := SM.t.

Section NotIn.
  Variable elt:Type.

  Let lt_irrefl:
    forall x : mid, ~ MID.lt x x.
  Proof.
    unfold not; intros.
    apply MID.lt_not_eq in H.
    contradiction H.
    apply MID.eq_refl.
  Qed.

  Let lt_next:
    forall x : mid, MID.lt x (mid_next x).
  Proof.
    intros.
    destruct x.
    unfold mid_next, mid_nat, MID.lt.
    simpl.
    auto.
  Qed.

  Let mid_impl_eq:
    forall k k' : mid, k = k' -> k = k'.
  Proof.
    auto.
  Qed.

  Definition supremum {elt:Type} := @MM_Extra.supremum elt mid_first mid_next MID.lt MID.compare.

  Theorem find_not_in:
    forall (m: MM.t elt),
    ~ MM.In (supremum m) m.
  Proof.
    intros.
    eauto using MM_Extra.find_not_in, MID.lt_trans.
  Qed.

End NotIn.

Lemma mid_eq_dec:
  forall x y : mid, {x = y} + {x <> y}.
Proof.
  auto using mid_eq_rw, MID.eq_dec.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (lf2 : natural) : natural := lf2.


Require Import List.

CoInductive CoNat : Type :=
| Z : CoNat
| S : CoNat -> CoNat.

CoFixpoint inf : CoNat := S(inf).

Eval compute in inf.

Definition isZero (n:CoNat) :=
  match n with
    | Z => True
    | S n' => False
  end.

Eval compute in (isZero inf).

Ltac circle :=
  match goal with
    | [ H : ((context[?x]) = ?x) |- _ ] => induction x ; inversion H ; congruence
  end.

Lemma nocirc : forall (A : Set) (h : A) (t : list A), cons h t  = t -> False.
  intros A h t H'. circle.
  intros A h t H'. induction t. inversion H'. congruence.
Defined.


Require Import init.

Require Export linear_base.
Require Import linear_subspace.
Require Import set.
Require Import unordered_list.

Definition linear_span U {V} `{Plus V, Zero V, ScalarMult U V}
    (S : V → Prop) :=
    λ v, ∀ sub : Subspace U V, S ⊆ subspace_set sub → subspace_set sub v.

(* begin hide *)
Section Span.

Context U {V} `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    UM : Mult U,
    UO : One U,
    UD : Div U,
    @PlusComm U UP,
    @PlusLid U UP UZ,
    @PlusLinv U UP UZ UN,
    @MultAssoc U UM,
    @MultLid U UM UO,
    @MultLinv U UZ UM UO UD,

    VP : Plus V,
    VZ : Zero V,
    VN : Neg V,
    @PlusComm V VP,
    @PlusAssoc V VP,
    @PlusLid V VP VZ,
    @PlusLinv V VP VZ VN,

    SM : ScalarMult U V,
    @ScalarComp U V UM SM,
    @ScalarId U V UO SM,
    @ScalarLdist U V VP SM,
    @ScalarRdist U V UP VP SM
}.
(* end hide *)
Variable A : V → Prop.

Let S := linear_span U A.

Lemma linear_span_zero : S 0.
Proof.
    intros [T T_zero T_plus T_scalar]; cbn.
    intros sub.
    exact T_zero.
Qed.
Lemma linear_span_plus : ∀ a b, S a → S b → S (a + b).
Proof.
    intros a b Sa Sb T sub.
    specialize (Sa T sub).
    specialize (Sb T sub).
    apply subspace_plus; assumption.
Qed.
Lemma linear_span_scalar : ∀ a v, S v → S (a · v).
Proof.
    intros a v Sv T sub.
    specialize (Sv T sub).
    apply subspace_scalar.
    exact Sv.
Qed.

Definition linear_span_subspace := make_subspace S
    linear_span_zero linear_span_plus linear_span_scalar.

Theorem linear_span_sub : A ⊆ S.
Proof.
    intros v Av.
    unfold S, linear_span.
    intros sub A_sub.
    apply A_sub.
    exact Av.
Qed.

Definition linear_span_quotient := quotient_space linear_span_subspace.
Definition to_quotient v :=
    to_equiv (subspace_equiv linear_span_subspace) v.
Definition linear_span_quotient_plus
    := quotient_space_plus linear_span_subspace.
Definition linear_span_quotient_plus_assoc
    := quotient_space_plus_assoc linear_span_subspace.
Definition linear_span_quotient_plus_comm
    := quotient_space_plus_comm linear_span_subspace.
Definition linear_span_quotient_zero
    := quotient_space_zero linear_span_subspace.
Definition linear_span_quotient_plus_lid
    := quotient_space_plus_lid linear_span_subspace.
Definition linear_span_quotient_neg
    := quotient_space_neg linear_span_subspace.
Definition linear_span_quotient_plus_linv
    := quotient_space_plus_linv linear_span_subspace.
Definition linear_span_quotient_scalar_mult
    := quotient_space_scalar_mult linear_span_subspace.
Definition linear_span_quotient_scalar_comp
    := quotient_space_scalar_comp linear_span_subspace.
Definition linear_span_quotient_scalar_id
    := quotient_space_scalar_id linear_span_subspace.
Definition linear_span_quotient_scalar_ldist
    := quotient_space_scalar_ldist linear_span_subspace.
Definition linear_span_quotient_scalar_rdist
    := quotient_space_scalar_rdist linear_span_subspace.

Theorem span_linear_combination : S = linear_combination_of A.
Proof.
    pose (A_sub := make_subspace _ (linear_combination_of_zero A)
        (linear_combination_of_plus A) (linear_combination_of_scalar A)).
    apply antisym.
    -   intros v Sv.
        unfold S, linear_span in Sv.
        apply (Sv A_sub).
        cbn.
        clear v Sv.
        intros v Av.
        pose (l := (1, v) ː ulist_end).
        assert (linear_combination_set l) as l_comb.
        {
            unfold linear_combination_set, l.
            rewrite ulist_image_add, ulist_unique_add.
            rewrite ulist_image_end.
            split.
            -   apply in_ulist_end.
            -   apply ulist_unique_end.
        }
        exists [l|l_comb]; cbn.
        split.
        +   unfold linear_combination, l; cbn.
            rewrite ulist_image_add, ulist_sum_add; cbn.
            rewrite scalar_id.
            rewrite ulist_image_end, ulist_sum_end.
            rewrite plus_rid.
            reflexivity.
        +   unfold l, linear_list_in; cbn.
            rewrite ulist_prop_add; cbn.
            split; [>exact Av|apply ulist_prop_end].
    -   intros v [l [v_eq Sv]].
        rewrite v_eq; clear v_eq.
        apply (subspace_linear_combination linear_span_subspace).
        cbn.
        unfold linear_list_in in *.
        eapply (ulist_prop_sub _ _ _ _ Sv).
        Unshelve.
        intros x.
        apply linear_span_sub.
Qed.
(* begin hide *)

End Span.
(* end hide *)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*            [*] Affiliation LORIA -- CNRS                   *)
(*            [+] Affiliation VERIMAG - Univ. Grenoble-Alpes  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Lia Utf8. (* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ *)

Require Import nm_graph_def nm_fun nm_props_def.

Set Implicit Arguments.

Theorem nm_equiv e D : e ~Ω nm e D.
Proof.
  generalize (nm _ D) (nm_spec D); clear D.
  induction 1 as [
                 |
                 | a b c y z nb nc na H1 IH1 H2 IH2 H3 IH3 ]; auto.
  apply equiv_trans with (1 := in_eq_0 _ _ _ _ _),
        equiv_trans with (2 := IH3),
        in_eq_1; auto.
Qed.

Theorem nm_normal e D : normal (nm e D).
Proof.
 generalize (nm _ D) (nm_spec D); clear D.
 induction 1; auto.
Qed.

Hint Resolve ce_size_sub_2 ce_size_sub_3 ce_size_mono ce_size_smono_1 : core.

(** nm preserves the measure *)

Theorem nm_dec e D : ⟪nm e D⟫ ≤ ⟪e⟫.
Proof.
  generalize (nm _ D) (nm_spec D); clear D.
  induction 1 as [
                 | y ny z nz H1 IH1 H2 IH2
                 | a b c y z nb nc na H1 IH1 H2 IH2 H3 IH3 ]; auto.
  apply le_trans with (1 := IH3),
        le_trans with (2 := ce_size_special _ _ _ _ _); auto.
Qed.


Require Import Sail.Values.
Require List.
Import List.ListNotations.
Local Open Scope Z.

(*** Bit vector operations *)

Section Bitvectors.
Context {a b c} `{Bitvector a} `{Bitvector b} `{Bitvector c}.

(*val concat_bv : forall 'a 'b 'c. Bitvector 'a, Bitvector 'b, Bitvector 'c => 'a -> 'b -> 'c*)
Definition concat_bv (l : a) (r : b) : list bitU := bits_of l ++ bits_of r.

(*val cons_bv : forall 'a 'b 'c. Bitvector 'a, Bitvector 'b => bitU -> 'a -> 'b*)
Definition cons_bv b' (v : a) : list bitU := b' :: bits_of v.

Definition cast_unit_bv b : list bitU := [b].
Definition bv_of_bit len b : list bitU := extz_bits len [b].

(*Definition most_significant v := match bits_of v with
  | cons b _ => b
  | _ => failwith "most_significant applied to empty vector"
  end.

Definition get_max_representable_in sign (n : integer) : integer :=
  if (n = 64) then match sign with | true -> max_64 | false -> max_64u end
  else if (n=32) then match sign with | true -> max_32 | false -> max_32u end
  else if (n=8) then max_8
  else if (n=5) then max_5
  else match sign with | true -> integerPow 2 ((natFromInteger n) -1)
                       | false -> integerPow 2 (natFromInteger n)
       end

Definition get_min_representable_in _ (n : integer) : integer :=
  if n = 64 then min_64
  else if n = 32 then min_32
  else if n = 8 then min_8
  else if n = 5 then min_5
  else 0 - (integerPow 2 (natFromInteger n))

val arith_op_bv_int : forall 'a 'b. Bitvector 'a =>
  (integer -> integer -> integer) -> bool -> 'a -> integer -> 'a*)
Definition arith_op_bv_int {a} `{Bitvector a} (op : Z -> Z -> Z) (sign : bool) (l : a) (r : Z) : a :=
  let r' := of_int (length l) r in
  arith_op_bv op sign l r'.

(*val arith_op_int_bv : forall 'a 'b. Bitvector 'a =>
  (integer -> integer -> integer) -> bool -> integer -> 'a -> 'a*)
Definition arith_op_int_bv {a} `{Bitvector a} (op : Z -> Z -> Z) (sign : bool) (l : Z) (r : a) : a :=
  let l' := of_int (length r) l in
  arith_op_bv op sign l' r.
(*
Definition add_bv_int := arith_op_bv_int Zplus false 1.
Definition sadd_bv_int := arith_op_bv_int Zplus true 1.
Definition sub_bv_int := arith_op_bv_int Zminus false 1.
Definition mult_bv_int := arith_op_bv_int Zmult false 2.
Definition smult_bv_int := arith_op_bv_int Zmult true 2.

(*val arith_op_int_bv : forall 'a 'b. Bitvector 'a, Bitvector 'b =>
  (integer -> integer -> integer) -> bool -> integer -> integer -> 'a -> 'b
Definition arith_op_int_bv op sign size l r :=
  let r' = int_of_bv sign r in
  let n = op l r' in
  of_int (size * length r) n

Definition add_int_bv = arith_op_int_bv integerAdd false 1
Definition sadd_int_bv = arith_op_int_bv integerAdd true 1
Definition sub_int_bv = arith_op_int_bv integerMinus false 1
Definition mult_int_bv = arith_op_int_bv integerMult false 2
Definition smult_int_bv = arith_op_int_bv integerMult true 2

Definition arith_op_bv_bit op sign (size : integer) l r :=
  let l' = int_of_bv sign l in
  let n = op l' (match r with | B1 -> (1 : integer) | _ -> 0 end) in
  of_int (size * length l) n

Definition add_bv_bit := arith_op_bv_bit integerAdd false 1
Definition sadd_bv_bit := arith_op_bv_bit integerAdd true 1
Definition sub_bv_bit := arith_op_bv_bit integerMinus true 1

val arith_op_overflow_bv : forall 'a 'b. Bitvector 'a, Bitvector 'b =>
  (integer -> integer -> integer) -> bool -> integer -> 'a -> 'a -> ('b * bitU * bitU)
Definition arith_op_overflow_bv op sign size l r :=
  let len := length l in
  let act_size := len * size in
  let (l_sign,r_sign) := (int_of_bv sign l,int_of_bv sign r) in
  let (l_unsign,r_unsign) := (int_of_bv false l,int_of_bv false r) in
  let n := op l_sign r_sign in
  let n_unsign := op l_unsign r_unsign in
  let correct_size := of_int act_size n in
  let one_more_size_u := bits_of_int (act_size + 1) n_unsign in
  let overflow :=
    if n <= get_max_representable_in sign len &&
         n >= get_min_representable_in sign len
    then B0 else B1 in
  let c_out := most_significant one_more_size_u in
  (correct_size,overflow,c_out)

Definition add_overflow_bv := arith_op_overflow_bv integerAdd false 1
Definition add_overflow_bv_signed := arith_op_overflow_bv integerAdd true 1
Definition sub_overflow_bv := arith_op_overflow_bv integerMinus false 1
Definition sub_overflow_bv_signed := arith_op_overflow_bv integerMinus true 1
Definition mult_overflow_bv := arith_op_overflow_bv integerMult false 2
Definition mult_overflow_bv_signed := arith_op_overflow_bv integerMult true 2

val arith_op_overflow_bv_bit : forall 'a 'b. Bitvector 'a, Bitvector 'b =>
  (integer -> integer -> integer) -> bool -> integer -> 'a -> bitU -> ('b * bitU * bitU)
Definition arith_op_overflow_bv_bit op sign size l r_bit :=
  let act_size := length l * size in
  let l' := int_of_bv sign l in
  let l_u := int_of_bv false l in
  let (n,nu,changed) := match r_bit with
    | B1 -> (op l' 1, op l_u 1, true)
    | B0 -> (l',l_u,false)
    | BU -> failwith "arith_op_overflow_bv_bit applied to undefined bit"
    end in
  let correct_size := of_int act_size n in
  let one_larger := bits_of_int (act_size + 1) nu in
  let overflow :=
    if changed
    then
      if n <= get_max_representable_in sign act_size && n >= get_min_representable_in sign act_size
      then B0 else B1
    else B0 in
  (correct_size,overflow,most_significant one_larger)

Definition add_overflow_bv_bit := arith_op_overflow_bv_bit integerAdd false 1
Definition add_overflow_bv_bit_signed := arith_op_overflow_bv_bit integerAdd true 1
Definition sub_overflow_bv_bit := arith_op_overflow_bv_bit integerMinus false 1
Definition sub_overflow_bv_bit_signed := arith_op_overflow_bv_bit integerMinus true 1

type shift := LL_shift | RR_shift | RR_shift_arith | LL_rot | RR_rot

val shift_op_bv : forall 'a. Bitvector 'a => shift -> 'a -> integer -> 'a
Definition shift_op_bv op v n :=
  match op with
  | LL_shift ->
     of_bits (get_bits true v n (length v - 1) ++ repeat [B0] n)
  | RR_shift ->
     of_bits (repeat [B0] n ++ get_bits true v 0 (length v - n - 1))
  | RR_shift_arith ->
     of_bits (repeat [most_significant v] n ++ get_bits true v 0 (length v - n - 1))
  | LL_rot ->
     of_bits (get_bits true v n (length v - 1) ++ get_bits true v 0 (n - 1))
  | RR_rot ->
     of_bits (get_bits false v 0 (n - 1) ++ get_bits false v n (length v - 1))
  end

Definition shiftl_bv := shift_op_bv LL_shift (*"<<"*)
Definition shiftr_bv := shift_op_bv RR_shift (*">>"*)
Definition arith_shiftr_bv := shift_op_bv RR_shift_arith
Definition rotl_bv := shift_op_bv LL_rot (*"<<<"*)
Definition rotr_bv := shift_op_bv LL_rot (*">>>"*)

Definition shiftl_mword w n := Machine_word.shiftLeft w (natFromInteger n)
Definition shiftr_mword w n := Machine_word.shiftRight w (natFromInteger n)
Definition rotl_mword w n := Machine_word.rotateLeft (natFromInteger n) w
Definition rotr_mword w n := Machine_word.rotateRight (natFromInteger n) w

Definition rec arith_op_no0 (op : integer -> integer -> integer) l r :=
  if r = 0
  then Nothing
  else Just (op l r)

val arith_op_bv_no0 : forall 'a 'b. Bitvector 'a, Bitvector 'b =>
  (integer -> integer -> integer) -> bool -> integer -> 'a -> 'a -> 'b
Definition arith_op_bv_no0 op sign size l r :=
  let act_size := length l * size in
  let (l',r') := (int_of_bv sign l,int_of_bv sign r) in
  let n := arith_op_no0 op l' r' in
  let (representable,n') :=
    match n with
    | Just n' ->
      (n' <= get_max_representable_in sign act_size &&
         n' >= get_min_representable_in sign act_size, n')
    | _ -> (false,0)
    end in
  if representable then (of_int act_size n') else (of_bits (repeat [BU] act_size))

Definition mod_bv := arith_op_bv_no0 hardware_mod false 1
Definition quot_bv := arith_op_bv_no0 hardware_quot false 1
Definition quot_bv_signed := arith_op_bv_no0 hardware_quot true 1

Definition mod_mword := Machine_word.modulo
Definition quot_mword := Machine_word.unsignedDivide
Definition quot_mword_signed := Machine_word.signedDivide

Definition arith_op_bv_int_no0 op sign size l r :=
  arith_op_bv_no0 op sign size l (of_int (length l) r)

Definition quot_bv_int := arith_op_bv_int_no0 hardware_quot false 1
Definition mod_bv_int := arith_op_bv_int_no0 hardware_mod false 1
*)
Definition replicate_bits_bv {a b} `{Bitvector a} `{Bitvector b} (v : a) count : b := of_bits (repeat (bits_of v) count).
Import List.
Import ListNotations.
Definition duplicate_bit_bv {a} `{Bitvector a} bit len : a := replicate_bits_bv [bit] len.

(*val eq_bv : forall 'a. Bitvector 'a => 'a -> 'a -> bool*)
Definition eq_bv {A} `{Bitvector A} (l : A) r := (unsigned l =? unsigned r).

(*val neq_bv : forall 'a. Bitvector 'a => 'a -> 'a -> bool*)
Definition neq_bv (l : a) (r :a) : bool := (negb (unsigned l =? unsigned r)).
(*
val ucmp_bv : forall 'a. Bitvector 'a => (integer -> integer -> bool) -> 'a -> 'a -> bool
Definition ucmp_bv cmp l r := cmp (unsigned l) (unsigned r)

val scmp_bv : forall 'a. Bitvector 'a => (integer -> integer -> bool) -> 'a -> 'a -> bool
Definition scmp_bv cmp l r := cmp (signed l) (signed r)

Definition ult_bv := ucmp_bv (<)
Definition slt_bv := scmp_bv (<)
Definition ugt_bv := ucmp_bv (>)
Definition sgt_bv := scmp_bv (>)
Definition ulteq_bv := ucmp_bv (<=)
Definition slteq_bv := scmp_bv (<=)
Definition ugteq_bv := ucmp_bv (>=)
Definition sgteq_bv := scmp_bv (>=)
*)

(*val get_slice_int_bv : forall 'a. Bitvector 'a => integer -> integer -> integer -> 'a*)*)
Definition get_slice_int_bv {a} `{Bitvector a} len n lo : a :=
  let hi := lo + len - 1 in
  let bs := bools_of_int (hi + 1) n in
  of_bools (subrange_list false bs hi lo).

(*val set_slice_int_bv : forall 'a. Bitvector 'a => integer -> integer -> integer -> 'a -> integer
Definition set_slice_int_bv {a} `{Bitvector a} len n lo (v : a) :=
  let hi := lo + len - 1 in
  let bs := bits_of_int (hi + 1) n in
  maybe_failwith (signed_of_bits (update_subrange_list false bs hi lo (bits_of v))).*)

End Bitvectors.