Theorem Modus_tollens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P.
Proof.
  intros.
  intro.
  destruct H.
  apply H.
  apply H1.
  assumption.
Qed.


Module X.
  (*Set Universe Polymorphism.*)
  Inductive paths A (x : A) : forall _ : A, Type := idpath : paths A x x.
  Notation "x = y" := (@paths _ x y) (at level 70, no associativity) : type_scope.

  Axioms A B : Type.
  Axiom P : A = B.
  Definition foo : A = B.
    abstract (rewrite <- P; reflexivity).
  Defined.
End X.

Module Y.
  (*Set Universe Polymorphism.*)
  Inductive paths A (x : A) : forall _ : A, Type := idpath : paths A x x.
  Notation "x = y" := (@paths _ x y) (at level 70, no associativity) : type_scope.

  Axioms A B : Type.
  Axiom P : A = B.
  Definition foo : (A = B) * (A = B).
    split; abstract (rewrite <- P; reflexivity).
  Defined.
End Y.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Export ZAxioms ZMaxMin ZSgnAbs ZParity ZPow ZDivTrunc ZDivFloor
 ZGcd ZLcm NZLog NZSqrt ZBits.

(** This functor summarizes all known facts about Z. *)

Module Type ZProp (Z:ZAxiomsSig) :=
 ZMaxMinProp Z <+ ZSgnAbsProp Z <+ ZParityProp Z <+ ZPowProp Z
 <+ NZSqrtProp Z Z <+ NZSqrtUpProp Z Z
 <+ NZLog2Prop Z Z Z <+ NZLog2UpProp Z Z Z
 <+ ZDivProp Z <+ ZQuotProp Z <+ ZGcdProp Z <+ ZLcmProp Z
 <+ ZBitsProp Z.


(*** Interface for bounded arithmetic *)
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.AutoRewrite.
Require Import Crypto.Util.Notations.

Local Open Scope type_scope.
Local Open Scope Z_scope.

Class decoder (n : Z) W :=
  { decode : W -> Z }.
Coercion decode : decoder >-> Funclass.
Global Arguments decode {n W _} _.

Class is_decode {n W} (decode : decoder n W) :=
  decode_range : forall x, 0 <= decode x < 2^n.

Class bounded_in_range_cls (x y z : Z) := is_bounded_in_range : x <= y < z.
Ltac bounded_solver_tac :=
  solve [ eassumption | typeclasses eauto | omega ].
Hint Extern 0 (bounded_in_range_cls _ _ _) => unfold bounded_in_range_cls; bounded_solver_tac : typeclass_instances.
Global Arguments bounded_in_range_cls / _ _ _.
Global Instance decode_range_bound {n W} {decode : decoder n W} {H : is_decode decode}
  : forall x, bounded_in_range_cls 0 (decode x) (2^n)
  := H.

Class bounded_le_cls (x y : Z) := is_bounded_le : x <= y.
Hint Extern 0 (bounded_le_cls _ _) => unfold bounded_le_cls; bounded_solver_tac : typeclass_instances.
Global Arguments bounded_le_cls / _ _.

Inductive bounded_decode_pusher_tag := decode_tag.

Ltac push_decode_step :=
  match goal with
  | [ |- context[@decode ?n ?W ?decoder ?w] ]
    => tc_rewrite (decode_tag) (@decode n W decoder w) ->
  | [ |- context[match @fst ?A ?B ?x with true => 1 | false => 0 end] ]
    => tc_rewrite (decode_tag) (match @fst A B x with true => 1 | false => 0 end) ->
  | [ |- context[@fst bool ?B ?x] ]
    => tc_rewrite (decode_tag) (@fst bool B x) ->
  end.
Ltac push_decode := repeat push_decode_step.
Ltac pull_decode_step :=
  match goal with
  | [ |- context[?E] ]
    => lazymatch type of E with
       | Z => idtac
       | bool => idtac
       end;
       tc_rewrite (decode_tag) <- E
  end.
Ltac pull_decode := repeat pull_decode_step.

Delimit Scope bounded_rewrite_scope with bounded_rewrite.

Infix "<~=~>" := (rewrite_eq decode_tag) : bounded_rewrite_scope.
Infix "=~>" := (rewrite_left_to_right_eq decode_tag) : bounded_rewrite_scope.
Infix "<~=" := (rewrite_right_to_left_eq decode_tag) : bounded_rewrite_scope.
Notation "x <= y" := (bounded_le_cls x y) : bounded_rewrite_scope.
Notation "x <= y < z" := (bounded_in_range_cls x y z) : bounded_rewrite_scope.

Module Import BoundedRewriteNotations.
  Infix "<~=~>" := (rewrite_eq decode_tag) : type_scope.
  Infix "=~>" := (rewrite_left_to_right_eq decode_tag) : type_scope.
  Infix "<~=" := (rewrite_right_to_left_eq decode_tag) : type_scope.
  Open Scope bounded_rewrite_scope.
End BoundedRewriteNotations.

(** This is required for typeclass resolution to be fast. *)
Typeclasses Opaque decode.

Section InstructionGallery.
  Context (n : Z) (* bit-width of width of [W] *)
          {W : Type} (* bounded type, [W] for word *)
          (Wdecoder : decoder n W).
  Local Notation imm := Z (only parsing). (* immediate (compile-time) argument *)

  Class load_immediate := { ldi : imm -> W }.
  Global Coercion ldi : load_immediate >-> Funclass.

  Class is_load_immediate {ldi : load_immediate}  :=
    decode_load_immediate :> forall x, 0 <= x < 2^n -> decode (ldi x) =~> x.

  Class shift_right_doubleword_immediate := { shrd : W -> W -> imm -> W }.
  Global Coercion shrd : shift_right_doubleword_immediate >-> Funclass.

  Class is_shift_right_doubleword_immediate (shrd : shift_right_doubleword_immediate) :=
    decode_shift_right_doubleword :>
      forall high low count,
        0 <= count < n
        -> decode (shrd high low count) <~=~> (((decode high << n) + decode low) >> count) mod 2^n.

  (** Quoting http://www.felixcloutier.com/x86/SHRD.html:

      If the count is 1 or greater, the CF flag is filled with the
      last bit shifted out of the destination operand and the SF, ZF,
      and PF flags are set according to the value of the result. For a
      1-bit shift, the OF flag is set if a sign change occurred;
      otherwise, it is cleared. For shifts greater than 1 bit, the OF
      flag is undefined. If a shift occurs, the AF flag is
      unde-fined. If the count operand is 0, the flags are not
      affected. If the count is greater than the operand size, the
      flags are undefined.

      We ignore the CF in the specification; we only have it so that
      we can ensure that the CF flag gets appropriately clobbered. *)
  Class shift_right_doubleword_immediate_with_CF := { shrdf : W -> W -> imm -> bool * W }.
  Global Coercion shrdf : shift_right_doubleword_immediate_with_CF >-> Funclass.

  Class is_shift_right_doubleword_immediate_with_CF (shrdf : shift_right_doubleword_immediate_with_CF) :=
    decode_snd_shift_right_doubleword_with_CF :>
      forall high low count,
        0 <= count < n
        -> decode (snd (shrdf high low count)) <~=~> (((decode high << n) + decode low) >> count) mod 2^n.

  Class shift_left_immediate := { shl : W -> imm -> W }.
  Global Coercion shl : shift_left_immediate >-> Funclass.

  Class is_shift_left_immediate (shl : shift_left_immediate) :=
    decode_shift_left_immediate :>
      forall r count, 0 <= count < n -> decode (shl r count) <~=~> (decode r << count) mod 2^n.

  (** Quoting http://www.felixcloutier.com/x86/SAL:SAR:SHL:SHR.html:

      The CF flag contains the value of the last bit shifted out of
      the destination operand; it is undefined for SHL and SHR
      instructions where the count is greater than or equal to the
      size (in bits) of the destination operand. The OF flag is
      affected only for 1-bit shifts (see “Description” above);
      otherwise, it is undefined. The SF, ZF, and PF flags are set
      according to the result. If the count is 0, the flags are not
      affected. For a non-zero count, the AF flag is undefined.

      We ignore the CF in the specification; we only have it so that
      we can ensure that the CF flag gets appropriately clobbered. *)
  Class shift_left_immediate_with_CF := { shlf : W -> imm -> bool * W }.
  Global Coercion shlf : shift_left_immediate_with_CF >-> Funclass.

  Class is_shift_left_immediate_with_CF (shlf : shift_left_immediate_with_CF) :=
    decode_shift_left_immediate_with_CF :>
      forall r count, 0 <= count < n -> decode (snd (shlf r count)) <~=~> (decode r << count) mod 2^n.

  Class shift_right_immediate := { shr : W -> imm -> W }.
  Global Coercion shr : shift_right_immediate >-> Funclass.

  Class is_shift_right_immediate (shr : shift_right_immediate) :=
    decode_shift_right_immediate :>
      forall r count, 0 <= count < n -> decode (shr r count) <~=~> (decode r >> count).

  Class shift_right_immediate_with_CF := { shrf : W -> imm -> bool * W }.
  Global Coercion shrf : shift_right_immediate_with_CF >-> Funclass.

  Class is_shift_right_immediate_with_CF (shrf : shift_right_immediate_with_CF) :=
    decode_shift_right_immediate_with_CF :>
      forall r count, 0 <= count < n -> decode (snd (shrf r count)) <~=~> (decode r >> count).

  Class spread_left_immediate := { sprl : W -> imm -> tuple W 2 (* [(low, high)] *) }.
  Global Coercion sprl : spread_left_immediate >-> Funclass.

  Class is_spread_left_immediate (sprl : spread_left_immediate) :=
    {
      decode_fst_spread_left_immediate :> forall r count,
          0 <= count < n
          -> decode (fst (sprl r count)) =~> (decode r << count) mod 2^n;
      decode_snd_spread_left_immediate :> forall r count,
        0 <= count < n
        -> decode (snd (sprl r count)) =~> (decode r << count) >> n

    }.

  Class mask_keep_low := { mkl :> W -> imm -> W }.
  Global Coercion mkl : mask_keep_low >-> Funclass.

  Class is_mask_keep_low (mkl : mask_keep_low) :=
    decode_mask_keep_low :> forall r count,
      0 <= count < n -> decode (mkl r count) <~=~> decode r mod 2^count.

  Class bitwise_and := { and : W -> W -> W }.
  Global Coercion and : bitwise_and >-> Funclass.

  Class is_bitwise_and (and : bitwise_and) :=
    {
      decode_bitwise_and :> forall x y, decode (and x y) <~=~> Z.land (decode x) (decode y)
    }.

  (** Quoting http://www.felixcloutier.com/x86/AND.html:

      The OF and CF flags are cleared; the SF, ZF, and PF flags are set
      according to the result. The state of the AF flag is
      undefined. *)
  Class bitwise_and_with_CF := { andf : W -> W -> bool * W }.
  Global Coercion andf : bitwise_and_with_CF >-> Funclass.

  Class is_bitwise_and_with_CF (andf : bitwise_and_with_CF) :=
    {
      decode_snd_bitwise_and_with_CF :> forall x y, decode (snd (andf x y)) <~=~> Z.land (decode x) (decode y);
      fst_bitwise_and_with_CF :> forall x y, fst (andf x y) =~> false
    }.

  Class bitwise_or := { or : W -> W -> W }.
  Global Coercion or : bitwise_or >-> Funclass.

  Class is_bitwise_or (or : bitwise_or) :=
    {
      decode_bitwise_or :> forall x y, decode (or x y) <~=~> Z.lor (decode x) (decode y)
    }.

  (** Quoting http://www.felixcloutier.com/x86/OR.html:

      The OF or CF flags are cleared; the SF, ZF, or PF flags are set
      according to the result. The state of the AF flag is
      undefined. *)
  Class bitwise_or_with_CF := { orf : W -> W -> bool * W }.
  Global Coercion orf : bitwise_or_with_CF >-> Funclass.

  Class is_bitwise_or_with_CF (orf : bitwise_or_with_CF) :=
    {
      decode_snd_bitwise_or_with_CF :> forall x y, decode (snd (orf x y)) <~=~> Z.lor (decode x) (decode y);
      fst_bitwise_or_with_CF :> forall x y, fst (orf x y) =~> false
    }.

  Local Notation bit b := (if b then 1 else 0).

  Class add_with_carry := { adc : W -> W -> bool -> bool * W }.
  Global Coercion adc : add_with_carry >-> Funclass.

  Class is_add_with_carry (adc : add_with_carry) :=
    {
      bit_fst_add_with_carry :> forall x y c, bit (fst (adc x y c)) <~=~> (decode x + decode y + bit c) >> n;
      decode_snd_add_with_carry :> forall x y c, decode (snd (adc x y c)) <~=~> (decode x + decode y + bit c) mod (2^n)
    }.

  Class sub_with_carry := { subc : W -> W -> bool -> bool * W }.
  Global Coercion subc : sub_with_carry >-> Funclass.

  Class is_sub_with_carry (subc:W->W->bool->bool*W) :=
    {
      fst_sub_with_carry :> forall x y c, fst (subc x y c) <~=~> ((decode x - decode y - bit c) <? 0);
      decode_snd_sub_with_carry :> forall x y c, decode (snd (subc x y c)) <~=~> (decode x - decode y - bit c) mod 2^n
    }.

  Class multiply := { mul : W -> W -> W }.
  Global Coercion mul : multiply >-> Funclass.

  Class is_mul (mul : multiply) :=
    decode_mul :> forall x y, decode (mul x y) <~=~> (decode x * decode y).

  Class multiply_low_low := { mulhwll : W -> W -> W }.
  Global Coercion mulhwll : multiply_low_low >-> Funclass.
  Class multiply_high_low := { mulhwhl : W -> W -> W }.
  Global Coercion mulhwhl : multiply_high_low >-> Funclass.
  Class multiply_high_high := { mulhwhh : W -> W -> W }.
  Global Coercion mulhwhh : multiply_high_high >-> Funclass.
  Class multiply_double := { muldw : W -> W -> tuple W 2 }.
  Global Coercion muldw : multiply_double >-> Funclass.
  (** Quoting http://www.felixcloutier.com/x86/MUL.html:

      The OF and CF flags are set to 0 if the upper half of the result
      is 0; otherwise, they are set to 1. The SF, ZF, AF, and PF flags
      are undefined.

      We ignore the CF in the specification; we only have it so that
      we can ensure that the CF flag gets appropriately clobbered. *)
  Class multiply_double_with_CF := { muldwf : W -> W -> bool * tuple W 2 }.
  Global Coercion muldwf : multiply_double_with_CF >-> Funclass.

  Class is_mul_low_low (w:Z) (mulhwll : multiply_low_low) :=
    decode_mul_low_low :>
      forall x y, decode (mulhwll x y) <~=~> ((decode x mod 2^w) * (decode y mod 2^w)) mod 2^n.
  Class is_mul_high_low (w:Z) (mulhwhl : multiply_high_low) :=
    decode_mul_high_low :>
      forall x y, decode (mulhwhl x y) <~=~> ((decode x >> w) * (decode y mod 2^w)) mod 2^n.
  Class is_mul_high_high (w:Z) (mulhwhh : multiply_high_high) :=
    decode_mul_high_high :>
      forall x y, decode (mulhwhh x y) <~=~> ((decode x >> w) * (decode y >> w)) mod 2^n.
  Class is_mul_double (muldw : multiply_double) :=
    {
      decode_fst_mul_double :>
        forall x y, decode (fst (muldw x y)) =~> (decode x * decode y) mod 2^n;
      decode_snd_mul_double :>
        forall x y, decode (snd (muldw x y)) =~> (decode x * decode y) >> n
    }.

  Class is_mul_double_with_CF (muldwf : multiply_double_with_CF) :=
    {
      decode_fst_mul_double_with_CF :>
        forall x y, decode (fst (snd (muldwf x y))) =~> (decode x * decode y) mod 2^n;
      decode_snd_mul_double_with_CF :>
        forall x y, decode (snd (snd (muldwf x y))) =~> (decode x * decode y) >> n
    }.

  Class select_conditional := { selc : bool -> W -> W -> W }.
  Global Coercion selc : select_conditional >-> Funclass.

  Class is_select_conditional (selc : select_conditional) :=
    decode_select_conditional :> forall b x y,
      decode (selc b x y) <~=~> if b then decode x else decode y.

  Class add_modulo := { addm : W -> W -> W (* modulus *) -> W }.
  Global Coercion addm : add_modulo >-> Funclass.

  Class is_add_modulo (addm : add_modulo) :=
    decode_add_modulo :> forall x y modulus,
        decode (addm x y modulus) <~=~> (if (decode x + decode y) <? decode modulus
                                         then (decode x + decode y)
                                         else (decode x + decode y) - decode modulus).
End InstructionGallery.

Global Arguments load_immediate : clear implicits.
Global Arguments shift_right_doubleword_immediate : clear implicits.
Global Arguments shift_right_doubleword_immediate_with_CF : clear implicits.
Global Arguments shift_left_immediate : clear implicits.
Global Arguments shift_left_immediate_with_CF : clear implicits.
Global Arguments shift_right_immediate : clear implicits.
Global Arguments shift_right_immediate_with_CF : clear implicits.
Global Arguments spread_left_immediate : clear implicits.
Global Arguments mask_keep_low : clear implicits.
Global Arguments bitwise_and : clear implicits.
Global Arguments bitwise_and_with_CF : clear implicits.
Global Arguments bitwise_or : clear implicits.
Global Arguments bitwise_or_with_CF : clear implicits.
Global Arguments add_with_carry : clear implicits.
Global Arguments sub_with_carry : clear implicits.
Global Arguments multiply : clear implicits.
Global Arguments multiply_low_low : clear implicits.
Global Arguments multiply_high_low : clear implicits.
Global Arguments multiply_high_high : clear implicits.
Global Arguments multiply_double : clear implicits.
Global Arguments multiply_double_with_CF : clear implicits.
Global Arguments select_conditional : clear implicits.
Global Arguments add_modulo : clear implicits.
Global Arguments ldi {_ _} _.
Global Arguments shrdf {_ _} _ _ _.
Global Arguments shrd {_ _} _ _ _.
Global Arguments shl {_ _} _ _.
Global Arguments shlf {_ _} _ _.
Global Arguments shr {_ _} _ _.
Global Arguments shrf {_ _} _ _.
Global Arguments sprl {_ _} _ _.
Global Arguments mkl {_ _} _ _.
Global Arguments and {_ _} _ _.
Global Arguments andf {_ _} _ _.
Global Arguments or {_ _} _ _.
Global Arguments orf {_ _} _ _.
Global Arguments adc {_ _} _ _ _.
Global Arguments subc {_ _} _ _ _.
Global Arguments mul {_ _} _ _.
Global Arguments mulhwll {_ _} _ _.
Global Arguments mulhwhl {_ _} _ _.
Global Arguments mulhwhh {_ _} _ _.
Global Arguments muldw {_ _} _ _.
Global Arguments muldwf {_ _} _ _.
Global Arguments selc {_ _} _ _ _.
Global Arguments addm {_ _} _ _ _.

Global Arguments is_decode {_ _} _.
Global Arguments is_load_immediate {_ _ _} _.
Global Arguments is_shift_right_doubleword_immediate {_ _ _} _.
Global Arguments is_shift_right_doubleword_immediate_with_CF {_ _ _} _.
Global Arguments is_shift_left_immediate {_ _ _} _.
Global Arguments is_shift_left_immediate_with_CF {_ _ _} _.
Global Arguments is_shift_right_immediate {_ _ _} _.
Global Arguments is_shift_right_immediate_with_CF {_ _ _} _.
Global Arguments is_spread_left_immediate {_ _ _} _.
Global Arguments is_mask_keep_low {_ _ _} _.
Global Arguments is_bitwise_and {_ _ _} _.
Global Arguments is_bitwise_and_with_CF {_ _ _} _.
Global Arguments is_bitwise_or {_ _ _} _.
Global Arguments is_bitwise_or_with_CF {_ _ _} _.
Global Arguments is_add_with_carry {_ _ _} _.
Global Arguments is_sub_with_carry {_ _ _} _.
Global Arguments is_mul {_ _ _} _.
Global Arguments is_mul_low_low {_ _ _} _ _.
Global Arguments is_mul_high_low {_ _ _} _ _.
Global Arguments is_mul_high_high {_ _ _} _ _.
Global Arguments is_mul_double {_ _ _} _.
Global Arguments is_mul_double_with_CF {_ _ _} _.
Global Arguments is_select_conditional {_ _ _} _.
Global Arguments is_add_modulo {_ _ _} _.

Module fancy_machine.
  Local Notation imm := Z (only parsing).

  Class instructions (n : Z) :=
    {
      W : Type (* [n]-bit word *);
      decode :> decoder n W;
      ldi :> load_immediate W;
      shrd :> shift_right_doubleword_immediate W;
      shl :> shift_left_immediate W;
      shr :> shift_right_immediate W;
      adc :> add_with_carry W;
      subc :> sub_with_carry W;
      mulhwll :> multiply_low_low W;
      mulhwhl :> multiply_high_low W;
      mulhwhh :> multiply_high_high W;
      selc :> select_conditional W;
      addm :> add_modulo W
    }.

  Class arithmetic {n_over_two} (ops:instructions (2 * n_over_two)) :=
    {
      decode_range :> is_decode decode;
      load_immediate :> is_load_immediate ldi;
      shift_right_doubleword_immediate :> is_shift_right_doubleword_immediate shrd;
      shift_left_immediate :> is_shift_left_immediate shl;
      shift_right_immediate :> is_shift_right_immediate shr;
      add_with_carry :> is_add_with_carry adc;
      sub_with_carry :> is_sub_with_carry subc;
      multiply_low_low :> is_mul_low_low n_over_two mulhwll;
      multiply_high_low :> is_mul_high_low n_over_two mulhwhl;
      multiply_high_high :> is_mul_high_high n_over_two mulhwhh;
      select_conditional :> is_select_conditional selc;
      add_modulo :> is_add_modulo addm
    }.
End fancy_machine.

Module x86.
  Local Notation imm := Z (only parsing).

  Class instructions (n : Z) :=
    {
      W : Type (* [n]-bit word *);
      decode :> decoder n W;
      ldi :> load_immediate W;
      shrdf :> shift_right_doubleword_immediate_with_CF W;
      shlf :> shift_left_immediate_with_CF W;
      shrf :> shift_right_immediate_with_CF W;
      adc :> add_with_carry W;
      subc :> sub_with_carry W;
      muldwf :> multiply_double_with_CF W;
      selc :> select_conditional W;
      orf :> bitwise_or_with_CF W
    }.

  Class arithmetic {n} (ops:instructions n) :=
    {
      decode_range :> is_decode decode;
      load_immediate :> is_load_immediate ldi;
      shift_right_doubleword_immediate_with_CF :> is_shift_right_doubleword_immediate_with_CF shrdf;
      shift_left_immediate_with_CF :> is_shift_left_immediate_with_CF shlf;
      shift_right_immediate_with_CF :> is_shift_right_immediate_with_CF shrf;
      add_with_carry :> is_add_with_carry adc;
      sub_with_carry :> is_sub_with_carry subc;
      multiply_double_with_CF :> is_mul_double_with_CF muldwf;
      select_conditional :> is_select_conditional selc;
      bitwise_or_with_CF :> is_bitwise_or_with_CF orf
    }.
End x86.


(* Some facts about series that are not in Coquelicot *)
From discprob.basic Require Import base order bigop_ext.
Require Import Reals Fourier Psatz.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy Markov.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
Require Import ClassicalEpsilon.

Lemma Rbar_le_fin x y: 0 <= y → Rbar_le x (Finite y) → Rle (real x) y.
Proof.
  rewrite /Rbar_le. destruct x => //=.
Qed.

Lemma Rbar_le_fin' x y: 0 <= y → Rbar_le x y → Rle x (real y).
Proof.
  rewrite /Rbar_le. destruct x => //=.
Qed.

Lemma Rbar_eq_fin x y: x = (Finite y) → (real x) = y.
Proof.
  destruct x => //=. inversion 1; auto.
Qed.

Lemma is_series_0 a: (∀ n, a n = 0) → is_series a 0.
Proof.
  intros Ha. apply (is_series_ext (λ x, 0)); auto.
  rewrite /is_series.
  apply (filterlim_ext (λ x, 0)).
  - intros m. rewrite sum_n_const Rmult_0_r //.
  - apply filterlim_const.
Qed.

Lemma Series_0 a: (∀ n, a n = 0) → Series a = 0.
Proof.
  intros Heq. apply is_series_unique, is_series_0. done.
Qed.

Lemma is_lim_seq_pos a (v: R):
  (∀ n, a n >= 0) →
  is_lim_seq a v →
  0 <= v.
Proof.
  rewrite /is_lim_seq => Hn; intros.
  cut (Rbar_le 0 v); first by auto.
  apply (@filterlim_le _ eventually _ (λ x, 0) a); auto.
  - exists O; intros. apply Rge_le; auto.
  - apply filterlim_const.
Qed.

Lemma Lim_seq_pos a:
  (∀ n, a n >= 0) →
  0 <= Lim_seq a.
Proof.
  intros.
  cut (Rbar_le 0 (Lim_seq a)).
  { rewrite //=. rewrite /real. destruct Lim_seq; nra. }
  rewrite -Lim_seq_const. apply Lim_seq_le_loc.
  exists O. intros. apply Rge_le; auto.
Qed.

Lemma Series_pos a:
  (∀ n, a n >= 0) →
  0 <= Series a.
Proof.
  intros Hpos.
  rewrite /Series. apply Lim_seq_pos. induction n.
  - rewrite sum_O.  auto.
  - rewrite sum_Sn /plus//=. specialize (Hpos (S n)). nra.
Qed.

Lemma Series_strict_pos_inv a:
  (∀ n, a n >= 0) →
  0 < Series a →
  ∃ n, a n > 0.
Proof.
  intros Hge Hlt.
  destruct (LPO (λ n, a n > 0)) as [Hs|Heq0].
  - intros n. destruct (Rgt_dec (a n) 0) => //=; auto.
  - destruct Hs as (n&Hgt0); exists n; done.
  - exfalso. assert (Series a = 0).
    { apply Series_0. intros n. destruct (Hge n) => //=.
      exfalso; eapply Heq0; eauto.
    }
    nra.
Qed.

Lemma is_lim_seq_unique_series a v:
  is_series a v → Lim_seq (sum_n a) = v.
Proof.
  intros. apply is_lim_seq_unique. rewrite //=.
Qed.

Lemma is_series_partial_pos a n v:
  (∀ n, a n >= 0) →
  is_series a v →
  sum_n a n <= v.
Proof.
  intros Hpos His_series.
  assert (Hpos' : ∀ n : nat, sum_n a n >= 0).
  { intros n'. induction n' => //=; rewrite ?sum_O ?sum_Sn; eauto.
    specialize (Hpos (S n')). rewrite /plus//=. nra. }
  replace (sum_n a n) with (real (sum_n a n)) by auto.
  rewrite -(is_series_unique _ _ His_series).
  eapply Rbar_le_fin'.
  - case_eq (Lim_seq (sum_n a)) => //=; try nra.
    intros r Heq.
    rewrite /is_series in His_series.
    assert (ex_lim_seq (sum_n a)).
    { exists v. eauto. }
    eapply is_lim_seq_pos; eauto.
    rewrite -Heq. apply Lim_seq_correct; eauto.
  -  rewrite -Lim_seq_const.
     case_eq (Lim_seq (sum_n a)) => //=; try nra.
     * intros r Heq. rewrite -Heq.
       apply Lim_seq_le_loc. exists n.
       intros m; induction 1.
       ** reflexivity.
       ** rewrite sum_Sn /plus//=. specialize (Hpos (S m)). nra.
     * intros Heq_infty. apply is_lim_seq_unique_series in His_series. exfalso.
       rewrite Heq_infty in His_series. congruence.
     * intros Heq_infty. apply is_lim_seq_unique_series in His_series. exfalso.
       rewrite Heq_infty in His_series. congruence.
Qed.

Lemma sum_n_partial_pos a :
  (∀ n, a n >= 0) →
   ∀ n : nat, sum_n a n >= 0.
Proof.
  intros Hpos n'; induction n' => //=; rewrite ?sum_O ?sum_Sn; eauto.
    specialize (Hpos (S n')). rewrite /plus//=. nra.
Qed.

Lemma sum_n_pos a (n: nat):
  (∀ n, a n >= 0) →
  0 <= sum_n a n.
Proof.
  intros Hge. induction n => //=.
  - rewrite sum_O. by apply Rge_le.
  - rewrite sum_Sn /plus//=. specialize (Hge (S n)). nra.
Qed.

Lemma sum_n_strict_pos a (n: nat):
  (∀ n, a n >= 0) →
  a n > 0 →
  0 < sum_n a n.
Proof.
  intros Hge Hgt.
  destruct n => //=.
  - rewrite sum_O. nra.
  - rewrite sum_Sn /plus//=. specialize (sum_n_pos a n Hge).
    nra.
Qed.

Lemma Series_partial_pos a (n: nat):
  (∀ n, a n >= 0) →
  ex_finite_lim_seq (sum_n a) →
  sum_n a n <= Series a.
Proof.
  intros Hpos Hfin.
  specialize (sum_n_partial_pos a Hpos) => Hpos'.
  replace (sum_n a n) with (real (sum_n a n)) by auto.
  eapply Rbar_le_fin'.
  - case_eq (Lim_seq (sum_n a)) => //=; try nra.
    intros r Heq'.
    etransitivity; first apply Lim_seq_pos; eauto.
    move: Heq'. destruct Lim_seq => //=. inversion 1. nra.
  - destruct Hfin as (?&Hfin).
    rewrite -Lim_seq_const.
     case_eq (Lim_seq (sum_n a)) => //=; try nra.
     * intros r Heq'. rewrite -Heq'.
       apply Lim_seq_le_loc. exists n.
       intros m; induction 1.
       ** reflexivity.
       ** rewrite sum_Sn /plus//=. specialize (Hpos (S m)). nra.
     * apply is_lim_seq_unique in Hfin. congruence.
     * apply is_lim_seq_unique in Hfin. congruence.
Qed.

Lemma Series_strict_pos a (n: nat):
  (∀ n, a n >= 0) →
  a n > 0 →
  ex_finite_lim_seq (sum_n a) →
  0 < Series a.
Proof.
  intros. eapply Rlt_le_trans; last eapply Series_partial_pos; eauto.
  eapply sum_n_strict_pos; eauto.
Qed.

Lemma is_series_filter_pos a (P: pred nat) (v: R):
  (∀ n, a n >= 0) →
  is_series a v → ex_series (λ n, if P n then a n else 0).
Proof.
  intros Hge Hconv. apply ex_series_Rabs.
  apply: ex_series_le; last by (exists v; eauto).
  intros n. rewrite /norm//=/abs//=.
  destruct (P n); rewrite Rabs_Rabsolu Rabs_right => //=; try nra.
  specialize (Hge n); nra.
Qed.

Lemma is_series_filter_PQ a (P Q: pred nat) (v: R):
  (∀ n, a n >= 0) →
  is_series (λ n, if P n then a n else 0) v →
  (∀ n, Q n → P n) →
  ex_series (λ n, if Q n then a n else 0).
Proof.
  intros Hge Hconv Himp. apply ex_series_Rabs.
  apply: ex_series_le; last by (exists v; eauto).
  intros n. rewrite /norm//=/abs//=.
  specialize (Himp n); specialize (Hge n).
  destruct (P n), (Q n); rewrite Rabs_Rabsolu Rabs_right => //=; try nra.
  exfalso; auto.
Qed.

Lemma is_series_filter_split a (P: pred nat) (v: R):
  (∀ n, a n >= 0) →
  is_series a v →
  Series (λ n, if P n then a n else 0) + Series (λ n, if ~~ P n then a n else 0) = v.
Proof.
  intros.
  rewrite -Series_plus; try (eapply is_series_filter_pos; eauto).
  rewrite -(is_series_unique a v) //.
  apply Series_ext => n; destruct (P n) => //=; nra.
Qed.

Lemma is_series_filter_union a (P Q: pred nat) (v: R):
  (∀ n, a n >= 0) →
  is_series (λ n, if P n || Q n then a n else 0) v →
  Series (λ n, if P n then a n else 0) + Series (λ n, if Q n then a n else 0)
    - Series (λ n, if P n && Q n then a n else 0) = v.
Proof.
  intros Hge Hexists.
  rewrite -Series_plus; try (eapply (is_series_filter_PQ _ _ _ _ Hge Hexists); eauto;
                             try (intros n; destruct (P n), (Q n); auto)).
  rewrite -Series_minus; try (eapply (is_series_filter_PQ _ _ _ _ Hge Hexists); eauto;
                             try (intros n; destruct (P n), (Q n); auto)).
  - rewrite -(is_series_unique _ v Hexists).
    apply Series_ext => n; destruct (P n) => //=; nra.
  - apply: (ex_series_le _ (λ n, scal 2 (if P n || Q n then a n else 0))).
    + intros n. specialize (Hge n). destruct (P n), (Q n) => //=;
      rewrite /norm//=/abs//=/scal//=/mult/=; rewrite Rabs_right; nra.
    + exists (scal 2 v). by apply: is_series_scal.
Qed.

Lemma is_series_bump_hd v:
  is_series (λ x, if eq_nat_dec x 0 then v else 0) v.
Proof.
  apply is_series_decr_1.
  rewrite //=. rewrite plus_opp_r.
  by apply is_series_0.
Qed.

Lemma is_series_bump n v:
  is_series (λ x, if eq_nat_dec x n then v else 0) v.
Proof.
  induction n.
  - apply is_series_bump_hd.
  - apply is_series_decr_1.
    destruct eq_nat_dec; first by done.
    rewrite opp_zero plus_zero_r.
    eapply is_series_ext; eauto.
    intros n' => //=.
    destruct eq_nat_dec => //=.
Qed.

Lemma Series_bump n v:
  Series (λ x, if eq_nat_dec x n then v else 0) = v.
Proof.
  apply is_series_unique, is_series_bump.
Qed.

Lemma Series_le':
  ∀ a b : nat → R, (∀ n : nat, a n <= b n) → ex_series a → ex_series b → Series a <= Series b.
Proof.
  intros a b Hle Hexa Hexb.
  destruct Hexa as [av Hav].
  destruct Hexb as [bv Hbv].
  cut (av <= bv).
  { intros Hle'.
    erewrite is_series_unique; eauto.
    erewrite is_series_unique; eauto.
  }
  cut (Rbar_le av bv); auto.
  eapply @filterlim_le; eauto.
  - apply Proper_StrongProper, eventually_filter.
  - exists O => n Hn.
    rewrite ?sum_n_bigop. apply Rle_bigr. done.
Qed.

Lemma is_lub_seq_eps_below a x:
  is_lub (λ r : R, ∃ n : nat, a n = r) x →
  ∀ eps : posreal , ∃ n, x - eps < a n <= x.
Proof.
  intros Hlub eps. apply Classical_Pred_Type.not_all_not_ex => Hn.
  destruct Hlub as [Hub Hlub].
  eapply Rgt_not_le; last eapply (Hlub (x - eps)).
  { destruct eps as (?&?); auto => //=. nra. }
  intros ? (n&<-).
  apply Rnot_gt_le => Hgt.
  specialize (Hn n).
  apply Hn; split; first nra.
  apply Hub; eauto.
Qed.

Lemma is_lub_seq_eps_ball a x:
  is_lub (λ r : R, ∃ n : nat, a n = r) x →
  ∀ eps : posreal , ∃ n, ball x eps (a n).
Proof.
  intros Hlub eps. edestruct (is_lub_seq_eps_below a x Hlub eps) as (n&?).
  destruct Hlub as [Hub Hlub].
  exists n. rewrite /ball//=/AbsRing_ball/abs/minus/plus/opp//=.
  rewrite Rabs_left1; last first.
  { cut (a n <= x); first by intros; nra. apply Hub. eauto. }
  nra.
Qed.

Lemma sum_n_nonneg_terms_increasing a n n':
  n ≤ n' → (∀ n, a n >= 0) → sum_n a n <= sum_n a n'.
Proof.
  induction 1; first reflexivity.
  intros Hpos. etransitivity; first eapply IHle; auto.
  rewrite sum_Sn /plus//=. specialize (Hpos (S m)). nra.
Qed.

Lemma Lim_seq_le_loc_const u v:
  0 <= v →
  eventually (λ n : nat, u n <= v) → Lim_seq u <= v.
Proof.
  intros.
  cut (Rbar_le (Lim_seq u) v).
  { destruct (Lim_seq u) => //=. }
  rewrite -Lim_seq_const.
  by apply Lim_seq_le_loc.
Qed.

Lemma ex_series_non_neg_le_const a v:
  (∀ n : nat, 0 <= a n) → (∀ n, sum_n a n <= v) → ex_series a ∧ Series a <= v.
Proof.
  intros Hnonneg Hbounded.
  rewrite /ex_series/is_series/Series.
  edestruct (completeness (λ r, ∃ n, sum_n a n = r)) as (x&Hlub).
  { exists v => r [n <-]. done. }
  { exists (sum_n a O); exists O; done. }
  split.
  - exists x. intros P. rewrite /locally//=. intros (eps&Heps).
    edestruct (is_lub_seq_eps_below _ _ Hlub eps) as (n&Hrange).
    exists n => n'. intros Hle.
    apply Heps. rewrite /ball//=/AbsRing_ball/abs/minus/plus/opp//=.
    rewrite Rabs_left1; last first.
    { destruct Hrange.
      apply (Rplus_le_reg_r x). ring_simplify.
      apply Hlub. eauto.
    }
    destruct Hrange.
    assert (sum_n a n <= sum_n a n').
    { apply sum_n_nonneg_terms_increasing; eauto. intros. apply Rle_ge. eauto. }
    destruct Hlub as [Hub Hlub].
    assert (sum_n a n' <= x); eauto.
    replace ((@sum_n (NormedModule.AbelianGroup R_AbsRing R_NormedModule) a n'))
            with ((@sum_n R_AbelianGroup a n')) by auto.
    nra.
  - apply Lim_seq_le_loc_const.
    * transitivity (a O); auto.
      rewrite -(sum_O a). done.
    * exists O. auto.
Qed.

Lemma ex_series_is_lim_seq (f: nat → R):
  ex_series f → is_lim_seq (sum_n f) (Series f).
Proof.
  intros Hex. by eapply Series_correct.
Qed.

Lemma is_lim_seq_is_series (f: nat → R) (v: R):
  is_lim_seq (sum_n f) v → is_series f v.
Proof. eauto. Qed.

Lemma is_series_single_non_zero (f: nat → R) i:
  (∀ j, f j ≠ 0 → i = j) →
  is_series f (f i).
Proof.
  intros Hone Hneq0. eapply is_series_ext; last eapply (is_series_bump i).
  intros n => //=. destruct (Nat.eq_dec n i) as [|Hneq] => //=.
  * subst; eauto.
  * destruct (Req_dec 0 (f n)); auto.
    exfalso. eapply Hneq. symmetry. eapply Hone; eauto.
Qed.

Lemma Series_single_non_zero (f: nat → R) i:
  (∀ j, f j ≠ 0 → i = j) →
  Series f = (f i).
Proof. intros. apply is_series_unique, is_series_single_non_zero; eauto. Qed.

Lemma ex_series_single_non_zero (f: nat → R):
  (∀ i j, f i ≠ 0 → f j ≠ 0 → i = j) →
  ex_series f.
Proof.
  destruct (excluded_middle_informative (∃ i, f i ≠ 0)) as [(i&Heq)|?]; last first.
  { intros. exists 0. eapply is_series_0. intros m.
    destruct (Req_dec (f m) 0); try nra. exfalso; eauto.
  }
  intros. exists (f i). eapply is_series_single_non_zero; eauto.
Qed.


Require Import Arith.
Require Import Ascii.
Require Import Nat.
Require Import Bool.
Require Import Coq.Strings.Byte.
Require Import Strings.String.
Scheme Equality for string.
Local Open Scope string_scope.

Inductive Nat : Type :=
| TypeNat : nat -> Nat
| ErrorNat : Nat.

Inductive Bool : Type :=
| TypeBool : bool -> Bool
| ErrorBool : Bool.

Inductive String : Type :=
| TypeString : string -> String
| ErrorString : String.

Coercion TypeNat : nat >-> Nat.
Coercion TypeBool : bool >-> Bool.
Coercion TypeString : string >->String.

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Inductive list (T : Type) : Type :=
| nil
| cons (t : T) (l : list T).

Check cons Nat 4 (cons Nat 3 (nil Nat)).
Check cons Bool false (cons Bool true (nil Bool)).

Arguments nil {T}.
Notation "[]" := nil.

Notation "{ X , .. , Y }" := (cons Nat X .. (cons Nat Y []) ..).
Notation "{ X ; .. ; Y }" := (cons Bool X .. (cons Bool Y []) ..).
Notation "{ X ;;; .. ;;; Y }" := (cons String X .. (cons String Y []) ..).

Check {1, 2, 3}.
Check {false; true; true; false}.

Definition list1nat := {2, 4, 6, 8, 10, 12, 14}.
Definition list2nat := {1, 3, 5, 7, 9}.
Definition list1bool := {true; false; true; false; false}.
Definition list1string := { "ioan" ;;; "ioana" }.

Inductive Array : Type :=
| NatArray : list Nat -> Array
| BoolArray : list Bool -> Array
| StringArray : list String -> Array
| Matrix : list Array -> Array.

Check NatArray list1nat.
Check BoolArray list1bool.

Notation "{ X & .. & Y }" := (cons Array X .. (cons Array Y []) ..).
Check Matrix { (NatArray list1nat) & (NatArray list2nat) }.

Notation "'[Natural]' = L " := (NatArray L) (at level 20).
Notation "'[Boolean]' = L " := (BoolArray L) (at level 20).
Notation "'[String]' = L " := (StringArray L) (at level 20).
Notation "'[[Matrix]]' = L" := (Matrix L) (at level 20).

Definition vector_nat := [Natural] = list1nat.
Definition vector_bool := [Boolean] = list1bool.
Definition vector_string := [String] = list1string.
Definition matrix_both := [[Matrix]] = { vector_nat & vector_bool }.

Compute vector_nat.
Compute vector_bool.
Compute vector_string.

Inductive types_allowed : Type :=
| natural (n : Nat)
| boolean (b : Bool)
| stringg (s : String)
| arr (v : Array)
| inexistent.

Coercion  natural : Nat >-> types_allowed.
Coercion boolean : Bool >-> types_allowed.
Coercion arr : Array >-> types_allowed.
Coercion stringg : String >-> types_allowed.

Check 7 : types_allowed.
Check false : types_allowed.

Inductive pair_struct : Type :=
| pair (first : string) (second : types_allowed).

Notation "( N , V )" := (pair N V).
Notation "{ P1 ;; .. ;; P2 }" := (cons pair_struct P1 .. (cons pair_struct P2 []) ..).

Inductive Struct : Type :=
| struct (s : string) ( struct_pairs : list pair_struct).

Definition pair_get_first (p : pair_struct) :=
match p with
| pair first second => first
end.

Definition pair_get_second (p : pair_struct) :=
match p with
| pair first second => second
end.

Fixpoint get_element_pairlist (l : list pair_struct) (f : string) :=
match l with
| nil => inexistent
| cons _ field l2 => if ( eqb_string f ( pair_get_first field ))
                     then pair_get_second field
                     else get_element_pairlist l2 f
end.

Definition get_element_struct (str : Struct) (field : string) :=
match str with
| struct name list_pair => get_element_pairlist list_pair field
end.

Definition struct1 := struct "Animale" { ("Varsta" , 5 ) ;; ( "Rasa" , "Bichon" ) ;; ( "Culoare" , "Alb" ) } .

Compute get_element_struct struct1 "Varsta".

Inductive pair_map (T1 T2 : Type) : Type :=
| pairr (first : T1) (second : T2).

Inductive Map (T1 T2 : Type): Type :=
| map (s : string) ( map_pair : list (pair_map T1 T2)).

Inductive Types : Type :=
| Nats (n : Nat)
| Bools (b : Bool)
| undeclared : Types
| Arrays (v : Array)
| Structs (s : Struct)
| Error.

Definition Env := string -> Types.
Coercion Nats : Nat >-> Types.
Coercion Bools : Bool >-> Types.

Definition update (env : Env)
           (x : string) (v : Types) : Env :=
  fun y => if (eqb_string y x)
           then v
           else (env y).

Definition all (x : Types) : Env :=
  (fun _ => x).

Definition default := all undeclared.

Definition default_zero (s : string) := update default s 0.
Check false.
Definition default_false (s : string) := update default s false.

Definition env1 := update default "v1" 1.
Definition env2 := update default "v2" true.

Check "v1".
Compute env2 "v2" .

Inductive Exp :=
| anum : Nat -> Exp
| avar : string -> Exp
| aplus : Exp -> Exp -> Exp
| aminus : Exp -> Exp -> Exp
| amul : Exp -> Exp -> Exp
| adiv : Exp -> Exp -> Exp
| amod : Exp -> Exp -> Exp
| btrue : Exp
| bfalse : Exp
| not' : Exp -> Exp
| and' : Exp -> Exp -> Exp
| or' : Exp -> Exp -> Exp
| less : Exp -> Exp -> Exp
| lessequal : Exp -> Exp -> Exp
| greater : Exp -> Exp -> Exp
| greaterequal : Exp -> Exp -> Exp
| equal : Exp -> Exp -> Exp
| notequal : Exp -> Exp -> Exp.

Coercion anum : Nat >-> Exp.
Coercion avar : string >-> Exp.

Notation "A +' B" := (aplus A B) (at level 60, right associativity).
Notation "A -' B" := (aminus A B) (at level 58, left associativity).
Notation "A *' B" := (amul A B) (at level 58, left associativity).
Notation "A /' B" := (adiv A B) (at level 58, left associativity).
Notation "A %' B" := (amod A B) (at level 58, left associativity).
Notation "! A" := (not' A) (at level 75, right associativity).
Notation "A &&' B" := (and' A B) (at level 40, left associativity).
Notation "A ||' B" := (or' A B) (at level 50, left associativity).
Notation "A <' B" := (less A B) (at level 70, no associativity).
Notation "A <=' B" := (lessequal A B) (at level 70, no associativity).
Notation "A >' B" := (greater A B) (at level 70, no associativity).
Notation "A >=' B" := (greaterequal A B) (at level 70, no associativity).
Notation "A ==' B" := (equal A B) (at level 70, no associativity).
Notation "A !=' B" := (notequal A B) (at level 70, no associativity).

Check 2 +' 2.
Check 2 +' btrue.
Check (and' 2 2).

Definition types_plus (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeNat(x + y)
| TypeBool x, TypeBool y => match x, y with
                    | true, true => TypeNat 2
                    | false, false => TypeNat 0
                    | _, _ => TypeNat 1
                    end
| TypeNat x, TypeBool y => match y with
                   | true => TypeNat (x + 1)
                   | false => TypeNat (x + 0)
                   end
| TypeBool x, TypeNat y => match x with
                   | true => TypeNat (1 + y)
                   | false => TypeNat (0 + y)
                   end
| _, _ => ErrorNat
end.

Compute (types_plus true true).
Compute (types_plus false true).
Compute (types_plus 9 true).

Definition types_minus (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeNat(x - y)
| TypeBool x, TypeBool y => match x, y with
                    | true, false => TypeNat 1
                    | _, _ => TypeNat 0
                    end
| TypeNat x, TypeBool y => match y with
                   | true => TypeNat (x - 1)
                   | false => TypeNat x
                   end
| TypeBool x, TypeNat y => match x with
                   | true => TypeNat (1 - y)
                   | false => TypeNat (0 - y)
                   end
| _, _ => ErrorNat
end.

Compute (types_minus true false).
Compute (types_minus true true).
Compute (types_minus 8 false).
Compute (types_minus 8 true).
Compute (types_minus 10 8).
Compute (types_minus false 2).
Compute (types_minus true 0).

Definition types_mul (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeNat(x * y)
| TypeBool x, TypeBool y => match x, y with
                    | true, true => TypeNat 1
                    | _, _ => TypeNat 0
                    end
| TypeNat x, TypeBool y => match y with
                   | true => TypeNat x
                   | false => TypeNat 0
                   end
| TypeBool x, TypeNat y => match x with
                   | true => TypeNat y
                   | false => TypeNat 0
                   end
| _, _ => ErrorNat
end.

Compute (types_mul 4 2).
Compute (types_mul 4 true).
Compute (types_mul 4 false).
Compute (types_mul true true).
Compute (types_mul false true).

Definition types_div (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => match y with
                          | 0 => ErrorNat
                          | _ => TypeNat(div x y)
                          end
| TypeBool x, TypeBool y => match x, y with
                            | true, true => TypeNat 1
                            | false, true => TypeNat 0
                            | _, _ => ErrorNat
                            end
| TypeNat x, TypeBool y => match y with
                           | true => TypeNat x
                           | false => ErrorNat
                           end
| TypeBool x, TypeNat y => match x, y with
                           | _, 0 => ErrorNat
                           | true, _ => TypeNat (div 1 y)
                           | false, _ => TypeNat 0
                           end
| _, _ => ErrorNat
end.

Compute (types_div 8 4).
Compute (types_div 8 0).
Compute (types_div 8 true).
Compute (types_div 8 false).
Compute (types_div true true).
Compute (types_div false true).

Definition types_mod (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => match y with
                          | 0 => ErrorNat
                          | _ => TypeNat(modulo x y)
                          end
| TypeBool x, TypeBool y => match x, y with
                            | true, true => TypeNat 0
                            | false, true => TypeNat 0
                            | _, _ => ErrorNat
                            end
| TypeNat x, TypeBool y => match y with
                           | true => TypeNat 0
                           | false => ErrorNat
                           end
| TypeBool x, TypeNat y => match x, y with
                           | _, 0 => ErrorNat
                           | true, _ => TypeNat (modulo 1 y)
                           | false, _ => TypeNat 0
                           end
| _, _ => ErrorNat
end.

Compute (types_mod 8 4).
Compute (types_mod 8 3).
Compute (types_mod 8 false).
Compute (types_mod 8 true).
Compute (types_mod true 4).

Definition types_not (x : Types) :=
match x with
| TypeNat x => match x with
               | 0 => TypeBool true
               | _ => TypeBool false
               end
| TypeBool x => match x with
               | true => TypeBool false
               | false => TypeBool true
               end
| _ => ErrorBool
end.

Compute(types_not true).
Compute(types_not false).
Compute(types_not 5).
Compute(types_not 0).

Definition types_and (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => match x, y with
                          | _, 0 => TypeBool false
                          | 0, _ => TypeBool false
                          | _, _ => TypeBool true
                          end
| TypeBool x, TypeBool y => match x, y with
                            | _, false => TypeBool false
                            | false, _ => TypeBool false
                            | _, _ => TypeBool true
                            end
| TypeNat x, TypeBool y => match x, y with
                           | 0, _ => TypeBool false
                           | _, false => TypeBool false
                           | _, _ => TypeBool true
                           end
| TypeBool x, TypeNat y => match x, y with
                           | false, _ => TypeBool false
                           | _, 0 => TypeBool false
                           | _, _ => TypeBool true
                           end
| _, _ => ErrorBool
end.

Compute (types_and 3 5).
Compute (types_and true false).
Compute (types_and 0 true).
Compute (types_and true true).

Definition types_or (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => match x, y with
                          | 0, 0 => TypeBool false
                          | _, _ => TypeBool true
                          end
| TypeBool x, TypeBool y => match x, y with
                            | false, false => TypeBool false
                            | _, _ => TypeBool true
                            end
| TypeNat x, TypeBool y => match x, y with
                           | 0, false => TypeBool false
                           | _, _ => TypeBool true
                           end
| TypeBool x, TypeNat y => match x, y with
                           | false, 0 => TypeBool false
                           | _, _ => TypeBool true
                           end
| _, _ => ErrorBool
end.

Compute (types_or true 8).
Compute (types_or 0 false).
Compute (types_or 6 0).
Compute (types_or true false).

Definition types_less (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeBool (ltb x y)
| TypeBool x, TypeBool y => match x, y with
                            | false, true => TypeBool true
                            | _, _ => TypeBool false
                            end
| TypeNat x, TypeBool y => match x, y with
                           | 0, true => TypeBool true
                           | _, _ => TypeBool false
                           end
| TypeBool x, TypeNat y => match x, y with
                           | false, 0 => TypeBool false
                           | true, 0 => TypeBool false
                           | true, 1 => TypeBool false
                           | _, _ => TypeBool true
                           end
| _, _ => ErrorBool
end.

Compute (types_less 4 7).
Compute (types_less 4 3).
Compute (types_less true 7).
Compute (types_less 4 true).
Compute (types_less false true).
Compute (types_less true true).

Definition types_lessequal (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeBool (Nat.leb x y)
| TypeBool x, TypeBool y => match x, y with
                            | false, _ => TypeBool true
                            | true, true => TypeBool true
                            | _, _ => TypeBool false
                            end
| TypeNat x, TypeBool y => match x, y with
                           | 0, _ => TypeBool true
                           | 1, true => TypeBool true
                           | _, _ => TypeBool false
                           end
| TypeBool x, TypeNat y => match x, y with
                           | true, 0 => TypeBool false
                           | _, _ => TypeBool true
                           end
| _, _ => ErrorBool
end.

Compute (types_lessequal 4 7).
Compute (types_lessequal 4 3).
Compute (types_lessequal true 7).
Compute (types_lessequal 4 true).
Compute (types_lessequal false true).
Compute (types_lessequal true true).

Definition types_greater (x y : Types) := types_not (types_lessequal x y).

Compute (types_greater 6 4).
Compute (types_greater 4 6).

Definition types_greaterequal (x y : Types) := types_not (types_less x y).

Compute (types_greaterequal 6 4).
Compute (types_greaterequal 4 4).

Definition types_equal (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeBool (Nat.eqb x y)
| TypeBool x, TypeBool y => match x, y with
                            | false, false => TypeBool true
                            | true, true => TypeBool true
                            | _, _ => TypeBool false
                            end
| TypeNat x, TypeBool y => match x, y with
                           | 0, false => TypeBool true
                           | 1, true => TypeBool true
                           | _, _ => TypeBool false
                           end
| TypeBool x, TypeNat y => match x, y with
                           | true, 1 => TypeBool true
                           | false, 0 => TypeBool true
                           | _, _ => TypeBool false
                           end
| _, _ => ErrorBool
end.

Compute (types_equal 5 5).
Compute (types_equal true true).
Compute (types_equal true false).
Compute (types_equal true 1).
Compute (types_equal true 5).

Definition types_notequal (x y : Types) := types_not (types_equal x y).

Compute (types_notequal true true).
Compute (types_notequal true false).
Compute (types_notequal true 1).
Compute (types_notequal true 5).

Fixpoint Eval (exp : Exp) (env : Env) : Types :=
match exp with
| anum x => x
| avar x => env x
| aplus x y => types_plus (Eval x env) (Eval y env)
| aminus x y => types_minus (Eval x env) (Eval y env)
| amul x y => types_mul (Eval x env) (Eval y env)
| adiv x y => types_div (Eval x env) (Eval y env)
| amod x y => types_mod (Eval x env) (Eval y env)
| btrue => true
| bfalse => false
| not' x => types_not (Eval x env)
| and' x y => types_and (Eval x env) (Eval y env)
| or' x y => types_or (Eval x env) (Eval y env)
| less x y => types_less (Eval x env) (Eval y env)
| lessequal x y => types_lessequal (Eval x env) (Eval y env)
| greater x y => types_greater (Eval x env) (Eval y env)
| greaterequal x y => types_greaterequal (Eval x env) (Eval y env)
| equal x y => types_equal (Eval x env) (Eval y env)
| notequal x y => types_notequal (Eval x env) (Eval y env)
end.

Inductive Stmt : Type :=
| declareNat :  string -> Stmt
| declareBool :  string -> Stmt
| declareString :  string -> Stmt

| assignmentNat : string -> Exp -> Stmt
| assignmentBool : string -> Exp -> Stmt
| assignmentString : string -> Exp -> Stmt

| initializeNat : string -> Exp -> Stmt
| initializeBool : string -> Exp -> Stmt
| initializeString : string -> Exp -> Stmt

| sequence : Stmt -> Stmt -> Stmt
| ifthenelse : Exp -> Stmt -> Stmt -> Stmt
| ifthen : Exp -> Stmt -> Stmt
| while_loop : Exp -> Stmt -> Stmt
| for_loop : Stmt -> Exp -> Stmt -> Stmt -> Stmt
| switch_case : string -> list (pair_map Nat Stmt) -> Stmt
| break : Stmt
| continue : Stmt

(*for Array*)
| declareArrayNat : string -> Stmt
| declareArrayBool : string -> Stmt
| declareArrayString : string -> Stmt
| declareMatrix : string -> Stmt

| initializeArrayNat : string -> list Nat -> Stmt
| initializeArrayBool : string -> list Bool -> Stmt
| initializeArrayString : string -> list String -> Stmt
| initializeMatrix : string -> list Array -> Stmt

| getElemArray : string -> nat -> Stmt

| setElemArrayNat : string -> nat -> Nat -> Stmt
| setElemArrayBool : string -> nat -> Bool -> Stmt
| setElemArrayString : string -> nat -> String -> Stmt
| setElemMatrix : string -> nat -> Array -> Stmt

| pushNat : string -> Nat -> Stmt
| pushBool : string -> Bool -> Stmt
| pushString : string -> String -> Stmt
| pushMatrix : string -> Array -> Stmt

| pop : string -> Stmt

(*for Struct*)
| declareStruct : string -> list pair_struct -> Stmt
| get_element_from_struct : string -> string -> Stmt
| set_element_struct : string -> string -> types_allowed -> Stmt

(*for Map*)
| declareMap : string -> list (pair_map types_allowed types_allowed) -> Stmt
| addToMap : string -> pair_map types_allowed types_allowed -> Stmt
| getValue : string -> types_allowed -> Stmt.

Notation "'nat' S" := (declareNat S) (at level 79).
Notation "'boolean' S" := (declareBool S) (at level 79).
Notation "'char' S" := (declareString S) (at level 79).

Notation "S :n= E" := (assignmentNat S E) (at level 80).
Notation "S :b= E" := (assignmentBool S E) (at level 80).
Notation "S :s= E" := (assignmentString S E) (at level 80).

Notation "'nat' S ::= E" := (initializeNat S E) (at level 78).
Notation "'boolean' S ::= E" := (initializeBool S E) (at level 78).
Notation "'char' S ::= E" := (initializeString S E) (at level 78).

Notation "S1 ;; S2" := (sequence S1 S2 ) (at level 98, left associativity).
Notation "'If' ( B ) 'Then' ( S1 ) 'Else' ( S2 ) 'EndIte'" := (ifthenelse B S1 S2) (at level 97).
Notation "'If' ( B ) 'Then' ( S ) 'EndI'" := (ifthen B S ) (at level 97).
Notation "'While' ( B ) { S } 'EndW'" := (while_loop B S) (at level 97).
Notation "'For' ( S1 ';' B ';' S2 ) { S3 }  'EndF'" := (for_loop S1 B S2 S3) (at level 97).
Notation "'switch'( X ) 'cases': C" := (switch_case X C) (at level 97).
Notation "'Break'" := (break) (at level 97).
Notation "'Continue'" := (continue) (at level 97).

Notation "[Natural] V" := (declareArrayNat V) (at level 79).
Notation "[Boolean] V" := (declareArrayBool V) (at level 79).
Notation "[String] V" := (declareArrayString V) (at level 79).
Notation "[[Matrix]] V" := (declareMatrix V) (at level 79).

Notation "[Natural] V ::= L" := (initializeArrayNat V L) (at level 79).
Notation "[Boolean] V ::= L" := (initializeArrayBool V L) (at level 79).
Notation "[String] V ::= L" := (initializeArrayString V L) (at level 79).
Notation "[[Matrix]] V ::= L" := (initializeMatrix V L) (at level 79).

Notation "V [ P ]" := (getElemArray V P)(at level 79).

Notation "V [ P ] :n= L" := (setElemArrayNat V P L) (at level 78).
Notation "V [ P ] :b= L" := (setElemArrayBool V P L) (at level 78).
Notation "V [ P ] :s= L" := (setElemArrayString V P L) (at level 78).
Notation "V [ P ] :m= L" := (setElemMatrix V P L) (at level 78).

Notation "push_n( V ) X" := (pushNat V X) (at level 79).
Notation "push_b( V ) X" := (pushBool V X) (at level 79).
Notation "push_s( V ) X" := (pushString V X) (at level 79).
Notation "push_m( V ) X" := (pushMatrix V X) (at level 79).

Notation "pop ( V )" := (pop V) (at level 79).

Notation "'struct'( N ): L" := (declareStruct N L) (at level 79).
Notation "'get' N ( F )" := (get_element_struct N F) (at level 79).
Notation "'set' N ( F ) ::= V" := (set_element_struct N F V) (at level 79).

Notation "'Map' M ::= L" := (declareMap M L) (at level 79).
Notation "'add' M P" := (addToMap M P) (at level 79).
Notation "'get_map' M ( K )" := (getValue M K) (at level 79).


(********************************************************************************
* Formalization of labelled lambda ex calculus				        *
*									        *
* Flavio L. C. de Moura & Daniel L. Ventura & Washington R. Segundo, 2014	*
*********************************************************************************)

Set Implicit Arguments.
Require Import Metatheory LambdaES_Defs LambdaES_Infra LambdaES_FV.
Require Import Rewriting.
Require Import Equation_C Lambda Lambda_Ex Arith Morphisms.

(*
(** Given a relation Red, constructs its contextual closure just over Lterms *)
Inductive L_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | L_redex : forall t s, Red t s -> L_contextual_closure Red t s
  | L_app_left : forall t t' u, Lterm u -> L_contextual_closure Red t t' ->
	  		L_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | L_app_right : forall t u u', Lterm t -> L_contextual_closure Red u u' ->
	  		L_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | L_abs_in : forall t t' L, (forall x, x \notin L -> L_contextual_closure Red (t^x) (t'^x))
      -> L_contextual_closure Red (pterm_abs t) (pterm_abs t')
.

(** Given a relation Red, constructs its parallel contextual closure *)
Inductive p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | p_redex : forall t s, Red t s -> p_contextual_closure Red t s
  | p_app : forall t t' u u', p_contextual_closure Red t t' -> p_contextual_closure Red u u' ->
	  		p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
  | p_abs_in : forall t t' L, (forall x, x \notin L -> p_contextual_closure Red (t^x) (t'^x)) ->
               p_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | p_subst : forall t t' u u' L, (forall x, x \notin L -> p_contextual_closure Red (t^x) (t'^x)) ->
              p_contextual_closure Red u u' ->
	      p_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u') .
*)

(** Step 1 *)

(** Grammar of labelled pre-terms. Labelled terms extend the ordinary
 terms with a new constructor for marked explicit substitutions. *)

Inductive lab_term : pterm -> Prop :=
  | lab_term_var : forall x,
      lab_term (pterm_fvar x)
  | lab_term_app : forall t1 t2,
      lab_term t1 ->
      lab_term t2 ->
      lab_term (pterm_app t1 t2)
  | lab_term_abs : forall L t1,
      (forall x, x \notin L -> lab_term (t1 ^ x)) ->
      lab_term (pterm_abs t1)
  | lab_term_sub : forall L t1 t2,
     (forall x, x \notin L -> lab_term (t1 ^ x)) ->
      lab_term t2 -> lab_term (t1[t2])
  | lab_term_sub' : forall L t1 t2,
     (forall x, x \notin L -> lab_term (t1 ^ x)) ->
      (term t2) -> (SN lex t2) ->
      lab_term (t1 [[ t2 ]]).

Definition lab_body (t : pterm) :=
           exists L, forall x, x \notin L -> lab_term (t ^ x).

(** Given a relation Red, constructs the contextual closure for labelled terms. *)

Inductive lab_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | lab_redex : forall t s, Red t s -> lab_contextual_closure Red t s
  | lab_app_left : forall t t' u, lab_term u -> lab_contextual_closure Red t t' ->
	  		lab_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | lab_app_right : forall t u u', lab_term t -> lab_contextual_closure Red u u' ->
	  		lab_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | lab_abs_in : forall t t' L, (forall x, x \notin L -> lab_contextual_closure Red (t^x) (t'^x))
      -> lab_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | lab_subst_left : forall t t' u L, lab_term u ->
	  	(forall x, x \notin L -> lab_contextual_closure Red (t^x) (t'^x)) ->
	        lab_contextual_closure Red  (t[u]) (t'[u])
  | lab_subst_right : forall t u u', lab_body t -> lab_contextual_closure Red u u' ->
	  	lab_contextual_closure Red  (t[u]) (t[u'])
  | lab_subst'_left : forall t t' u L, term u ->
	  	(forall x, x \notin L -> lab_contextual_closure Red (t^x) (t'^x)) ->
	        lab_contextual_closure Red  (t[[u]]) (t'[[u]])
  | lab_subst'_right : forall t u u', lab_body t -> term u ->  (SN lex u) -> Red u u' ->
	  	lab_contextual_closure Red  (t[[u]]) (t[[u']])
.

(* No SN *)
Inductive simpl_lab_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | s_lab_redex : forall t s, Red t s -> simpl_lab_contextual_closure Red t s
  | s_lab_app_left : forall t t' u, lab_term u -> simpl_lab_contextual_closure Red t t' ->
	  		simpl_lab_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | s_lab_app_right : forall t u u', lab_term t -> simpl_lab_contextual_closure Red u u' ->
	  		simpl_lab_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | s_lab_abs_in : forall t t' L, (forall x, x \notin L -> simpl_lab_contextual_closure Red (t^x) (t'^x))
      -> simpl_lab_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | s_lab_subst_left : forall t t' u L, lab_term u ->
	  	(forall x, x \notin L -> simpl_lab_contextual_closure Red (t^x) (t'^x)) ->
	        simpl_lab_contextual_closure Red  (t[u]) (t'[u])
  | s_lab_subst_right : forall t u u', lab_body t -> simpl_lab_contextual_closure Red u u' ->
	  	simpl_lab_contextual_closure Red  (t[u]) (t[u'])
  | s_lab_subst'_left : forall t t' u L, term u ->
	  	(forall x, x \notin L -> simpl_lab_contextual_closure Red (t^x) (t'^x)) ->
	        simpl_lab_contextual_closure Red  (t[[u]]) (t'[[u]])
  | s_lab_subst'_right : forall t u u', lab_body t -> term u -> Red u u' ->
	  	simpl_lab_contextual_closure Red  (t[[u]]) (t[[u']])
.

(* ====================================================================== *)
(** ** Alternative definition for local closure *)

(* ********************************************************************** *)
(** Local closure for marked terms. *)

Fixpoint lc_at' (k:nat) (t:pterm) {struct t} : Prop :=
  match t with
  | pterm_bvar i    => i < k
  | pterm_fvar x    => True
  | pterm_app t1 t2 => lc_at' k t1 /\ lc_at' k t2
  | pterm_abs t1    => lc_at' (S k) t1
  | pterm_sub t1 t2 => (lc_at' (S k) t1) /\ lc_at' k t2
  | pterm_lsub t1 t2 => (lc_at k t2) /\ (SN lex t2) /\ (lc_at' (S k) t1)
  end.

Definition term'' t := lc_at' 0 t.

Definition body'' t := lc_at' 1 t.

(** Equivalence of [term and [term'] *)

Lemma term_impl_lab_term: forall t, term t -> lab_term t.
Proof.
    induction 1; try constructor; intuition eauto.
    constructor 3 with L. auto.
    constructor 4 with L; auto.

Qed.

Lemma lc_rec_open_var_rec' : forall x t k,
  lc_at' k (open_rec k x t) -> lc_at' (S k) t.
Proof.
  induction t; simpl; introv H; auto*.
  case_nat; simpls~.
  split.
  destruct H. apply lc_rec_open_var_rec with x. auto.
  split*.
  destruct H.
  destruct H0. admit. (* !!!!!!!!!!!!! *)
Qed.

Lemma lc_at'_weaken_ind : forall k1 k2 t,
  lc_at' k1 t -> k1 <= k2 -> lc_at' k2 t.
Proof. introv. gen k1 k2. induction t; simpl; introv T Lt; auto*.
       omega. apply (IHt (S k1) (S k2)); trivial; try omega.
       case T; clear T; intros Tt1 Tt2. split.
       apply (IHt1 (S k1) (S k2)); trivial; try omega.
       apply (IHt2 k1 k2); trivial; try omega.
       destruct T as [ H1 [H2 H3] ].
       split*.
       apply lc_at_weaken_ind with k1; auto.
       split*.
       apply IHt1 with (S k1); auto.
       apply le_n_S; auto.
Qed.

Lemma lc_at'_weaken : forall k t,
  term'' t -> lc_at' k t.
Proof. introv H. apply~ (@lc_at'_weaken_ind 0). omega. Qed.

Lemma lab_term_to_term'' : forall t,
  lab_term t -> term'' t.
Proof.
  introv T. induction T; unfold term'; simple~.
  pick_fresh y. unfold term''. simpl. auto.
  split; pick_fresh x; simpl; auto.
  unfold term''. simpl. pick_fresh x. apply lc_rec_open_var_rec' with (x := (pterm_fvar x)). apply H0. eauto. constructor. pick_fresh x. apply lc_rec_open_var_rec' with (x := (pterm_fvar x)). apply H0. eauto. auto.
  constructor. apply term_to_term' in H1. auto. split*. unfold term'' in H0. pick_fresh x. apply lc_rec_open_var_rec' with (x := (pterm_fvar x)). eauto.
Qed.

Lemma lc_at_open_var_rec' : forall x t k,
  lc_at' (S k) t -> lc_at' k (open_rec k (pterm_fvar x) t).
Proof.
  induction t; simpl; introv H; auto*.
  case_nat; simpls~.
  unfold lt in *|-.
  apply le_lt_or_eq in H.
  case H.
  intro H1. apply lt_S_n in H1; trivial.
  intro H1. assert (n = k).
  auto. assert (k = n). auto.
  contradiction.
  split.
  destruct H. apply lc_at_open_var_rec. auto.
  split*.
  destruct H.
  destruct H0. admit. (* !!!!!!!!!!!!! *)
Qed.

Lemma lc_at'_bswap_rec : forall n k t, S k < n -> lc_at' n t -> lc_at' n (bswap_rec k t).
Proof.
 intros n k t.
 generalize n k; clear n k.
 induction t.
 (* bvar *)
 intros n' k H0 H1. simpl in H1.
 unfolds bswap_rec.
 case (k === n). intro H2.
 rewrite H2. simpl. omega. intro H2.
 case (S k === n). intro H3. simpl. omega. intro H3.
 simpl. trivial.
 (* fvar *)
 intros n k H0 H1. simpl in *|-*. trivial.
 (* app *)
 intros n k H0 H1. simpl in *|-*. destruct H1. split.
 apply IHt1; trivial. apply IHt2; trivial.
 (* abs *)
 intros n k H0 H1. simpl in *|-*.
 apply IHt; try omega; trivial.
 (* sub *)
 intros n k H0 H1. simpl in *|-*. destruct H1. split.
 apply IHt1; try omega; trivial. apply IHt2; trivial.
 (* sub' *)
 intros n k H0 H1. simpl in *|-*. destruct H1 as [ H2 [ H3 H4 ] ].
 split*. apply lc_at_bswap_rec; auto.
 split*. admit. (* !!!!! *)
 apply IHt1; auto. apply lt_n_S; auto.
Qed.

Lemma bswap_rec_lc_at' : forall n k t, S k < n -> lc_at' n (bswap_rec k t) -> lc_at' n t.
Proof.
    Admitted.

Lemma term''_to_lab_term : forall t,
  term'' t -> lab_term t.
Proof.
  introv. unfold term'.
  apply pterm_size_induction with (t := t).
  (* bvar *)
  simpl. intros.
  assert (~ n < 0). auto with arith.
  contradiction.
  (* fvar *)
  simpl. intros.
  apply lab_term_var.
  (* abs *)
  simpl. intros.
  apply lab_term_abs with (L := fv t1).
  intros x Fr.
  apply (H t1); trivial.
  unfold open.
  apply lc_at_open_var_rec'; trivial.
  (* app *)
  intros t1 t2 IHt1 IHt2 H.
  simpl in H. apply lab_term_app.
  apply IHt1; apply H.
  apply IHt2; apply H.
  (* sub *)
  intros. simpl in H1.
  apply lab_term_sub with (L := fv t1).
  intros x Fr.
  apply (H0 t1); trivial.
  unfold open.
  apply lc_at_open_var_rec'. apply H1.
  apply H.  apply H1.
  (* sub' *)
  intros.
  unfold term'' in H1. simpl in H1.
  pick_fresh x.
  constructor 5 with (fv t \u fv t1 \u fv t3). intros.
  destruct H1. destruct H3. apply H0. eauto. auto. unfold term''.
  apply lc_at_open_var_rec'; auto. destruct H1. apply term'_to_term; auto. destruct H1. destruct* H2.
Qed.

Lemma lab_term_eq_term'' : forall t, lab_term t <-> term'' t.
Proof. intros. split. apply lab_term_to_term''. apply term''_to_lab_term. Qed.

Lemma lab_body_to_body'' : forall t,
  lab_body t -> body'' t.
Proof.
  introv [L H]. pick_fresh x.
  applys (@lc_rec_open_var_rec' (pterm_fvar x)).
  apply lab_term_to_term''. apply~ H.
Qed.

Lemma body''_to_lab_body : forall t,
  body'' t -> lab_body t.
Proof.
  introv B. exists ({}:vars). introv F.
  apply term''_to_lab_term. apply~ lc_at_open_var_rec'.
Qed.

Lemma lab_body_eq_body'' : forall t, lab_body t <-> body'' t.
Proof. intros. split. apply lab_body_to_body''. apply body''_to_lab_body. Qed.

(** Labelled lambda ex calculus. There is just one B rule that works
both in the labelled and non-labelled calculus. *)

(** Labelled equations *)

Inductive lab_eqc  : pterm -> pterm -> Prop :=
(*| lab_eqc_rf: forall u, lab_eqc u u*)
| lab_eqc_rx1 : forall t u v,
                  lab_term u -> term v -> lab_eqc (t[u][[v]]) ((& t)[[v]][u])
| lab_eqc_rx2 : forall t u v,
                  term u -> lab_term v -> lab_eqc (t[[u]][v]) ((& t)[v][[u]])
| lab_eqc_rx3 : forall t u v,
                  term u -> term v -> lab_eqc (t[[u]][[v]]) ((& t)[[v]][[u]]).

Lemma lab_eqc_sym : forall t u, lab_eqc t u -> lab_eqc u t.
Proof.
  intros t u Heqc.
  destruct Heqc.
  (*apply lab_eqc_rf.*)
  replace ((t [u]) [[v]]) with (((& (& t)) [u]) [[v]]).
  apply lab_eqc_rx2; assumption.
  rewrite bswap_idemp; trivial.
  replace ((t [[u]]) [v]) with (((& (& t)) [[u]]) [v]).
  apply lab_eqc_rx1; assumption.
  rewrite bswap_idemp; trivial.
  replace ((t [[u]]) [[v]]) with (((& (& t)) [[u]]) [[v]]).
  apply lab_eqc_rx3; assumption.
  rewrite bswap_idemp; trivial.
Qed.

(*Lemma lab_eqc_trans : forall t u v, lab_eqc t u -> lab_eqc u v -> lab_eqc t v.*)
(*Proof.*)
  (*intros t u v Htu Huv.*)
  (*induction Huv.*)
  (*[>assumption.<]*)
  (*inversion Htu; subst.*)
  (*[>apply lab_eqc_rx1; assumption.<]*)
  (*rewrite bswap_idemp; trivial.*)
  (*apply lab_eqc_rf.*)
  (*inversion Htu.*)
  (*apply lab_eqc_rx2; assumption.*)
  (*rewrite bswap_idemp; trivial.*)
  (*apply lab_eqc_rf.*)
  (*inversion Htu.*)
  (*apply lab_eqc_rx3; assumption.*)
  (*rewrite bswap_idemp; trivial.*)
  (*apply lab_eqc_rf.*)
(*Qed.  *)

(*Instance lab_eqc_eq : Equivalence lab_eqc.*)
(*Proof.*)
 (*split; intros_all.*)
 (*apply lab_eqc_rf.*)
 (*apply lab_eqc_sym; trivial.*)
 (*generalize H H0. apply lab_eqc_trans.*)
(*Qed.*)

Definition lab_eqC (t: pterm) (u : pterm) :=  trans_closure (lab_contextual_closure lab_eqc) t u .
Notation "t =~e u" := (lab_eqC t u) (at level 66).

(** =~e is an equivalence relation *)

(*Lemma lab_eqC_rf : forall t, t =~e t.*)
(*Proof.*)
 (*intro t. *)
 (*apply one_step_reduction.*)
 (*apply lab_redex. reflexivity.*)
(*Qed.*)

(*Lemma lab_eqc_preserves_SN_lex: forall t t', SN lex t -> lab_eqc t t' -> SN lex t'.
Proof.
  intros t t' H0 H1.
  induction H1. assumption.
  inversion H0.
  inversion H2.
  unfold SN.
  exists x.
  apply SN_intro.
  intros t' H4.
  apply H3.
  assert  (lab_eqc ((t [u]) [[v]]) (((& t) [[v]]) [u])).
  apply lab_eqc_rx1; assumption.
  Admitted.*)

(*Lemma lab_ctx_eqc_sym : forall t u, (lab_contextual_closure lab_eqc t u) -> lab_contextual_closure lab_eqc u t. *)
(*Proof.*)
  (*intros t u H. induction H.*)
  (*apply lab_redex. rewrite H. reflexivity.*)
  (*apply lab_app_left; trivial. *)
  (*apply lab_app_right; trivial.*)
  (*apply lab_abs_in with L; trivial.*)
  (*apply lab_subst_left with (L:=L); trivial.*)
  (*apply lab_subst_right; trivial.*)
  (*apply lab_subst'_left with L; assumption.*)
  (*apply lab_subst'_right; trivial. *)
  (*apply lab_eqc_sym; assumption.*)
(*Qed.*)

(*Lemma lab_eqC_sym : forall t u, t =~e u -> u =~e t.*)
(*Proof.*)
  (*intros t u H.*)
  (*unfold lab_eqC in *.*)
  (*induction H.*)
  (*apply one_step_reduction.*)
  (*apply lab_ctx_eqc_sym; assumption.*)
  (*apply lab_ctx_eqc_sym in H.*)
  (*apply (one_step_reduction (lab_contextual_closure lab_eqc)) in H.*)
  (*apply transitive_closure_composition with u; assumption.*)
(*Qed.  *)

Lemma lab_eqC_trans : forall t u v, t =~e u -> u =~e v -> t =~e v.
Proof.
 intros t u v H H'.
 apply transitive_closure_composition with (u := u); trivial.
Qed.

(*Instance lab_eqC_eq : Equivalence lab_eqC.*)
(*Proof.*)
 (*split; intros_all.*)
 (*apply lab_eqC_rf.*)
 (*apply lab_eqC_sym; trivial.*)
 (*apply lab_eqC_trans with y; trivial.*)
(*Qed.*)

Definition eqcc t t' := eqc t t' \/ lab_eqc t t'.
Notation "t =ee t'" := (eqcc t t') (at level 66).

Definition star_ctx_eqcc (t: pterm) (u : pterm) :=  star_closure (simpl_lab_contextual_closure eqcc) t u .
Notation "t =EE u" := (star_ctx_eqcc t u) (at level 66).

(** TBD:regularity and contextual lemmas are missing. *)

(** Step 2 *)

(** The extended reduction system. This system is used to propagate
terminating labelled substitutions. *)

Inductive lab_sys_x : pterm -> pterm -> Prop :=
| lab_reg_rule_var : forall t, lab_term (pterm_bvar 0 [[t]]) -> lab_sys_x (pterm_bvar 0 [[t]]) t

| lab_reg_rule_gc : forall t u, lab_term t -> lab_term (t[[u]]) -> lab_sys_x (t[[u]]) t

| lab_reg_rule_app : forall t1 t2 u, lab_term (t1[[u]]) -> lab_term (t2[[u]]) ->
  lab_sys_x ((pterm_app t1 t2)[[u]]) (pterm_app (t1[[u]]) (t2[[u]]))

| lab_reg_rule_lamb : forall t u, lab_term ((pterm_abs t)[[u]]) ->
  lab_sys_x ((pterm_abs t)[[u]]) (pterm_abs ((& t)[[u]]))

| lab_reg_rule_comp : forall t u v, lab_term ((t[u])[[v]]) -> ~ term u ->
  lab_sys_x (t[u][[v]]) (((& t)[[v]])[u[[v]]]).
Notation "t ->_lab_x u" := (lab_sys_x t u) (at level 59, left associativity).

Inductive lab_sys_lx: pterm -> pterm -> Prop :=
| B_lx : forall t u, t ->_B u -> lab_sys_lx t u
| sys_x_lx : forall t u, t ->_x u -> lab_sys_lx t u
| sys_x_lab_lx : forall t u, t ->_lab_x u -> lab_sys_lx t u.

Definition red_ctx_mod_lab_eqC (R: pterm -> pterm -> Prop) (t: pterm) (u : pterm) :=
           exists t' u', (t =~e t')/\(ES_contextual_closure R t' u')/\(u' =~e u).

Definition lab_ex (t: pterm) (u : pterm) :=
    exists t' u', (t =~e t')/\(lab_contextual_closure lab_sys_x t' u')/\(u' =~e u).

Definition lab_lex (t: pterm) (u : pterm) :=
    exists t' u', (t =EE t')/\(lab_contextual_closure lab_sys_lx t' u')/\(u' =EE u).

Notation "t -->[ex] u" := (lab_ex t u) (at level 59, left associativity).
Notation "t -->[lex] u" := (lab_lex t u) (at level 59, left associativity).

Definition red_lab_regular (R : pterm -> pterm -> Prop) :=
  forall t t',  R t t' -> lab_term t /\ lab_term t'.

Definition red_lab_regular' (R : pterm -> pterm -> Prop) :=
  forall t t',  R t t' -> (lab_term t <-> lab_term t').

(** Unlabelled reduction is in the corresponding labelled reduction. *)
Lemma sys_Bx_is_lab_sys_lx: forall t t', t -->lex t' -> t -->[lex] t'.
Proof.
    Admitted.

(** Unlabelled of S-terms *)
Fixpoint U_lab (t : pterm) : pterm :=
  match t with
  | pterm_bvar i    => pterm_bvar i
  | pterm_fvar x    => pterm_fvar x
  | pterm_app t1 t2 => pterm_app (U_lab t1) (U_lab t2)
  | pterm_abs t1    => pterm_abs (U_lab t1)
  | pterm_sub t1 t2 => pterm_sub (U_lab t1) (U_lab t2)
  | pterm_lsub t1 t2 => pterm_sub (U_lab t1) t2
  end.

(* ********************************************************************** *)
(** pterm lists  properties *)

Fixpoint cr_lc_at_list (n : nat) (l : list pterm) {struct l} : Prop :=
 match l with
 | nil => True
 | t::lu =>  lc_at' n t /\ (cr_lc_at_list (S n) lu)
 end.

Lemma lc_at_mult_sub : forall n t lu, lc_at' n (t//[lu]) <-> (lc_at' (n + length lu) t /\ cr_lc_at_list n lu).
Proof.
 intros. generalize n; clear n. induction lu; simpl.
 split. intro. assert (Q : n + 0 = n); try omega. rewrite Q. split; trivial.
 intro. assert (Q : n + 0 = n); try omega. rewrite Q in H. apply H.
 intro n. replace (n + S (length lu)) with ((S n) + length lu). split.
 intro H. destruct H. split.
 apply IHlu; trivial. split; trivial. apply IHlu; trivial.
 intro H. destruct H. destruct H0. split; trivial. apply IHlu. split; trivial.
 omega.
Qed.

(** Step 3 *)

(** Step 4 *)


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Structure.Cartesian.
Require Import Category.Structure.Initial.
Require Import Category.Construction.Opposite.

Generalizable All Variables.

(* To be cocartesian is just to be cartesian in the opposite category; but to
   avoid confusion, we'd like a set of notations specific to categories with
   cocartesian structure. *)

Notation "'Cocartesian' C" := (@Cartesian (C^op))
  (at level 9) : category_theory_scope.
Notation "@Cocartesian C" := (@Cartesian (C^op))
  (at level 9) : category_theory_scope.

Section Cocartesian_.

Context `{O : @Cocartesian C}.

Definition Coprod : C → C → C := @product_obj _ O.

Infix "+" := Coprod (at level 50, left associativity) : object_scope.

Definition merge {x y z : C} (f : y ~> x) (g : z ~> x) : y + z ~{C}~> x :=
  @fork _ O _ _ _ f g.

Infix "▽" := merge (at level 26) : morphism_scope.

#[export] Program Instance merge_respects {x y z} :
  Proper (equiv ==> equiv ==> equiv) (@merge x y z).
Next Obligation. apply (@fork_respects _ O). Qed.

Definition inl {x y : C} : x ~{C}~> x + y := @exl _ O _ _.
Definition inr {x y : C} : y ~{C}~> x + y := @exr _ O _ _.

Definition left  {x y z : C} (f : x ~> y) : x + z ~{C}~> y + z :=
  (inl ∘ f) ▽ inr.

Definition right  {x y z : C} (f : x ~> y) : z + x ~{C}~> z + y :=
  inl ▽ (inr ∘ f).

Definition cover  {x y z w : C} (f : x ~> y) (g : z ~> w) :
  x + z ~{C}~> y + w :=
  (inl ∘ f) ▽ (inr ∘ g).

#[export] Program Instance left_respects {a b c : C} :
  Proper (equiv ==> equiv) (@left a b c).
Next Obligation. apply (@first_respects _ O). Qed.

#[export] Program Instance right_respects {a b c : C} :
  Proper (equiv ==> equiv) (@right a b c).
Next Obligation. apply (@second_respects _ O). Qed.

#[export] Program Instance cover_respects {a b c d : C} :
  Proper (equiv ==> equiv ==> equiv) (@cover a b c d).
Next Obligation.
  proper.
  unfold cover.
  rewrites.
  reflexivity.
Qed.

Definition paws {x y : C} : x + y ~{C}~> y + x := @swap _ O _ _.

Lemma inl_merge {x z w : C} (f : z ~> x) (g : w ~> x) :
  f ▽ g ∘ inl ≈ f.
Proof. apply (@exl_fork _ O). Qed.

#[local] Hint Rewrite @inl_merge : categories.

Lemma inr_merge {x z w : C} (f : z ~> x) (g : w ~> x) :
  f ▽ g ∘ inr ≈ g.
Proof. apply (@exr_fork _ O). Qed.

#[local] Hint Rewrite @inr_merge : categories.

Corollary merge_inl_inr {x y : C} :
  inl ▽ inr ≈ @id C (x + y).
Proof. apply (@fork_exl_exr _ O). Qed.

#[local] Hint Rewrite @merge_inl_inr : categories.

Corollary merge_inv {x y z : C} (f h : y ~> x) (g i : z ~> x) :
  f ▽ g ≈ h ▽ i ↔ (f ≈ h) * (g ≈ i).
Proof. apply (@fork_inv _ O). Qed.

Corollary merge_comp {x y z w : C} (f : y ~> z) (h : w ~> z) (g : z ~> x) :
  (g ∘ f) ▽ (g ∘ h) ≈ g ∘ f ▽ h.
Proof. apply (@fork_comp _ O). Qed.

Ltac unmerge :=
  unfold paws, cover, left, right; simpl;
  repeat (rewrite <- !merge_comp; cat;
          rewrite <- !comp_assoc; cat).

#[local] Obligation Tactic := cat_simpl; unmerge.

Theorem left_id {x y : C} :
  left (id[x]) ≈ id[x + y].
Proof. unfold left; cat. Qed.

#[local] Hint Rewrite @left_id : categories.

Theorem left_comp {x y z w : C} (f : y ~> z) (g : x ~> y) :
  left (z:=w) (f ∘ g) ≈ left f ∘ left g.
Proof. apply (@first_comp _ O). Qed.

Theorem left_fork {x y z w : C} (f : y ~> x) (g : z ~> x) (h : w ~> y) :
  f ▽ g ∘ left h ≈ (f ∘ h) ▽ g.
Proof. apply (@first_fork _ O). Qed.

Theorem right_id {x y : C} :
  right (id[y]) ≈ id[x + y].
Proof. unfold right; cat. Qed.

#[local] Hint Rewrite @right_id : categories.

Theorem right_comp {x y z w : C} (f : y ~> z) (g : x ~> y) :
  right (z:=w) (f ∘ g) ≈ right f ∘ right g.
Proof. apply (@second_comp _ O). Qed.

Theorem right_fork {x y z w : C} (f : y ~> x) (g : z ~> x) (h : w ~> z) :
  f ▽ g ∘ right h ≈ f ▽ (g ∘ h).
Proof. apply (@second_fork _ O). Qed.

Corollary inl_left {x y z : C} (f : x ~> y) :
  left f ∘ @inl x z ≈ inl ∘ f.
Proof. apply (@exl_first _ O). Qed.

#[local] Hint Rewrite @inl_left : categories.

Corollary inr_left {x y z : C} (f : x ~> y) :
  left f ∘ @inr x z ≈ inr.
Proof. apply (@exr_first _ O). Qed.

#[local] Hint Rewrite @inr_left : categories.

Corollary inl_right {x y z : C} (f : x ~> y) :
  right f ∘ @inl z x ≈ inl.
Proof. apply (@exl_second _ O). Qed.

#[local] Hint Rewrite @inl_right : categories.

Corollary inr_right {x y z : C} (f : x ~> y) :
  right f ∘ @inr z x ≈ inr ∘ f.
Proof. apply (@exr_second _ O). Qed.

#[local] Hint Rewrite @inr_right : categories.

Theorem paws_left {x y z : C} (f : x ~> y) :
  paws ∘ left (z:=z) f ≈ right f ∘ paws.
Proof. symmetry; apply (@swap_second _ O y x z f). Qed.

Theorem paws_right {x y z : C} (f : x ~> y) :
  paws ∘ right f ≈ left (z:=z) f ∘ paws.
Proof. symmetry; apply (@swap_first _ O y x z f). Qed.

Theorem left_right {x y z w : C} (f : x ~> y) (g : z ~> w) :
  left f ∘ right g ≈ right g ∘ left f.
Proof. symmetry; apply (@first_second _ O). Qed.

Theorem paws_fork {x y z : C} (f : y ~> x) (g : z ~> x) :
  f ▽ g ∘ paws ≈ g ▽ f.
Proof. apply (@swap_fork _ O). Qed.

Definition paws_invol {x y : C} :
  paws ∘ paws ≈ @id C (x + y).
Proof. unfold paws; apply (@swap_invol _ O). Qed.

#[local] Hint Rewrite @paws_invol : categories.

Theorem cover_id {x y : C} :
  cover (id[x]) (id[y]) ≈ id[x + y].
Proof. now unmerge; cat. Qed.

#[local] Hint Rewrite @cover_id : categories.

Theorem cover_comp {x y z w v u : C}
        (f : y ~> z) (h : x ~> y) (g : v ~> u) (i : w ~> v) :
  cover f g ∘ cover h i ≈ cover (f ∘ h) (g ∘ i).
Proof.
  unmerge.
  rewrite !comp_assoc.
  rewrite <- merge_comp.
  unfold cover.
  rewrite !comp_assoc.
  rewrite inl_merge.
  rewrite inr_merge.
  reflexivity.
Qed.

Theorem cover_left {x y z v u : C}
        (f : y ~> z) (h : x ~> y) (g : v ~> u) :
  cover f g ∘ left h ≈ cover (f ∘ h) g.
Proof.
  unmerge.
  rewrite <- merge_comp.
  rewrite inr_merge.
  rewrite comp_assoc.
  rewrite inl_merge.
  rewrite comp_assoc.
  reflexivity.
Qed.

Theorem left_cover {x y z v u : C}
        (f : y ~> z) (h : x ~> y) (g : v ~> u) :
  left f ∘ cover h g ≈ cover (f ∘ h) g.
Proof.
  unmerge.
  rewrite <- merge_comp.
  rewrite !comp_assoc.
  rewrite inl_merge.
  rewrite inr_merge.
  reflexivity.
Qed.

Theorem cover_right {x y z v u : C}
        (f : y ~> z) (h : x ~> y) (g : v ~> u) :
  cover g f ∘ right h ≈ cover g (f ∘ h).
Proof.
  unmerge.
  rewrite <- merge_comp.
  rewrite !comp_assoc.
  rewrite inl_merge.
  rewrite inr_merge.
  reflexivity.
Qed.

Theorem right_cover {x y z v u : C}
        (f : y ~> z) (h : x ~> y) (g : v ~> u) :
  right f ∘ cover g h ≈ cover g (f ∘ h).
Proof.
  unmerge.
  rewrite <- merge_comp.
  rewrite !comp_assoc.
  rewrite inl_merge.
  rewrite inr_merge.
  reflexivity.
Qed.

Theorem cover_inl {x y z w : C} (f : x ~> y) (g : z ~> w):
  cover f g ∘ inl ≈ inl ∘ f.
Proof. unmerge; cat. Qed.

Theorem cover_inr {x y z w : C} (f : x ~> y) (g : z ~> w):
  cover f g ∘ inr ≈ inr ∘ g.
Proof. unmerge; cat. Qed.

#[export] Program Instance coprod_respects_iso :
  Proper (Isomorphism ==> Isomorphism ==> Isomorphism) Coprod.
Next Obligation.
  proper.
  construct.
  - exact (cover (to X) (to X0)).
  - exact (cover (from X) (from X0)).
  - now rewrite cover_comp, !iso_to_from, cover_id.
  - now rewrite cover_comp, !iso_from_to, cover_id.
Defined.

Context `{I : @Initial C}.

#[export] Program Instance coprod_zero_l {x : C} :
  0 + x ≅ x := {
  to   := zero ▽ id;
  from := inr
}.
Next Obligation. apply (@prod_one_l _ _ I). Qed.

#[local] Hint Rewrite @coprod_zero_l : isos.

#[export] Program Instance coprod_zero_r {x : C} :
  x + 0 ≅ x := {
  to   := id ▽ zero;
  from := inl
}.
Next Obligation. apply (@prod_one_r _ _ I). Qed.

#[local] Hint Rewrite @coprod_zero_r : isos.

#[export] Program Instance coprod_comm  {x y : C} :
  x + y ≅ y + x := {
  to   := paws;
  from := paws
}.

#[export] Program Instance coprod_assoc  {x y z : C} :
  (x + y) + z ≅ x + (y + z) := {
  to   := (inl ▽ (inr ∘ inl)) ▽ (inr ∘ inr);
  from := (inl ∘ inl) ▽ ((inl ∘ inr) ▽ inr)
}.
Next Obligation. apply (@prod_assoc _ O). Qed.
Next Obligation. apply (@prod_assoc _ O). Qed.

End Cocartesian_.

Infix "+" := Coprod (at level 50, left associativity) : object_scope.
Infix "▽" := merge (at level 26) : morphism_scope.

#[export] Hint Rewrite @inl_merge : categories.
#[export] Hint Rewrite @inr_merge : categories.
#[export] Hint Rewrite @merge_inl_inr : categories.
#[export] Hint Rewrite @coprod_zero_r : isos.
#[export] Hint Rewrite @coprod_zero_l : isos.

Ltac unmerge :=
  unfold paws, cover, left, right; simpl;
  repeat (rewrite <- !merge_comp; cat;
          rewrite <- !comp_assoc; cat).


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Some useful lemmas about Paths.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export CpdtTactics.
Require Export Case.
Require Export FormalSyntax.

(* Unused but they may be needed as I go into heap weakening. *)

(* Unused *)
Lemma beq_path_symmetric:
  forall (p p' : P),
    beq_path p p' = beq_path p' p.
Proof.
  induction p; induction p'.
  Case "[],[]".
   reflexivity.
  Case "[], a :: p'".
   compute.
   destruct a; try destruct i; try reflexivity.
  Case "a :: p, []".
   compute.
   destruct a; try destruct i; try reflexivity.
  Case "a ::p, a0 :: p'".
  (* Cute reasoning by cases. *)
   destruct a; try destruct i; destruct a0; try destruct i0; unfold beq_path;
   fold   beq_path; try destruct i; try reflexivity.
   destruct p'.
   admit.
   admit.
   admit.
   admit.
Qed.

(* Unused. *)
Lemma beq_path_eq:
  forall (p p' : P),
    beq_path p p' = true ->
    p = p'.
Proof.
  intros.
  case_eq (beq_path p p').
  intros.
  destruct p; destruct p'.
  unfold beq_path in H.
  unfold beq_path in H0.
  symmetry in H.
  reflexivity.
  inversion H.
  inversion H.
  destruct p.
  destruct i.
  inversion H2.
  inversion H2.
  inversion H2.
  admit. (* Need beq_path -> equality. *)
  intros.
  rewrite H in H0.
  inversion H0.
Qed.

(* Unused. *)
Lemma beq_path_neq:
  forall (p p' : P),
    beq_path p p' = false ->
    p <> p'.
Proof.
  intros.
  case_eq (beq_path p p').
  intros.
  destruct p; destruct p'.
  unfold beq_path in H.
  unfold beq_path in H0.
  inversion H.
  rewrite H in H0.
  inversion H0.
  rewrite H in H0.
  inversion H0.
  admit.
  intros.
  destruct p; destruct p'.
  inversion H.
  admit.
  admit.
  admit.
Qed.


Require Export mto_paper_definitions.

Lemma lowEquiv_refl : forall M, (lowEquivalentMem M M).
Proof.
	intros M.
	unfold lowEquivalentMem.
	split.
	intros x v.
	apply iff_refl.
	intros x v.
	apply iff_refl.
Qed.

Lemma lowEquiv_trans :
	forall M1 M2 M3, (lowEquivalentMem M1 M2) ->
	(lowEquivalentMem M2 M3) ->
	(lowEquivalentMem M1 M3).
Proof.
	intros M1 M2 M3 H1 H2.
	unfold lowEquivalentMem in *.
	split.
	intros x v.
	apply iff_trans with (M2 x = Some (vint v low)).
	apply H1.
	apply H2.
	intros x v.
	apply iff_trans with (M2 x = Some (varr v low)).
	apply H1.
	apply H2.
Qed.

Lemma lowEquiv_persist :
	forall M1 M2 x v,
	(lowEquivalentMem M1 M2) ->
	(lowEquivalentMem (memdefine M1 x v) (memdefine M2 x v)).
Proof.
	intros M1 M2 x v H.
	unfold lowEquivalentMem.
	split.
	intros x0 v0.
	unfold memdefine.
	remember (varideq x0 x).
	destruct b.
	apply iff_refl.
	apply H.
	intros x0 v0.
	unfold memdefine.
	remember (varideq x0 x).
	destruct b.
	apply iff_refl.
	apply H.
Qed.

Lemma lowEquiv_sym :
	forall M1 M2,
	(lowEquivalentMem M1 M2) -> (lowEquivalentMem M2 M1).
Proof.
	intros M1 M2 H.
	unfold lowEquivalentMem in *.
	split.
	intros x v.
	apply iff_sym.
	apply H.
	intros x v.
	apply iff_sym.
	apply H.
Qed.

Lemma lowEquiv_persist_high_int :
	forall M1 x v o,
	(exists v1, M1 x = Some (vint v1 (o_high o))) ->
	(lowEquivalentMem (memdefine M1 x (vint v (o_high o))) M1).
Proof.
	intros M1 x v o H.
	unfold lowEquivalentMem.
	split.
	intros x0 v0.
	unfold memdefine.
	remember (varideq x0 x).
	destruct b.
	split.
	intros HH.
	inversion HH.

	intros HH.
	unfold varideq in Heqb.
	destruct x0.
	destruct i.
	destruct x.
	destruct i.
	remember (beq_nat n n0).
	destruct b.
	symmetry in Heqb0.
	apply beq_nat_true in Heqb0.
	rewrite Heqb0 in HH.
	rewrite HH in H.
	inversion H.
	inversion H0.
	inversion Heqb.
	apply iff_refl.

	intros x0 v0.
	unfold memdefine.
	unfold varideq.
	destruct x0.
	destruct x.
	destruct i.
	destruct i0.
	remember (beq_nat n n0).
	destruct b.
	split.
	intros HH.
	inversion HH.
	intros HH.
	symmetry in Heqb.
	apply beq_nat_true in Heqb.
	rewrite Heqb in HH.
	rewrite HH in H.
	inversion H.
	inversion H0.
	apply iff_refl.
Qed.

Lemma lowEquiv_persist_high_arr :
	forall M1 x v o,
	(exists v1, M1 x = Some (varr v1 (o_high o))) ->
	(lowEquivalentMem (memdefine M1 x (varr v (o_high o))) M1).
Proof.
	intros M1 x v o H.
	unfold lowEquivalentMem.
	split.
	intros x0 v0.
	unfold memdefine.
	remember (varideq x0 x).
	destruct b.
	split.
	intros HH.
	inversion HH.

	intros HH.
	unfold varideq in Heqb.
	destruct x0.
	destruct i.
	destruct x.
	destruct i.
	remember (beq_nat n n0).
	destruct b.
	symmetry in Heqb0.
	apply beq_nat_true in Heqb0.
	rewrite Heqb0 in HH.
	rewrite HH in H.
	inversion H.
	inversion H0.
	inversion Heqb.
	apply iff_refl.

	intros x0 v0.
	unfold memdefine.
	unfold varideq.
	destruct x0.
	destruct x.
	destruct i.
	destruct i0.
	remember (beq_nat n n0).
	destruct b.
	split.
	intros HH.
	inversion HH.
	intros HH.
	symmetry in Heqb.
	apply beq_nat_true in Heqb.
	rewrite Heqb in HH.
	rewrite HH in H.
	inversion H.
	inversion H0.
	apply iff_refl.
Qed.