(* ***********************************************************************)
(*                                                                       *)
(*   Synchronously executed Interpreted Time Petri Nets (SITPNs)         *)
(*                                                                       *)
(*                                                                       *)
(*   Copyright Université de Montpellier, contributor(s): Vincent        *)
(*   Iampietro, David Andreu, David Delahaye (May 2020)                  *)
(*                                                                       *)
(*   This software is governed by the CeCILL-C license under French law  *)
(*   and abiding by the rules of distribution of free software.  You can *)
(*   use, modify and/ or redistribute the software under the terms of    *)
(*   the CeCILL-C license as circulated by CEA, CNRS and INRIA at the    *)
(*   following URL "http://www.cecill.info".  The fact that you are      *)
(*   presently reading this means that you have had knowledge of the     *)
(*   CeCILL-C license and that you accept its terms.                     *)
(*                                                                       *)
(* ***********************************************************************)

(* Import Sitpn material. *)

Require Import simpl.Sitpn.
Require Import simpl.SitpnTokenPlayer.
Require Import simpl.SitpnSemantics.

(* Import lemmas on fired transitions. *)

Require Import simpl.SitpnWellDefFired.

(* Import lemmas on interpretation. *)

Require Import simpl.SitpnWellDefInterpretation.

(* Import lemmas on marking. *)

Require Import simpl.SitpnRisingEdgeMarking.

(* Import lemmas on well-definition. *)

Require Import simpl.SitpnRisingEdgeWellDef.

(* Import misc. tactics and lemmas. *)

Require Import simpl.SitpnTactics.

(** * [sitpn_rising_edge] and [sitpn_state_eq] relation. *)

(** ** [sitpn_state_eq], [sitpn_rising_edge] and marking. *)

(** Lemmas on [pre_sum] and [post_sum] functions. *)

(** ∀ t, ∀ l, t ∈ l ∧ NoDup l ⇒ pre_sum l = pre t + pre_sum (l - {t})
 *  Needed to prove pre_sum_eq_iff_incl. *)

Lemma pre_sum_add_rm :
  forall (sitpn : Sitpn)
    (p : Place)
    (l : list Trans)
    (t : Trans),
    In t l ->
    NoDup l ->
    pre_sum sitpn p l = pre sitpn t p + pre_sum sitpn p (remove eq_nat_dec t l).
Proof.
  intros sitpn p l;
    functional induction (pre_sum sitpn p l) using pre_sum_ind;
    intros a Hin_a_l Hnodup_l.
  - inversion Hin_a_l.
  - inversion_clear Hin_a_l as [Heq_at | Hin_a_tl].
    + rewrite <- Heq_at.
      simpl; case (Nat.eq_dec t t).
      -- intro Heq_refl.
         rewrite NoDup_cons_iff in Hnodup_l; apply proj1 in Hnodup_l.
         specialize (not_in_remove_eq Nat.eq_dec t tail Hnodup_l) as Heq_rm.
         rewrite Heq_rm; reflexivity.
      -- intro Heq_diff; elim Heq_diff; reflexivity.
    + simpl; case (Nat.eq_dec a t).
      -- rewrite NoDup_cons_iff in Hnodup_l; apply proj1 in Hnodup_l.
         specialize (not_in_in_diff t a tail (conj Hnodup_l Hin_a_tl)) as Hdiff_ta.
         intro Heq_at; symmetry in Heq_at; contradiction.
      -- intro Hdiff_at.
         simpl; symmetry; rewrite Nat.add_comm.
         rewrite <- Nat.add_assoc.
         rewrite Nat.add_cancel_l; symmetry; rewrite Nat.add_comm.
         rewrite NoDup_cons_iff in Hnodup_l; apply proj2 in Hnodup_l.
         apply (IHn a Hin_a_tl Hnodup_l).
Qed.

(** For all list of transitions l and l', if l is a permutation
 *  of l', then pre_sum l = pre_sum l'. *)

Lemma pre_sum_eq_iff_incl :
  forall (sitpn : Sitpn)
         (p : Place)
         (l l' : list Trans),
    NoDup l ->
    NoDup l' ->
    (forall t : Trans, In t l <-> In t l') ->
    pre_sum sitpn p l = pre_sum sitpn p l'.
Proof.
  intros sitpn p l;
    functional induction (pre_sum sitpn p l) using pre_sum_ind;
    intros l' Hnodup_l Hnodup_l' Hequiv.
  (* BASE CASE *)
  - functional induction (pre_sum sitpn p l') using pre_sum_ind.
    + reflexivity.
    + assert (Hin_eq : In t (t :: tail)) by apply in_eq.
      rewrite <- Hequiv in Hin_eq; inversion Hin_eq.
  (* GENERAL CASE *)
  - assert (Hin_eq : In t (t :: tail)) by apply in_eq.
    rewrite Hequiv in Hin_eq.
    specialize (pre_sum_add_rm sitpn p l' t Hin_eq Hnodup_l') as Heq_presum.
    rewrite Heq_presum.
    rewrite Nat.add_cancel_l.
    assert (Hequiv_tl : forall t0 : Trans, In t0 tail <-> In t0 (remove Nat.eq_dec t l')).
    {
      intro t0; split.
      - intro Hin_tl; specialize (in_cons t t0 tail Hin_tl) as Hin_t0_ctl.
        rewrite NoDup_cons_iff in Hnodup_l.
        apply proj1 in Hnodup_l.
        specialize (not_in_in_diff t t0 tail (conj Hnodup_l Hin_tl)) as Hdiff_tt0.
        apply not_eq_sym in Hdiff_tt0.
        rewrite Hequiv in Hin_t0_ctl.
        rewrite in_remove_iff; apply (conj Hin_t0_ctl Hdiff_tt0).
      - intro Hin_rm.
        rewrite in_remove_iff in Hin_rm.
        elim Hin_rm; clear Hin_rm; intros Hin_t0_l' Hdiff_t0t.
        rewrite <- Hequiv in Hin_t0_l'.
        inversion_clear Hin_t0_l' as [Heq_t0t | Hin_t0_tl].
        + symmetry in Heq_t0t; contradiction.
        + assumption.
    }
    rewrite NoDup_cons_iff in Hnodup_l; apply proj2 in Hnodup_l.
    specialize (nodup_if_remove l' Hnodup_l' t Nat.eq_dec) as Hnodup_rm.
    apply (IHn (remove Nat.eq_dec t l') Hnodup_l Hnodup_rm Hequiv_tl).
Qed.

(** ∀ t, ∀ l, t ∈ l ∧ NoDup l ⇒ post_sum l = post t + post_sum (l - {t})
 *  Needed to prove post_sum_eq_iff_incl. *)

Lemma post_sum_add_rm :
  forall (sitpn : Sitpn)
         (p : Place)
         (l : list Trans)
         (t : Trans),
    In t l -> NoDup l -> post_sum sitpn p l = post sitpn t p + post_sum sitpn p (remove eq_nat_dec t l).
Proof.
  intros sitpn p l;
    functional induction (post_sum sitpn p l) using post_sum_ind;
    intros a Hin_a_l Hnodup_l.
  - inversion Hin_a_l.
  - inversion_clear Hin_a_l as [Heq_at | Hin_a_tl].
    + rewrite <- Heq_at.
      simpl; case (Nat.eq_dec t t).
      -- intro Heq_refl.
         rewrite NoDup_cons_iff in Hnodup_l; apply proj1 in Hnodup_l.
         specialize (not_in_remove_eq Nat.eq_dec t tail Hnodup_l) as Heq_rm.
         rewrite Heq_rm; reflexivity.
      -- intro Heq_diff; elim Heq_diff; reflexivity.
    + simpl; case (Nat.eq_dec a t).
      -- rewrite NoDup_cons_iff in Hnodup_l; apply proj1 in Hnodup_l.
         specialize (not_in_in_diff t a tail (conj Hnodup_l Hin_a_tl)) as Hdiff_ta.
         intro Heq_at; symmetry in Heq_at; contradiction.
      -- intro Hdiff_at.
         simpl; symmetry; rewrite Nat.add_comm.
         rewrite <- Nat.add_assoc.
         rewrite Nat.add_cancel_l; symmetry; rewrite Nat.add_comm.
         rewrite NoDup_cons_iff in Hnodup_l; apply proj2 in Hnodup_l.
         apply (IHn a Hin_a_tl Hnodup_l).
Qed.

(** For all list of transitions l and l', if l is a permutation
 *  of l', then post_sum l = post_sum l'. *)

Lemma post_sum_eq_iff_incl :
  forall (sitpn : Sitpn)
         (p : Place)
         (l l' : list Trans),
    NoDup l ->
    NoDup l' ->
    (forall t : Trans, In t l <-> In t l') ->
    post_sum sitpn p l = post_sum sitpn p l'.
Proof.
  intros sitpn p l;
    functional induction (post_sum sitpn p l) using post_sum_ind;
    intros l' Hnodup_l Hnodup_l' Hequiv.
  (* BASE CASE *)
  - functional induction (post_sum sitpn p l') using post_sum_ind.
    + reflexivity.
    + assert (Hin_eq : In t (t :: tail)) by apply in_eq.
      rewrite <- Hequiv in Hin_eq; inversion Hin_eq.
  (* GENERAL CASE *)
  - assert (Hin_eq : In t (t :: tail)) by apply in_eq.
    rewrite Hequiv in Hin_eq.
    specialize (post_sum_add_rm sitpn p l' t Hin_eq Hnodup_l') as Heq_postsum.
    rewrite Heq_postsum.
    rewrite Nat.add_cancel_l.
    assert (Hequiv_tl : forall t0 : Trans, In t0 tail <-> In t0 (remove Nat.eq_dec t l')).
    {
      intro t0; split.
      - intro Hin_tl; specialize (in_cons t t0 tail Hin_tl) as Hin_t0_ctl.
        rewrite NoDup_cons_iff in Hnodup_l.
        apply proj1 in Hnodup_l.
        specialize (not_in_in_diff t t0 tail (conj Hnodup_l Hin_tl)) as Hdiff_tt0.
        apply not_eq_sym in Hdiff_tt0.
        rewrite Hequiv in Hin_t0_ctl.
        rewrite in_remove_iff; apply (conj Hin_t0_ctl Hdiff_tt0).
      - intro Hin_rm.
        rewrite in_remove_iff in Hin_rm.
        elim Hin_rm; clear Hin_rm; intros Hin_t0_l' Hdiff_t0t.
        rewrite <- Hequiv in Hin_t0_l'.
        inversion_clear Hin_t0_l' as [Heq_t0t | Hin_t0_tl].
        + symmetry in Heq_t0t; contradiction.
        + assumption.
    }
    rewrite NoDup_cons_iff in Hnodup_l; apply proj2 in Hnodup_l.
    specialize (nodup_if_remove l' Hnodup_l' t Nat.eq_dec) as Hnodup_rm.
    apply (IHn (remove Nat.eq_dec t l') Hnodup_l Hnodup_rm Hequiv_tl).
Qed.

Lemma sitpn_rising_edge_state_eq_perm_marking :
  forall (sitpn : Sitpn)
         (s s' state state' : SitpnState),
    IsWellDefinedSitpn sitpn ->
    IsWellDefinedSitpnState sitpn s ->
    IsWellDefinedSitpnState sitpn state ->
    sitpn_state_eq s state ->
    sitpn_rising_edge sitpn s = Some s' ->
    sitpn_rising_edge sitpn state = Some state' ->
    Permutation (marking s') (marking state').
Proof.
  intros sitpn s s' state state' Hwell_def_sitpn Hwell_def_s
         Hwell_def_state Hsteq_sstate Hrising_s Hrising_state.

  (* Stategy is to apply NoDup_Permutation, then we need:
     - NoDup (marking s')
     - NoDup (marking state')
     - ∀(p, n) ∈ (marking s') ⇔ (p, n) ∈ (marking state'). *)

  (* Builds NoDup (marking s') and NoDup (marking state') *)

  specialize (sitpn_rising_edge_well_def_state
                sitpn s s' Hwell_def_sitpn Hwell_def_s Hrising_s)
    as Hwell_def_s'.
  deduce_nodup_state_marking for s'.

  specialize (sitpn_rising_edge_well_def_state
                sitpn state state' Hwell_def_sitpn Hwell_def_state Hrising_state)
    as Hwell_def_state'.
  deduce_nodup_state_marking for state'.

  (* Saves the NoDup fs hypotheses for later. *)
  assert (Hnodup_ms := Hnodup_fs_ms).
  assert (Hnodup_mstate := Hnodup_fs_ms0).
  rename Hnodup_fs_ms0 into Hnodup_fs_mstate'.
  rename Hnodup_fs_ms into Hnodup_fs_ms'.

  apply nodup_fst_split in Hnodup_ms.
  apply nodup_fst_split in Hnodup_mstate.

  (* We must specialize eq_if_eq_fs to deduce
     ∀(p, n) ∈ (marking s') ⇔ (p, n) (marking state') *)

  (* First, we have to build:
     ∀(a, b) ∈ (marking s) ⇒ ∃b', (a, b') ∈ (marking s') ∧
                                   (a, b') ∈ (marking state') *)

  (* Specializes sitpn_rising_edge_sub_pre_add_post for
     Hrising_s and Hrising_state. *)
  specialize (sitpn_rising_edge_sub_pre_add_post
                sitpn s s' Hwell_def_sitpn Hwell_def_s Hrising_s)
    as Hdef_marking_s'.
  specialize (sitpn_rising_edge_sub_pre_add_post
                sitpn state state' Hwell_def_sitpn Hwell_def_state Hrising_state)
    as Hdef_marking_state'.

  assert (Hin_ms_ex_in :
            forall (a : Place) (b : nat),
              In (a, b) (marking s) ->
              exists b' : nat, In (a, b') (marking s') /\ In (a, b') (marking state')
         ).
  {
    (* Builds Permutation (marking s) (marking state) *)
    assert (Hperm_m := Hsteq_sstate).
    unfold sitpn_state_eq in Hperm_m.
    apply proj1 in Hperm_m.

    (* Specializes Hdef_*. *)
    intros a b Hin_ms.

    specialize (Hdef_marking_s' a b Hin_ms).
    rewrite Hperm_m in Hin_ms.
    specialize (Hdef_marking_state' a b Hin_ms).

    (* Builds pre_sum (fired s) = pre_sum (fired state).
     * Deduced from Permutation (fired s) (fired state). *)

    assert (Hperm_fired := Hsteq_sstate).
    unfold sitpn_state_eq in Hperm_fired.
    apply proj2, proj1 in Hperm_fired.

    assert (Hequiv_fired: forall t : Trans, In t (fired s) <-> In t (fired state)) by
        (intros t; rewrite Hperm_fired; reflexivity).

    explode_well_defined_sitpn_state Hwell_def_s.
    explode_well_defined_sitpn_state Hwell_def_state.

    specialize (pre_sum_eq_iff_incl
                  sitpn a (fired s) (fired state)
                  Hnodup_state_fired Hnodup_state_fired0 Hequiv_fired)
      as Heq_presum.

    (* Builds post_sum (fired s) = post_sum (fired state).
     * Deduced from Permutation (fired s) (fired state). *)

    specialize (post_sum_eq_iff_incl
                  sitpn a (fired s) (fired state)
                  Hnodup_state_fired Hnodup_state_fired0 Hequiv_fired)
      as Heq_postsum.

    do 2 clear_well_defined_sitpn_state.
    rewrite Heq_presum in Hdef_marking_s'.
    rewrite Heq_postsum in Hdef_marking_s'.

    (* Instantiates and deduces the goal. *)
    exists (b - pre_sum sitpn a (fired state) + post_sum sitpn a (fired state)).
    auto.
  }

  (* Second, we need: NoDup fs (marking s). *)
  deduce_nodup_state_marking for s.

  (* Third, we need:
     fs (marking s) = fs (marking s') ∧
     fs (marking s) = fs (marking state') *)
  deduce_eq_from_wd_states_for s s'.
  deduce_eq_from_wd_states_for s state'.

  (* Finally, deduces: ∀(p, n) ∈ (marking s') ⇔ (p, n) (marking state') *)
  specialize (eq_if_eq_fs (marking s) (marking s') (marking state')
                          Hin_ms_ex_in Heq_state_marking Heq_state_marking0
                          Hnodup_fs_ms Hnodup_fs_ms' Hnodup_fs_mstate')
    as Hequiv_ms'_mstate'.

  (* Applies NoDup_Permutation, then QED. *)
  assert (Hequiv_simpl : forall (z : Place * nat), In z (marking s') <-> In z (marking state')) by
      (intros z; destruct z; specialize (Hequiv_ms'_mstate' p n); assumption).
  apply (NoDup_Permutation Hnodup_ms Hnodup_mstate Hequiv_simpl).
Qed.

(** ** [sitpn_state_eq], [sitpn_rising_edge] and action states. *)

Lemma sitpn_rising_edge_state_eq_perm_actions :
  forall (sitpn : Sitpn)
         (s s' state state' : SitpnState),
    IsWellDefinedSitpn sitpn ->
    IsWellDefinedSitpnState sitpn s ->
    IsWellDefinedSitpnState sitpn state ->
    sitpn_state_eq s state ->
    sitpn_rising_edge sitpn s = Some s' ->
    sitpn_rising_edge sitpn state = Some state' ->
    Permutation (exec_a s') (exec_a state').
Proof.
  intros sitpn s s' state state' Hwell_def_sitpn Hwell_def_s
         Hwell_def_state Hsteq_sstate Hrising_s Hrising_state.

  (* Specializes sitpn_rising_edge_same_actions for
     Hrising_s and Hrising_state. *)
  specialize (sitpn_rising_edge_same_actions sitpn s s' Hrising_s)
    as Heq_actions_s.
  specialize (sitpn_rising_edge_same_actions sitpn state state' Hrising_state)
    as Heq_actions_state.

  (* Decomposes sitpn_state_eq s state to
     get Permutation (cond_values s) (cond_values state) *)
  unfold sitpn_state_eq in Hsteq_sstate.
  do 5 (apply proj2 in Hsteq_sstate).
  specialize (proj1 Hsteq_sstate) as Hperm_actions.

  (* Rewrites the goal and concludes. *)
  rewrite Heq_actions_s, Heq_actions_state in Hperm_actions; assumption.
Qed.

(** ** [sitpn_state_eq], [sitpn_rising_edge] and condition values. *)

Lemma sitpn_rising_edge_state_eq_perm_condv :
  forall (sitpn : Sitpn)
         (s s' state state' : SitpnState),
    IsWellDefinedSitpn sitpn ->
    IsWellDefinedSitpnState sitpn s ->
    IsWellDefinedSitpnState sitpn state ->
    sitpn_state_eq s state ->
    sitpn_rising_edge sitpn s = Some s' ->
    sitpn_rising_edge sitpn state = Some state' ->
    Permutation (cond_values s') (cond_values state').
Proof.
  intros sitpn s s' state state' Hwell_def_sitpn Hwell_def_s
         Hwell_def_state Hsteq_sstate Hrising_s Hrising_state.

  (* Specializes sitpn_rising_edge_same_condv for
     Hrising_s and Hrising_state. *)
  specialize (sitpn_rising_edge_same_condv sitpn s s' Hrising_s)
    as Heq_condv_s.
  specialize (sitpn_rising_edge_same_condv sitpn state state' Hrising_state)
    as Heq_condv_state.

  (* Decomposes sitpn_state_eq s state to
     get Permutation (cond_values s) (cond_values state) *)
  unfold sitpn_state_eq in Hsteq_sstate.
  do 4 (apply proj2 in Hsteq_sstate).
  specialize (proj1 Hsteq_sstate) as Hperm_condv.

  (* Rewrites the goal and concludes. *)
  rewrite Heq_condv_s, Heq_condv_state in Hperm_condv; assumption.
Qed.

(** ** [sitpn_state_eq], [sitpn_rising_edge] and fired transitions. *)

Lemma sitpn_rising_edge_state_eq_perm_fired :
  forall (sitpn : Sitpn)
         (s s' state state' : SitpnState),
    IsWellDefinedSitpn sitpn ->
    IsWellDefinedSitpnState sitpn s ->
    IsWellDefinedSitpnState sitpn state ->
    sitpn_state_eq s state ->
    sitpn_rising_edge sitpn s = Some s' ->
    sitpn_rising_edge sitpn state = Some state' ->
    Permutation (fired s') (fired state').
Proof.
  intros sitpn s s' state state' Hwell_def_sitpn Hwell_def_s
         Hwell_def_state Hsteq_sstate Hrising_s Hrising_state.

  (* Specializes sitpn_rising_edge_same_fired for
     Hrising_s and Hrising_state. *)
  specialize (sitpn_rising_edge_same_fired sitpn s s' Hrising_s)
    as Heq_fired_s.
  specialize (sitpn_rising_edge_same_fired sitpn state state' Hrising_state)
    as Heq_fired_state.

  (* Decomposes sitpn_state_eq s state to
     get Permutation (fired s) (fired state) *)
  unfold sitpn_state_eq in Hsteq_sstate.
  specialize (proj1 (proj2 Hsteq_sstate)) as Hperm_fired.

  (* Rewrites the goal and concludes. *)
  rewrite Heq_fired_s, Heq_fired_state in Hperm_fired; assumption.
Qed.

(** ** [sitpn_state_eq], [sitpn_rising_edge] and dynamic time intervals. *)

Lemma sitpn_rising_edge_state_eq_perm_ditvals :
  forall (sitpn : Sitpn)
         (s s' state state' : SitpnState),
    IsWellDefinedSitpn sitpn ->
    IsWellDefinedSitpnState sitpn s ->
    IsWellDefinedSitpnState sitpn state ->
    sitpn_state_eq s state ->
    sitpn_rising_edge sitpn s = Some s' ->
    sitpn_rising_edge sitpn state = Some state' ->
    Permutation (d_intervals s') (d_intervals state').
Proof.
  intros sitpn s s' state state' Hwell_def_sitpn Hwell_def_s
         Hwell_def_state Hsteq_sstate Hrising_s Hrising_state.
Admitted.

(** ** [sitpn_rising_edge] and [sitpn_state_eq]. *)

Lemma sitpn_rising_edge_state_eq :
  forall (sitpn : Sitpn)
         (s s' state state' : SitpnState),
    IsWellDefinedSitpn sitpn ->
    IsWellDefinedSitpnState sitpn s ->
    IsWellDefinedSitpnState sitpn state ->
    sitpn_state_eq s state ->
    sitpn_rising_edge sitpn s = Some s' ->
    sitpn_rising_edge sitpn state = Some state' ->
    sitpn_state_eq s' state'.
Proof.
  intros sitpn s s' state state' Hwell_def_sitpn Hwell_def_s
         Hwell_def_state Hsteq_sstate Hrising_s Hrising_state.
  unfold sitpn_state_eq.
  repeat split.

  (* CASE Permutation (marking s') (marking state') *)
  - apply (sitpn_rising_edge_state_eq_perm_marking
             sitpn s s' state state' Hwell_def_sitpn Hwell_def_s
             Hwell_def_state Hsteq_sstate Hrising_s Hrising_state).

  (* CASE Permutation (fired s') (fired state') *)
  - apply (sitpn_rising_edge_state_eq_perm_fired
             sitpn s s' state state' Hwell_def_sitpn Hwell_def_s
             Hwell_def_state Hsteq_sstate Hrising_s Hrising_state).

  (* CASE Permutation (d_intervals s') (d_intervals state') *)
  - admit.

  (* CASE Permutation (reset s') (reset state') *)
  - admit.

  (* CASE (cond_values s') (cond_values state') *)
  - apply (sitpn_rising_edge_state_eq_perm_condv
             sitpn s s' state state' Hwell_def_sitpn Hwell_def_s
             Hwell_def_state Hsteq_sstate Hrising_s Hrising_state).

  (* CASE (exec_a s') (exec_a state') *)
  - apply (sitpn_rising_edge_state_eq_perm_actions
             sitpn s s' state state' Hwell_def_sitpn Hwell_def_s
             Hwell_def_state Hsteq_sstate Hrising_s Hrising_state).

  (* CASE (exec_f s') (exec_f state') *)
  - admit.
Admitted.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export orthogonalite.
Set Implicit Arguments.
Unset Strict Implicit.
#[export] Hint Resolve distance_non_nulle scalaire_positif: geo.

Lemma existence_unitaire :
 forall A B : PO,
 A <> B ->
 exists C : PO,
   alignes A B C /\
   scalaire (vec A C) (vec A C) = 1 /\ scalaire (vec A B) (vec A C) >= 0.
intros.
cut
 (ex
    (fun C : PO =>
     vec A C = mult_PP (/ sqrt (scalaire (vec A B) (vec A B))) (vec A B)));
 intros.
elim H0; intros C H1; try clear H0; try exact H1.
cut
 (/ sqrt (scalaire (vec A B) (vec A B)) *
  / sqrt (scalaire (vec A B) (vec A B)) * scalaire (vec A B) (vec A B) = 1);
 intros.
exists C.
split; [ try assumption | idtac ].
apply colineaire_alignes with (/ sqrt (scalaire (vec A B) (vec A B))); auto.
rewrite H1.
split; [ try assumption | idtac ].
Simplscal.
rewrite <- H0; ring.
Simplscal.
apply Rmult_pos; auto with *.
replace
 (/ sqrt (scalaire (vec A B) (vec A B)) *
  / sqrt (scalaire (vec A B) (vec A B))) with
 (/
  (sqrt (scalaire (vec A B) (vec A B)) * sqrt (scalaire (vec A B) (vec A B))));
 auto with real.
rewrite def_sqrt; auto.
auto with *.
auto with *.
apply Rinv_mult_distr; auto with *.
apply existence_representant_mult_vecteur; auto.
Qed.

Lemma scalaire_non_nul :
 forall A B C : PO,
 A <> B ->
 alignes A B C ->
 scalaire (vec A C) (vec A C) = 1 ->
 scalaire (vec A B) (vec A C) >= 0 -> scalaire (vec A B) (vec A C) <> 0.
intros.
halignes H0 k.
rewrite H3.
replace (scalaire (vec A B) (mult_PP k (vec A B))) with
 (k * scalaire (vec A B) (vec A B)).
cut (scalaire (vec A B) (vec A B) <> 0 /\ k <> 0); intros.
cut (~ (k = 0 \/ scalaire (vec A B) (vec A B) = 0)); intros.
unfold not in |- *; intros; apply H5.
apply Rmult_integral; auto with *.
tauto.
split; [ try assumption | idtac ].
auto with geo.
elim (classic (k = 0)); auto; intros.
rewrite H4 in H3.
rewrite H3 in H1.
absurd (0 = 1); auto with *.
rewrite <- H1.
Simplscal.
Simplscal.
Qed.
#[export] Hint Resolve scalaire_non_nul: geo.

Lemma unicite_representant_unitaire :
 forall A B C D : PO,
 A <> B ->
 alignes A B C ->
 scalaire (vec A C) (vec A C) = 1 ->
 scalaire (vec A B) (vec A C) >= 0 ->
 alignes A B D ->
 scalaire (vec A D) (vec A D) = 1 ->
 scalaire (vec A B) (vec A D) >= 0 -> C = D.
intros.
halignes H0 k.
halignes H3 k0.
cut (k = k0); intros.
apply conversion_PP with (a := 1) (b := 1); auto with *.
RingPP2 H6.
RingPP2 H7.
rewrite H8; RingPP.
apply resolution; auto.
replace k with
 (k * scalaire (vec A B) (vec A C) * / scalaire (vec A B) (vec A C)).
replace (k * scalaire (vec A B) (vec A C)) with
 (scalaire (mult_PP k (vec A B)) (vec A C)).
rewrite <- H6; rewrite H1.
replace (1 * / scalaire (vec A B) (vec A C)) with
 (/ scalaire (vec A B) (vec A C)); try ring.
apply Rinv_le_pos; auto with geo real.
Simplscal.
field.
auto with geo.
replace k0 with
 (k0 * scalaire (vec A B) (vec A D) * / scalaire (vec A B) (vec A D)).
replace (k0 * scalaire (vec A B) (vec A D)) with
 (scalaire (mult_PP k0 (vec A B)) (vec A D)).
rewrite <- H7; rewrite H4.
replace (1 * / scalaire (vec A B) (vec A D)) with
 (/ scalaire (vec A B) (vec A D)); try ring.
apply Rinv_le_pos; auto with geo real.
Simplscal.
field.
auto with geo.
cut (scalaire (vec A C) (vec A C) = scalaire (vec A D) (vec A D)); intros.
rewrite H7 in H8; rewrite H6 in H8.
replace (k * k) with
 (scalaire (mult_PP k (vec A B)) (mult_PP k (vec A B)) *
  / scalaire (vec A B) (vec A B)).
replace (k0 * k0) with
 (scalaire (mult_PP k0 (vec A B)) (mult_PP k0 (vec A B)) *
  / scalaire (vec A B) (vec A B)).
rewrite H8; auto.
field_simplify_eq.
Simplscal.
auto with geo.
field_simplify_eq.
Simplscal.
auto with geo.
rewrite H4; auto.
Qed.
Parameter representant_unitaire : PP -> PP.

Axiom
  def_representant_unitaire :
    forall A B C : PO,
    A <> B ->
    alignes A B C ->
    scalaire (vec A C) (vec A C) = 1 ->
    scalaire (vec A B) (vec A C) >= 0 ->
    vec A C = representant_unitaire (vec A B).

Axiom
  def_representant_unitaire2 :
    forall A B C : PO,
    A <> B ->
    vec A C = representant_unitaire (vec A B) ->
    alignes A B C /\
    scalaire (vec A C) (vec A C) = 1 /\ scalaire (vec A B) (vec A C) >= 0.

Lemma existence_representant_unitaire :
 forall A B : PO,
 A <> B -> exists C : PO, vec A C = representant_unitaire (vec A B).
intros A B H; try assumption.
elim existence_unitaire with (A := A) (B := B);
 [ intros C H0; try clear existence_unitaire; try exact H0 | auto ].
exists C.
elim H0; intros H1 H2; elim H2; intros H3 H4; try clear H2 H0; try exact H4.
apply def_representant_unitaire; auto.
Qed.

Ltac applatit_and :=
  match goal with
  | h:(_ /\ _) |- _ => elim h; intros; clear h
  end.

Ltac deroule_representant_unitaire A B C :=
  elim (existence_representant_unitaire (A:=A) (B:=B)); auto; intros C;
   intros; elim (def_representant_unitaire2 (A:=A) (B:=B) (C:=C));
   auto; intros; applatit_and; cut (A <> C); intros;
   [ idtac | auto with geo ].

Lemma produit_positif_representant_unitaire :
 forall (k : R) (A B C : PO),
 A <> B :>PO ->
 k > 0 ->
 vec A C = mult_PP k (vec A B) :>PP ->
 representant_unitaire (vec A B) = representant_unitaire (vec A C).
intros.
cut (A <> C); intros.
2: apply distinct_produit_vecteur with (3 := H1); auto with real.
deroule_representant_unitaire A B B'.
rewrite <- H3.
cut (scalaire (vec A C) (vec A B') >= 0); intros.
apply def_representant_unitaire; auto.
apply alignes_trans with B; auto.
apply colineaire_alignes with k; auto.
rewrite H1.
replace (scalaire (mult_PP k (vec A B)) (vec A B')) with
 (k * scalaire (vec A B) (vec A B')); [ idtac | Simplscal ].
apply Rmult_pos; auto with geo.
apply Rgt_ge; auto.
Qed.

Lemma egalite_representant_unitaire :
 forall A B C : PO,
 A <> B :>PO ->
 A <> C :>PO ->
 representant_unitaire (vec A B) = representant_unitaire (vec A C) :>PP ->
 exists k : R, k > 0 /\ vec A C = mult_PP k (vec A B) :>PP.
intros A B C H H0; try assumption.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros B' H3; try clear existence_representant_unitaire; rewrite <- H3
 | auto ].
elim existence_representant_unitaire with (A := A) (B := C);
 [ intros C' H4; rewrite <- H4; intros | auto ].
elim def_representant_unitaire2 with (A := A) (B := B) (C := B');
 [ intros | auto | auto ].
elim H5; intros H6 H7; try clear H5; try exact H7.
elim def_representant_unitaire2 with (A := A) (B := C) (C := C');
 [ intros | auto | auto ].
elim H8; intros H9 H10; try clear H8; try exact H10.
cut (alignes A C' C); intros; auto with geo.
assert (A <> C'); auto with geo.
halignes H8 k.
halignes H2 k0.
exists (k * k0).
split; [ idtac | try assumption ].
apply Rmult_gt_0_compat.
elim Rtotal_order with (r1 := k) (r2 := 0);
 [ intros H14
 | intros H14; elim H14;
    [ intros H15; try clear H14; try exact H15 | intros H15; try exact H15 ] ].
absurd (scalaire (vec A C) (vec A C') >= 0); auto.
rewrite H12.
replace (scalaire (mult_PP k (vec A C')) (vec A C')) with
 (k * scalaire (vec A C') (vec A C')); [ idtac | Simplscal ].
rewrite H9.
replace (k * 1) with k; [ auto with real | ring ].
absurd (A = C); auto.
apply vecteur_nul_conf.
rewrite H12; rewrite H15; Ringvec.
elim Rtotal_order with (r1 := k0) (r2 := 0);
 [ intros H16; try clear total_order
 | intros H16; elim H16;
    [ intros H17; try clear H16; try exact H17 | intros H17; try exact H17 ] ].
absurd (scalaire (vec A B) (vec A B') >= 0); auto.
replace (vec A B) with (mult_PP (/ k0) (vec A B')); [ Simplscal | idtac ].
rewrite H6.
replace (/ k0 * 1) with (/ k0); [ idtac | ring ].
cut (/ k0 < 0); intros; auto with real.
rewrite H13.
cut (k0 <> 0); intros; auto with real.
Fieldvec k0.
absurd (scalaire (vec A B') (vec A B') = 1); auto.
rewrite H13; rewrite H17; Simplscal.
replace (0 * 0 * scalaire (vec A B) (vec A B)) with 0;
 [ auto with real | ring ].
rewrite H12; rewrite <- H1; rewrite H13; Ringvec.
Qed.

Lemma representant_unitaire_bis :
 forall A B : PO,
 A <> B :>PO ->
 representant_unitaire (representant_unitaire (vec A B)) =
 representant_unitaire (vec A B) :>PP.
intros A B H; try assumption.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros B' H3; try clear existence_representant_unitaire; rewrite <- H3
 | auto ].
elim def_representant_unitaire2 with (A := A) (B := B) (C := B');
 [ intros | auto | auto ].
elim H1; intros H2 H4; try clear H1; try exact H4.
cut (A <> B'); intros; auto with geo.
elim existence_representant_unitaire with (A := A) (B := B');
 [ intros C' H5; rewrite <- H5; intros | auto ].
elim def_representant_unitaire2 with (A := A) (B := B') (C := C');
 [ intros | auto | auto ].
elim H7; intros H8 H9; try clear H7; try exact H9.
cut (A <> C'); intros; auto with geo.
halignes H6 k.
elim Rtotal_order with (r1 := k) (r2 := 0);
 [ intros H13
 | intros H13;
    (elim H13;
      [ intros H14; try clear H13
      | intros H14; try clear H13; try exact H14 ]) ].
absurd (scalaire (vec A B') (vec A C') >= 0); auto.
rewrite H10.
replace (scalaire (vec A B') (mult_PP k (vec A B'))) with
 (k * scalaire (vec A B') (vec A B')); [ idtac | Simplscal ].
rewrite H2.
replace (k * 1) with k; [ auto with real | ring ].
absurd (A = C'); auto with geo.
apply vecteur_nul_conf.
rewrite H10; rewrite H14; Ringvec.
elim (classic (k = 1)); intros.
rewrite H10; rewrite H11; Ringvec.
absurd (scalaire (vec A C') (vec A C') = 1); auto.
rewrite H10; Simplscal; rewrite H2.
replace (k * k * 1) with (Rsqr k) by (unfold Rsqr; ring).
red in |- *; intros; apply H11.
apply Rsqr_inj; auto with real.
rewrite H12; unfold Rsqr in |- *; ring.
Qed.
#[export] Hint Resolve representant_unitaire_bis: geo.

Lemma oppose_representant_unitaire :
 forall A B C : PO,
 A <> B :>PO ->
 A <> C :>PO ->
 representant_unitaire (vec A C) =
 mult_PP (-1) (representant_unitaire (vec A B)) :>PP ->
 exists k : R, k < 0 /\ vec A C = mult_PP k (vec A B) :>PP.
intros A B C H H0; try assumption.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros B' H3; try clear existence_representant_unitaire; rewrite <- H3
 | auto ].
elim existence_representant_unitaire with (A := A) (B := C);
 [ intros C' H4; rewrite <- H4; intros | auto ].
elim def_representant_unitaire2 with (A := A) (B := B) (C := B');
 [ intros | auto | auto ].
elim H5; intros H6 H7; try clear H5; try exact H7.
elim def_representant_unitaire2 with (A := A) (B := C) (C := C');
 [ intros | auto | auto ].
elim H8; intros H9 H10; try clear H8; try exact H10.
cut (representant_unitaire (vec A C) = representant_unitaire (vec A C'));
 intros.
elim egalite_representant_unitaire with (A := A) (B := C) (C := C');
 [ intros k H12; try clear egalite_representant_unitaire; try exact H12
 | auto with geo
 | auto with geo
 | auto with geo ].
elim H12; intros H13 H14; try clear H12; try exact H14.
cut (representant_unitaire (vec A B) = representant_unitaire (vec A B'));
 intros.
elim egalite_representant_unitaire with (A := A) (B := B) (C := B');
 [ intros k0 H12; try clear egalite_representant_unitaire; try exact H12
 | auto with geo
 | auto with geo
 | auto with geo ].
elim H12; intros H15 H16; try clear H12; try exact H16.
cut (k <> 0); auto with real; intros.
replace (vec A C) with (mult_PP (/ k) (vec A C')); idtac.
rewrite H1; rewrite H16.
exists (- (/ k * k0)).
split; [ idtac | Ringvec ].
cut (/ k * k0 > 0); intros; auto with real.
apply Rmult_gt_0_compat; auto with *.
rewrite H14.
Fieldvec k.
rewrite H3; (symmetry  in |- *; auto with geo).
rewrite H4; (symmetry  in |- *; auto with geo).
Qed.

Lemma produit_negatif_representant_unitaire :
 forall (k : R) (A B C : PO),
 A <> B ->
 k < 0 ->
 vec A C = mult_PP k (vec A B) ->
 representant_unitaire (vec A C) =
 mult_PP (-1) (representant_unitaire (vec A B)).
intros.
cut (A <> C); intros.
2: apply distinct_produit_vecteur with (3 := H1); auto.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros B' H3; try clear existence_representant_unitaire; try exact H3
 | auto ].
rewrite <- H3.
elim def_representant_unitaire2 with (A := A) (B := B) (C := B');
 [ intros; elim H5; intros H6 H7; try clear H5; try exact H6 | auto | auto ].
cut (- scalaire (vec A C) (vec A B') >= 0); intros.
symmetry  in |- *.
elim
 existence_representant_mult_vecteur
  with (A := A) (B := A) (C := B') (k := -1); intros D H9;
 try clear existence_representant_mult_vecteur; rewrite <- H9.
apply def_representant_unitaire; auto.
apply alignes_trans with B; auto.
apply colineaire_alignes with k; auto.
halignes H4 k0.
apply colineaire_alignes with (- k0); auto.
rewrite H9; rewrite H8; Ringvec.
rewrite H9; Simplscal; auto.
rewrite H9; Simplscal; auto.
rewrite H1; Simplscal.
apply Rmult_pos; auto.
apply Rgt_ge; auto with real.
auto with real.
Qed.

Lemma alignes_representant_unitaire :
 forall A B C : PO,
 A <> B :>PO ->
 A <> C :>PO ->
 alignes A B C ->
 representant_unitaire (vec A B) = representant_unitaire (vec A C) \/
 representant_unitaire (vec A C) =
 mult_PP (-1) (representant_unitaire (vec A B)).
intros.
halignes H1 k.
elim Rtotal_order with (r1 := k) (r2 := 0);
 [ intros H3; try clear total_order
 | intros H3; elim H3;
    [ intros H4; try clear H3 total_order
    | intros H4; try clear H3 total_order; try exact H4 ] ].
right; try assumption.
apply produit_negatif_representant_unitaire with k; auto.
absurd (k = 0); auto.
contrapose H0.
apply (produit_zero_conf H2); auto.
left; try assumption.
apply produit_positif_representant_unitaire with k; auto.
Qed.


(** UWhile.v *)
From Babel Require Import TerminalDogma
                          ExtraDogma.Extensionality
                          EpsilonDescription
                          SetFacility
                          POrderFacility.

From Babel Require Import Ranko
                            ExtensionalityCharacter
                            ClassicalCharacter.

From Babel.MetaLanguage Require Import Notations
                                        MetaType
                                        MetaLan.

From Coq Require Import Relations Classical.

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

(** Do not import this module. *)
Module UWhile.

(** Syntax *)

Record syn (mT : cpo) (Hj : FlowCtrl.join mT) (syn0 : Type) := while_ {
    flow_split : FlowCtrl.split Hj;
    S0 : syn0;
}.

Notation M0 s := (FlowCtrl.M0 (flow_split s)).
Notation M1 s := (FlowCtrl.M1 (flow_split s)).

Notation "'While' M 'Do' s0 'End'" := (while_ M s0) : MetaLan_scope.

(** DeSem

    Notice the application of Kleene fixpoint here.
*)

Definition while_iter (mT : cpo) (Hj : FlowCtrl.join mT)
    (de0 : deSem mT) (P : mT):
    syn Hj de0 -> mT -> mT :=
        fun s X => ((M0 s) (⟦ S0 s ⟧ <de0> X)) ⊕[Hj] ((M1 s) P).

Lemma while_iter_mono_mixin (mT : cpo) (Hj : FlowCtrl.join mT)
    (de0 : deSem mT) (P : mT) (s : syn Hj de0) :
    MonotonicFun.mixin_of (while_iter P s).
Proof. rewrite /MonotonicFun.mixin_of /while_iter => x y Hxy.
    transitivity (M0 s ((⟦ S0 s ⟧ < de0 >) x) ⊕[ Hj] M1 s P).
    - apply FlowCtrl.join_monot1.
        apply MonotonicFun.class. by reflexivity.
    - apply FlowCtrl.join_monot0.
        apply MonotonicFun.class.
        by apply MonotonicFun.class.
Qed.

Canonical while_iter_mono (mT : cpo) (Hj : FlowCtrl.join mT)
    (de0 : deSem mT) (P : mT) (s : syn Hj de0) : [ mT ↦ᵐ mT ] :=
    MonotonicFun (while_iter P s) (while_iter_mono_mixin P s).

Lemma while_iter_conti_mixin (mT : cpo) (Hj : FlowCtrl.join mT)
    (de0 : deSem mT) (P : mT) (s : syn Hj de0) :
    ContinuousFun.mixin_of (MonotonicFun.class (while_iter P s)).
Proof. rewrite /ContinuousFun.mixin_of => ch //=.
    rewrite /while_iter //=.
Admitted.

Canonical while_iter_conti (mT : cpo) (Hj : FlowCtrl.join mT)
    (de0 : deSem mT) (P : mT) (s : syn Hj de0) : [ mT ↦ mT ] :=
    ContinuousFun (while_iter P s) (while_iter_conti_mixin P s).

Definition de_fun (mT : cpo) (Hj : FlowCtrl.join mT) (de0 : deSem mT) :
    syn Hj de0 -> mT -> mT :=
        fun s P => KleeneFp (while_iter P s).

Lemma de_fun_monot_mixin (mT : cpo) (Hj : FlowCtrl.join mT)
    (de0 : deSem mT) (s : syn Hj de0) : MonotonicFun.mixin_of (de_fun s).
Proof. rewrite /MonotonicFun.mixin_of /de_fun //= => x y Hxy.
    rewrite /KleeneFp.

    (** proof by order of functions by KleeneFp. *)
Admitted.

Canonical de_fun_monot (mT : cpo) (Hj : FlowCtrl.join mT)
    (de0 : deSem mT) (s : syn Hj de0) : [ mT ↦ᵐ mT ] :=
    MonotonicFun (de_fun s) (de_fun_monot_mixin s).

Lemma de_fun_conti_mixin (mT : cpo) (Hj : FlowCtrl.join mT)
    (de0 : deSem mT) (s : syn Hj de0) :
        ContinuousFun.mixin_of (MonotonicFun.class (de_fun s)).
Proof.
    rewrite /ContinuousFun.mixin_of //= => ch.
    rewrite /de_fun //=.
Admitted.

Canonical de_fun_conti (mT : cpo) (Hj : FlowCtrl.join mT)
    (de0 : deSem mT) (s : syn Hj de0) : [ mT ↦ mT ] :=
    ContinuousFun (de_fun s) (de_fun_conti_mixin s).

Definition deSem_mixin (mT : cpo) (Hj : FlowCtrl.join mT) (de0 : deSem mT) :
    DeSem.mixin_of mT (syn Hj de0) :=
{|
	DeSem.de_fun := @de_fun mT Hj de0;
|}.

Definition deSem (mT : cpo) (Hj : FlowCtrl.join mT) (de0 : deSem mT) :=
    DeSem (syn Hj de0) (deSem_mixin Hj de0).

(** AxSem
    Note that cpoDMT is needed here.
*)

Inductive ax_sys (mT : cpoDMT) (Hj : FlowCtrl.join mT) (ax0 : axSem mT) :
    mT -> syn Hj ax0 -> mT -> Prop :=

| RULE_LOOP (M : FlowCtrl.split Hj)
        (s0 : ax0) (P Inv Q : mT)
        (H : ⊢ <ax0> { Inv } s0 { (FlowCtrl.M0 M Inv) ⊕[Hj] (FlowCtrl.M1 M Q) })
        (Himp : mT ⊢ P ⇒ ((FlowCtrl.M0 M Inv) ⊕[Hj] (FlowCtrl.M1 M Q))):

            ax_sys P (While M Do s0 End) Q.

Definition axSem_mixin (mT : cpoDMT) (Hj : FlowCtrl.join mT)
    (ax0 : axSem mT) : AxSem.mixin_of mT (syn Hj ax0)
    := @AxSem.Mixin mT _ (@ax_sys mT Hj ax0).

Definition axSem (mT : cpoDMT) (Hj : FlowCtrl.join mT) (ax0 : axSem mT)
        : AxSem.mixin_of mT (syn Hj ax0) :=
    AxSem (syn Hj ax0) (axSem_mixin Hj ax0).

(*
(** VeriModS *)

Definition veriModS_mixin (mT : cpoDMT) (Hj : FlowCtrl.join mT)
    (veriS0 : veriModS mT):
    VeriModS.mixin_of (axSem Hj veriS0) (deSem Hj veriS0).
Proof.
    constructor. rewrite /VeriModS.axiom => [] [] Hs s0 P Q.
    move => [] //=. intros. rewrite /de_fun.

    transitivity (
        (ContinuousFun.obj (FlowCtrl.M0 M) Inv
          ⊕[ Hj] ContinuousFun.obj (FlowCtrl.M1 M) Q0)
    ).
    - by apply /(CpoDMT.ded_iffP (CpoDMT.mixin mT)).

    apply (soundness_of veriS0) in H.
    rewrite /KleeneFp //=.

    apply (soundness_of veriS1) in H1 => //=.
    apply (soundness_of veriS0) in H0 => //=.

    transitivity ((⟦ s2 ⟧ < DeSem veriS0 (VeriModS.base_de veriS0) >) R).
    - by [].
    - by apply (DeSem.de_monot).
Qed.

Definition veriModS (mT : cpoDMT) (veriS0 veriS1 : veriModS mT) :=
    VeriModS (syn veriS0 veriS1) (veriModS_mixin veriS0 veriS1).
*)
End UWhile.


(*******************************************************************
 * Construcción Formal de Programas en Teoría de Tipos
 * Trabajo práctico final
 * Hernán Gurmendi
 ******************************************************************)

(*******************************************************************
 * Este archivo especifica las acciones
 * (Como transformadores de estado)
 ******************************************************************)

Load State.

Section Actions.

(* Tácticas obtenidas en http://adam.chlipala.net/cpdt/html/Match.html *)
Ltac notHyp P :=
  match goal with
    | [ _ : P |- _ ] => fail 1
    | _ =>
      match P with
        | ?P1 /\ ?P2 => first [ notHyp P1 | notHyp P2 | fail 2 ]
        | _ => idtac
      end
  end.

Ltac extend pf :=
  let t := type of pf in
    notHyp t; generalize pf; intro.

Ltac completer :=
  repeat match goal with
           | [ |- _ /\ _ ] => constructor
           | [ H : _ /\ _ |- _ ] => destruct H
           | [ H : ?P -> ?Q, H' : ?P |- _ ] => specialize (H H')
           | [ |- forall x, _ ] => intro

           | [ H : forall x, ?P x -> _, H' : ?P ?X |- _ ] => extend (H X H')
         end.

Parameter ctxt : context.

(* Ejercicio 7.2 *)

Inductive action : Set :=
  | read (va : vadd)
  | write (va : vadd) (val : value)
  | chmod.

(* Ejercicio 7.3 *)

(* in state _s_, is virtual address _va_ mapped to machine address _ma_? *)
Definition va_mapped_to_ma (s: state) (va: vadd) (ma: madd) : Prop :=
  exists (o: os) (pm: padd -> option madd) (ma': madd) (pg: page) (vm: vadd -> option madd),
    oss s (active_os s) = Some o
    /\ hypervisor s (active_os s) = Some pm
    /\ pm (curr_page o) = Some ma'
    /\ memory s ma' = Some pg
    /\ page_content pg = PT vm
    /\ vm va = Some ma.

(* Action Semantics - read *)

Definition readPre (s : state) (va : vadd) : Prop :=
  ctxt_vadd_accessible ctxt va = true
  /\ aos_activity s = running
  /\ (exists (ma : madd) (pg : page),
    va_mapped_to_ma s va ma
    /\ memory s ma = Some pg
    /\ isRW (page_content pg) = true).

Definition readPost (s s' : state) : Prop :=
  s = s'.

(* Action Semantics - write *)

Definition writePre (s : state) (va : vadd) (val : value) : Prop :=
  ctxt_vadd_accessible ctxt va = true
  /\ aos_activity s = running
  /\ (exists (ma : madd) (pg : page),
    va_mapped_to_ma s va ma
    /\ memory s ma = Some pg
    /\ isRW (page_content pg) = true).

Definition writePost (s s' : state) (va : vadd) (val : value) : Prop :=
  exists (ma : madd) (pg : page),
    va_mapped_to_ma s va ma
    /\ memory s' = (update (memory s) ma (Page (RW (Some val)) (Os (active_os s))))
    /\ active_os s = active_os s'
    /\ aos_exec_mode s = aos_exec_mode s'
    /\ aos_activity s = aos_activity s'
    /\ oss s = oss s'
    /\ hypervisor s = hypervisor s'
    /\ (forall (ma' : madd),
      ma <> ma'
      /\ (memory s) ma'  = (memory s') ma').

(* Action Semantics - chmod *)

Definition chmodPre (s : state) : Prop :=
  aos_activity s = waiting
  /\ (exists (o : os), oss s (active_os s) = Some o /\ hcall o = None).

Definition chmodPost (s s' : state) : Prop :=
    (ctxt_oss ctxt (active_os s) = true
    /\ active_os s = active_os s'
    /\ oss s = oss s'
    /\ hypervisor s = hypervisor s'
    /\ memory s = memory s'
    /\ (aos_exec_mode s = usr /\ aos_exec_mode s' = svc)
    /\ (aos_activity s = waiting /\ aos_activity s' = running))
  \/
    (ctxt_oss ctxt (active_os s) = false
    /\ active_os s = active_os s'
    /\ oss s = oss s'
    /\ hypervisor s = hypervisor s'
    /\ memory s = memory s'
    /\ (aos_exec_mode s = svc /\ aos_exec_mode s' = usr)
    /\ (aos_activity s = waiting /\ aos_activity s' = running)).

(* Ejercicio 7.5 *)

(* Propiedad 3 (iii)
if the hypervisor or a trusted OS is running the processor must be in
supervisor mode *)
Definition Prop3 (s : state) : Prop :=
  ((ctxt_oss ctxt (active_os s) = true /\ aos_activity s = running)
  \/ aos_activity s = waiting)
  -> aos_exec_mode s = svc.

(* Propiedad 5 (v)
the hypervisor maps an OS physical address to a machine address owned by
that same OS. This mapping is also injective *)
Definition Prop5 (s : state) : Prop :=
  forall (o : os_ident) (pa : padd),
    (forall (pm : padd -> option madd), exists (ma : madd) (pg : page),
      (hypervisor s) o = Some pm
      /\ pm pa = Some ma
      /\ memory s ma = Some pg
      /\ page_owned_by pg = Os o
      /\ forall (pa pa' : padd), pm pa = pm pa' -> pa = pa').

(* Propiedad 6 (vi)
all page tables of an OS o map accessible virtual addresses to pages owned
by o and not accessible ones to pages owned by the hypervisor *)
Definition Prop6 (s : state) : Prop :=
  forall (o : os_ident) (pg : page) (vtm : vadd -> option madd),
    (page_content pg = PT vtm /\ page_owned_by pg = Os o)
    -> forall (va : vadd) (ma : madd), exists (pg' : page),
        vtm va = Some ma
        /\ memory s ma = Some pg'
        /\ (ctxt_vadd_accessible ctxt va = true -> page_owned_by pg' = Os o)
        /\ (ctxt_vadd_accessible ctxt va = false -> page_owned_by pg' = Hyp).

Definition ValidState (s : state) : Prop :=
  Prop3 s
  /\ Prop5 s
  /\ Prop6 s.

(* Ejercicio 7.4 *)

Definition Pre (s : state) (a : action) : Prop :=
  match a with
  | read va      => readPre s va
  | write va val => writePre s va val
  | chmod        => chmodPre s
  end.

Definition Post (s s' : state) (a : action) : Prop :=
  match a with
  | read _      => readPost s s'
  | write va val => writePost s s' va val
  | chmod        => chmodPost s s'
  end.

Inductive OneStepExecution : state -> action -> state -> Prop :=
  | OSE : forall (s s' : state) (a : action),
    ValidState s -> Pre s a -> Post s s' a -> OneStepExecution s a s'.

(* Ejercicio 7.6 *)

Lemma ActionsPreserveProp3 (s s' : state) (a : action) :
  OneStepExecution s a s' -> Prop3 s'.
Proof.
  intros.
  inversion H.
  inversion H0.
  unfold Prop3; intros.
  destruct a.
  - inversion H2.
    rewrite H9 in H6.
    elim H6; intros; auto.
  - inversion H2.
    elim H9; intros; auto.
    completer.
    elim H6; intros; auto.
    elim H8; intros; auto.
    + left.
      rewrite H12.
      rewrite H14.
      split; elim H19; intros; assumption.
    + right.
      rewrite H14.
      assumption.
  - inversion H2.
    completer.
    + assumption.
    + completer.
      elim H8; intros; auto.
      * elim H19; intros.
        rewrite H10 in H9.
        rewrite H9 in H20.
        discriminate.
      * rewrite H16 in H19.
        discriminate.
Qed.

(* Ejercicio 7.7 *)

Lemma ReadIsolation (s s' : state) (va : vadd) :
  OneStepExecution s (read va) s' -> exists (ma : madd),
    va_mapped_to_ma s va ma
    /\ exists (pg : page),
      (memory s) ma = Some pg
      /\ page_owned_by pg = Os (active_os s).
Proof.
  intros.
  inversion H.
  inversion H1.
  completer.
  elim H8; intro ma; intros.
  clear H8.
  elim H9; intro pg; intros.
  clear H9.
  completer.
  exists ma.
  split; auto.
  exists pg.
  split; auto.
  inversion H0.
  completer.
  inversion H8.
  elim H14; intro p2m; intros.
  clear H14.
  elim H15; intro ma'; intros.
  clear H15.
  elim H14; intro pg'; intros.
  clear H14.
  elim H15; intro v2m; intros.
  clear H15.
  completer.
  elim H12 with (o := active_os s) (pa := curr_page x) (pm := p2m).
  intros.
  elim H20; intro pg''; intros.
  clear H20.
  completer.
  rewrite H16 in H21.
  injection H21; intros.
  rewrite <- H25 in H22.
  rewrite H17 in H22.
  injection H22; intros.
  rewrite <- H26 in H23.
  elim H13 with (o := active_os s) (pg := pg') (vtm := v2m) (va := va) (ma := ma); intros; completer.
  - rewrite H9 in H28.
    injection H28; intros.
    rewrite H31.
    assumption.
  - assumption.
  - assumption.
Qed.

End Actions.


(** * Bicolano: Big step (interface only) *)

(* <Insert License Here>

    $Id: BigStep.v 68 2006-02-02 15:06:27Z davidpichardie $ *)

(** Big step semantics.

 @author Benjamin Gregoire *)
(* Hendra : - Modified to suit DEX program.
            - Also trim the system to contain only Arithmetic *)

Require Export DEX_Domain.

Set Implicit Arguments.
Definition cons_option (A:Set) (o:option A) (l:list A) :=
   match o with
   | None => l
   | Some e => e::l
   end.
Unset Implicit Arguments.

Section TRANS.
 Set Implicit Arguments.
 Variable A B :Type.
 Variable R : A -> A + B -> Prop.

 Inductive TransStep_l : A -> A + B -> Prop :=
   | TransStep_l_refl : forall a,
       TransStep_l a (inl _ a)
   | TransStep_l_one : forall a r,
        R a r -> TransStep_l a r
   | TransStep_l_trans : forall a1 a2 r,
       R a1 (inl _ a2) ->
       TransStep_l a2 r ->
       TransStep_l a1 r.

 Variable R' : A -> A -> Prop.

 Inductive ClosReflTrans : A -> A -> Prop :=
   | ClosReflTrans_refl : forall a, ClosReflTrans a a
   | ClosReflTrans_trans : forall a a' a'',
       R' a a' ->
       ClosReflTrans a' a'' ->
       ClosReflTrans a a''.

 Unset Implicit Arguments.

End TRANS.

Open Scope type_scope.

Module Type DEX_BIGSTEP.

 Declare Module DEX_Dom : DEX_SEMANTIC_DOMAIN.

 Load "DEX_BigStepLoad.v".

  Parameter IntraStepStar_ind :
   forall (p:DEX_Program)
    (P : DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState + DEX_ReturnState -> Prop),
      (forall m s, P m s (inl _ s)) ->
      (forall m s r, DEX_exec_return p m s r -> P m s (inr _ r)) ->
      (forall m s s' , DEX_exec_intra p m s s' ->
         forall r, DEX_IntraStepStar p m s' r -> P m s' r ->
         P m s r) ->
(* DEX Method
      (forall m s s' ret m' r,
         DEX_exec_call p m s ret m' s' (inr _ r) ->
         DEX_IntraStepStar p m' s' (inr _ ret) ->
         P m' s' (inr _ ret) ->
         P m s (inr _ r)) ->
      (forall m s s' ret m' s'' r,
         DEX_exec_call p m s ret m' s' (inl _ s'') ->
         DEX_IntraStepStar p m' s' (inr _ ret) -> P m' s' (inr _ ret) ->
         DEX_IntraStepStar p m s'' r -> P m s'' r ->
         P m s r) ->
*)
   forall m s r, DEX_IntraStepStar p m s r -> P m s r.

  Parameter IntraStepStar_intra_ind :
   forall (p:DEX_Program)
    (P : DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState -> Prop),
      (forall m s, P m s s) ->
      (forall m s s', DEX_exec_intra p m s s' ->
         forall s'', DEX_IntraStepStar_intra p m s' s'' -> P m s' s'' ->
         P m s s'') ->
(* DEX Method
      (forall m s s1 ret m' s2 s3,
         DEX_exec_call p m s ret m' s1 (inl _ s2) ->
         DEX_BigStep p m' s1 ret ->
         DEX_IntraStepStar_intra p m s2 s3 -> P m s2 s3 ->
         P m s s3) ->
*)
   forall m s s', DEX_IntraStepStar_intra p m s s' -> P m s s'.

  Parameter BigStep_ind :
   forall (p:DEX_Program)
    (P : DEX_Method -> DEX_IntraNormalState -> DEX_ReturnState -> Prop),
      (forall m s r, DEX_exec_return p m s r -> P m s r) ->
      (forall m s s' , DEX_exec_intra p m s s' ->
         forall r, DEX_BigStep p m s' r -> P m s' r ->
         P m s r) ->
(* DEX Method
      (forall m s s' ret m' r,
         DEX_exec_call p m s ret m' s' (inr _ r) ->
         DEX_BigStep p m' s' ret ->
         P m' s' ret ->
         P m s r) ->
      (forall m s s' ret m' s'' r,
         DEX_exec_call p m s ret m' s' (inl _ s'') ->
         DEX_BigStep p m' s' ret -> P m' s' ret ->
         DEX_BigStep p m s'' r -> P m s'' r ->
         P m s r) ->
*)
   forall m s r, DEX_BigStep p m s r -> P m s r.

  Parameter ReachableStar_ind :
   forall (p:DEX_Program)
    (P : (DEX_Method * DEX_IntraNormalState) -> (DEX_Method * DEX_IntraNormalState) -> Prop),
      (forall m s, P (m,s) (m,s)) ->
      (forall m s s', DEX_exec_intra p m s s' ->
         forall m' s'', ClosReflTrans (DEX_ReachableStep p) (m,s') (m',s'') ->
         P (m,s') (m',s'') ->
         P (m,s) (m',s'')) ->
(* DEX Method
      (forall m s s1 ret m' s2,
         DEX_exec_call p m s ret m' s1 (inl _ s2) ->
         DEX_BigStep p m' s1 ret ->
         forall m' s3, ClosReflTrans (DEX_ReachableStep p) (m,s2) (m',s3) ->
         P (m,s2) (m',s3) ->
         P (m,s) (m',s3)) ->
      (forall m pc h l m' l' bm',
       DEX_CallStep p m (pc,(h, l)) (m', l') ->
       DEX_METHOD.body m' = Some bm' ->
       forall m'' s'',
       ClosReflTrans (DEX_ReachableStep p)
         (m', (DEX_BYTECODEMETHOD.firstAddress bm',(h, l')))
         (m'',s'') ->
       P (m', (DEX_BYTECODEMETHOD.firstAddress bm',(h, l')))
         (m'',s'') ->
       P (m, (pc,(h, l))) (m'',s'')) ->
*)
   forall ms ms',
      ClosReflTrans (DEX_ReachableStep p) ms ms' -> P ms ms'.

End DEX_BIGSTEP.


Require Export ZArith.
Require Export String.
Require Export List.

Open Scope string_scope.
Open Scope Z_scope.

Import ListNotations.

(**************************************************************)
(** Solidity address *)

Definition address := string.
Definition address_payable := address.

Definition Default_Address := "0x0".

(*
 *
TODO Consider better separation for address i.e.:

Inductive address :=
| AddrId : string -> address
| Address : string -> address
| Address_Payable : string -> address
| Msg_Sender -> address
.

Definition get_contract_by_id (mapping : id_state_mapping) (c_id : string) : ContractState := id_state_mapping c_id.

Definition contract_id_2_addr (c_id : string) : address := c_address (get_contract_by_id c_id).

*)

(**************************************************************)
(** Integers *)

Inductive aexp :=
| Int : Z -> aexp
| AId : string -> aexp
| Plus : aexp -> aexp -> aexp
| Sub : aexp -> aexp -> aexp
| Mul : aexp -> aexp -> aexp
| Div : aexp -> aexp -> aexp
| Rem : aexp -> aexp -> aexp
| BalanceOf : address -> aexp
| Msg_Value : aexp.

Definition Default_Aexp := Int 0.

(**************************************************************)
(** Bool *)

Inductive bexp :=
| Boolean : bool -> bexp
| BId : string -> bexp
| Aexp_Lt : aexp -> aexp -> bexp
| Aexp_Leq : aexp -> aexp -> bexp
| Aexp_Eq : aexp -> aexp -> bexp
| Aexp_Neq : aexp -> aexp -> bexp
| Aexp_Geq : aexp -> aexp -> bexp
| Aexp_Gt : aexp -> aexp -> bexp
| Not : bexp -> bexp
| And : bexp -> bexp -> bexp
| Or : bexp -> bexp -> bexp.

Definition Default_Bexp := Boolean false.

(** Message *)

Record msg :=
mkMsg {
value : Z;
sender : address_payable
}.

Definition Default_Msg_Value := 0.

Definition Default_Msg := {| value := Default_Msg_Value;
                             sender := Default_Address |}.

(**************************************************************)
(** Statements *)

Inductive instr :=
| Declare_Aexp : string -> instr
| Declare_Bexp : string -> instr

| Define_Aexp : (string * aexp) -> instr
| Define_Bexp : (string * bexp) -> instr

| Assign_Aexp : aexp -> aexp -> instr
| Assign_Bexp : bexp -> bexp -> instr

| IfThenElse : bexp -> list instr -> list instr -> instr
| While : bexp -> list instr -> instr
| Skip : instr

(* no params, no return value, with value setter *)
(* example: "this" "f" Some Int value *)
| Function_Call : option address -> string -> option aexp -> instr
| Transfer : address_payable -> aexp -> instr (* | Transfer : address -> aexp -> instr *)

| Revert : option string -> instr
| Require : bexp -> option string -> instr.

Inductive contract_part :=
| Define_Function : string -> list instr -> contract_part

| Declare_Aexp_Field : string -> contract_part
| Declare_Bexp_Field : string -> contract_part

| Define_Aexp_Field : (string * aexp) -> contract_part
| Define_Bexp_Field : (string * bexp) -> contract_part.

Definition contract_parts := list contract_part.

(**************************************************************)
(** * Environments *)

Definition Env T1 T2 := T1 -> option T2.

(** aexp *)

Definition Aexp_Vars := Env string Z.

(* Record aexp_env :=
mk_aexp_env {
aexp_vars : Aexp_Env;

}. *)

Definition Empty_Aexp_Vars : Aexp_Vars := fun x => None.

Definition update_aexp_vars (env : Aexp_Vars) (var : option string) (val : option Z) : Aexp_Vars :=
  fun x => match var with
  | Some str => if (string_dec x str) then val
                else (env x)
  | _ => None
  end.

(** bexp *)

Definition Bexp_Vars := Env string bool.
Definition Empty_Bexp_Vars : Bexp_Vars := fun x => None.

Definition update_bexp_vars (env : Bexp_Vars) (var : option string) (val : option bool) : Bexp_Vars :=
  fun x => match var with
  | Some str => if (string_dec x str) then val
                else (env x)
  | _ => None
  end.

(** contract functions *)

Definition Code := list instr.

Inductive function_body :=
| Body : Code -> function_body
| EmptyBody : function_body.

Definition Functions := Env string function_body.
Definition Empty_Functions : Functions := fun x => None.

Definition define_function (env : Functions) (name : string) (body : function_body) : Functions :=
  fun x => if (string_dec x name) then Some body
  else (env x).

Definition get_function_code (opt_body : option function_body) : Code :=
  match opt_body with
  | Some (Body code) => code
  | _ => nil
  end.

(** balances *)

Definition Address2Balance := Env address Z.
Definition Empty_Address2Balance : Address2Balance := fun a => None.
Definition Default_Balance := 0.

Definition update_balance (map : Address2Balance) (addr : address) (amount : Z) : Address2Balance :=
fun a' => if string_dec addr a' then Some amount else map a'.

(** function locals *)

Record FunctionState :=
mkFunctionState {
 aexp_locals : Aexp_Vars;
 bexp_locals : Bexp_Vars;
 next_code : Code;
 msg_data : msg
}.

Definition Empty_FunctionState := {| aexp_locals := Empty_Aexp_Vars;
                                bexp_locals := Empty_Bexp_Vars;
                                next_code := [];
                                msg_data := Default_Msg |}.

Definition update_function_aexp_locals :=
fun (fstate : FunctionState) (new_env : Aexp_Vars) => mkFunctionState new_env (bexp_locals fstate) (next_code fstate) (msg_data fstate).

Definition update_function_bexp_locals :=
fun (fstate : FunctionState) (new_env : Bexp_Vars) => mkFunctionState (aexp_locals fstate) new_env (next_code fstate) (msg_data fstate).

Definition update_function_next_code :=
fun (fstate : FunctionState) (new_next_code : Code) => mkFunctionState (aexp_locals fstate) (bexp_locals fstate) new_next_code (msg_data fstate).

Definition update_function_msg_data :=
fun (fstate : FunctionState) (new_msg : msg) => mkFunctionState (aexp_locals fstate) (bexp_locals fstate) (next_code fstate) new_msg.

Inductive contract :=
| CId (ident : string)
| Ctor (name : string) (* new Test() <=> Ctor "Test" *).

(** Contract state *)

(**
  * Introducing contract type.

 Definition Contract_Vars := string -> ContractState.

Definition Empty_Contract_Vars : Contract_Vars := fun x => Default_ContractState.

Definition updateContract_Vars (env : Contract_Vars) (name : string) (state : ContractState) : Contract_Vars :=
  fun x => if (string_dec x name) then state
  else (env x).

Inductive Contract_Vars :=
| contract_vars : string -> ContractState ->
with ContractState :=
| ctor (c_address : address) (fn_env : Functions_Env)
       (aexp_vars : Aexp_Env) (bexp_vars : Bexp_Env) (contract_vars : Contract_Vars)
.
 *)

Record ContractState :=
mkContractState {
 c_address : address;
 functions : Functions;
 aexp_fields : Aexp_Vars;
 bexp_fields : Bexp_Vars
(*  contract_vars : Contract_Vars *)
}.

Definition update_contract_aexp_vars :=
fun (cstate : ContractState) (new_env : Aexp_Vars)
 => mkContractState (c_address cstate) (functions cstate) new_env (bexp_fields cstate).

Definition update_contract_bexp_vars :=
fun (cstate : ContractState) (new_env : Bexp_Vars)
 => mkContractState (c_address cstate) (functions cstate) (aexp_fields cstate) new_env.

Definition update_contract_functions :=
fun (cstate : ContractState) (new_env : Functions)
 => mkContractState (c_address cstate) new_env (aexp_fields cstate) (bexp_fields cstate).

(* TODO: consider function, contract states as Inductive types, use simple label for default state instead
of initializers *)

Definition Default_ContractState := {| c_address := Default_Address;
                                       functions := Empty_Functions;
                                       aexp_fields := Empty_Aexp_Vars;
                                       bexp_fields := Empty_Bexp_Vars |}.

(**************************************************************)
(** Contracts Env *)

Definition Address2ContractState := address -> ContractState.
Definition Empty_Address2ContractState : Address2ContractState := fun x => Default_ContractState.

Definition get_calling_contract (opt_addr : option address) (env : Address2ContractState) (current_contract : ContractState) :=
match opt_addr with
| Some v => env v
| _ => current_contract
end.

Definition update_contract_state  (env : Address2ContractState) (addr : address) (state : ContractState) : Address2ContractState :=
  fun x => if (string_dec x addr) then state
           else (env x).

(**************************************************************)
(** More unfold/unpack helpers *)

(* * More generic *)
(*
Definition unfold_option {T1} {T2} (opt : option T1) (default : T2) (t1_to_t2 : T1 -> T2) : T2 :=
match opt with
| Some t1 => t1_to_t2 t1
| _ => default
end.
*)

Definition unfold_option {T} (opt : option T) (default : T) : T :=
match opt with
| Some v => v
| _ => default
end.

Definition unfold_option_z := fun opt => unfold_option opt 0.
Definition unfold_option_bool := fun opt => unfold_option opt false.

Definition unfold_aexp_literal (e : aexp) : option Z :=
match e with
| Int v => Some v
| _ => None
end.

Definition unfold_bexp_literal (e : bexp) : option bool :=
match e with
| Boolean v => Some v
| _ => None
end.

Definition unfold_aexp_id (e : aexp) : option string :=
match e with
| AId s => Some s
| _ => None
end.

Definition unfold_bexp_id (e : bexp) : option string :=
match e with
| BId s => Some s
| _ => None
end.

(**************************************************************)
(** Declaration helpers *)

Definition declare_aexp (env : Aexp_Vars) (name : string) : Aexp_Vars :=
fun x => if (string_dec x name) then unfold_aexp_literal Default_Aexp
         else env x.

(** [TEST] declareAexp *)

Let env := update_aexp_vars Empty_Aexp_Vars (Some "x") (Some 1).
Compute (declare_aexp env "y") "x".

(***************************)

Definition define_aexp (env : Aexp_Vars) (def : string * aexp) : Aexp_Vars :=
fun x => match def with
| (id, Int v) => if (string_dec x id) then Some v
                 else env x
| (_, _) => env x
end.

(** [TEST] defineAexp *)

Let env1 := update_aexp_vars Empty_Aexp_Vars (Some "x") (Some 1).
Compute (define_aexp env1 ("z", Int 33)) "z".
Compute (define_aexp env1 ("z", AId "x")) "z".

(***************************)

Definition declare_bexp (env : Bexp_Vars) (name : string) : Bexp_Vars :=
fun x => if (string_dec x name) then unfold_bexp_literal Default_Bexp
         else env x.

Definition define_bexp (env : Bexp_Vars) (def : string * bexp) : Bexp_Vars :=
fun x => match def with
| (id, Boolean v) => if (string_dec x id) then Some v
                 else env x
| (_, _) => env x
end.

(**************************************************************)
(** * Evaluation of expressions *)

(** aexp *)

Record aexp_eval_context :=
mk_aexp_eval_context {
vars : Aexp_Vars;
balances : Address2Balance;
msg_value : Z
}.

Definition get_aexp_eval_context (fstate : FunctionState) (bm : Address2Balance) :=
mk_aexp_eval_context (aexp_locals fstate) bm (value (msg_data fstate)).

Fixpoint eval_aexp (context : aexp_eval_context) (a : aexp) : option Z :=
  match a with
  | Int z => Some z
  | AId x => (vars context) x

  | BalanceOf x => (balances context) x
  | Msg_Value => Some (msg_value context)

  | Plus a1 a2 => match (eval_aexp context a1), (eval_aexp context a2) with
                  | Some v1, Some v2 => Some (Z.add v1 v2)
                  | _, _ => None
                  end
  | Sub a1 a2 => match (eval_aexp context a1), (eval_aexp context a2) with
                  | Some v1, Some v2 => Some (Z.sub v1 v2)
                  | _, _ => None
                  end
  | Mul a1 a2 => match (eval_aexp context a1), (eval_aexp context a2) with
                  | Some v1, Some v2 => Some (Z.mul v1 v2)
                  | _, _ => None
                  end
  | Div a1 a2 => match (eval_aexp context a1), (eval_aexp context a2) with
                 | Some v1, Some v2 => if (Z.eqb 0 v2) then None else Some (Z.div v1 v2)
                 | _, _ => None
                 end
  | Rem a1 a2 => match (eval_aexp context a1), (eval_aexp context a2) with
                 | Some v1, Some v2 => if (Z.eqb 0 v2) then None else Some (Z.rem v1 v2)
                 | _, _ => None
                 end
  end.

Definition unfold_opt_aexp (opt_aexp : option aexp) (context : aexp_eval_context) : option Z :=
match opt_aexp with
| Some v => eval_aexp context v
| _ => None
end.

(* TODO: Fix after updates *)
(** * Some proof examples *)

(* Example mixed_aexp_ops:
  eval_aexp Empty_Aexp_Env Empty_BalanceEnv (Plus (Int 1) (Div (Int 4) (Int 2))) = Some 3.
Proof.
  reflexivity.
Qed.

Example unknown_id_evals_none:
  eval_aexp Empty_Aexp_Env Empty_BalanceEnv (AId "a") = None.
Proof.
  reflexivity.
Qed.

Example zero_division:
  eval_aexp Empty_Aexp_Env Empty_BalanceEnv (Div (Int 1) (Int 0)) = None.
Proof.
  reflexivity.
Qed.

Example zero_division_remainder:
  eval_aexp Empty_Aexp_Env Empty_BalanceEnv (Rem (Int 1) (Int 0)) = None.
Proof.
  reflexivity.
Qed. *)

(** bexp *)

Fixpoint eval_bexp (aexp_context : aexp_eval_context) (bexp_context : Bexp_Vars) (b : bexp) : option bool :=
  match b with
  | Boolean b' => Some b'
  | BId x => bexp_context x
  | Aexp_Lt a1 a2 => match (eval_aexp aexp_context a1), (eval_aexp aexp_context a2) with
                    | Some v1, Some v2 => Some (Z.ltb v1 v2)
                    | _, _ => None
                    end
  | Aexp_Leq a1 a2 => match (eval_aexp aexp_context a1), (eval_aexp aexp_context a2) with
                    | Some v1, Some v2 => Some (Z.leb v1 v2)
                    | _, _ => None
                    end
  | Aexp_Eq a1 a2 => match (eval_aexp aexp_context a1), (eval_aexp aexp_context a2) with
                    | Some v1, Some v2 => Some (Z.eqb v1 v2)
                    | _, _ => None
                    end
  | Aexp_Neq a1 a2 => match (eval_aexp aexp_context a1), (eval_aexp aexp_context a2) with
                    | Some v1, Some v2 => Some (Zneq_bool v1 v2)
                    | _, _ => None
                    end
  | Aexp_Geq a1 a2 => match (eval_aexp aexp_context a1), (eval_aexp aexp_context a2) with
                    | Some v1, Some v2 => Some (Z.geb v1 v2)
                    | _, _ => None
                     end
  | Aexp_Gt a1 a2 => match (eval_aexp aexp_context a1), (eval_aexp aexp_context a2) with
                    | Some v1, Some v2 => Some (Z.gtb v1 v2)
                    | _, _ => None
                    end
  | Not b' => match (eval_bexp aexp_context bexp_context b') with
              | Some b'' => Some (negb b'')
              | _ => None
              end
  | And b1 b2 => match (eval_bexp aexp_context bexp_context b1), (eval_bexp aexp_context bexp_context b2) with
                 | Some b1', Some b2' => Some (andb b1' b2')
                 | _, _ => None
                 end
  | Or b1 b2 => match (eval_bexp aexp_context bexp_context b1), (eval_bexp aexp_context bexp_context b2) with
                 | Some b1', Some b2' => Some (orb b1' b2')
                 | _, _ => None
                 end
  end.


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

Require Import String.
Require Import List.
Require Import Arith.
Require Import Program.
Require Import EquivDec.
Require Import Morphisms.
Require Import Utils.
Require Import DataSystem.
Require Import cNNRC.
Require Import TcNNRC.

Section TcNNRCInfer.
  Context {m:basic_model}.
  Context (τconstants:tbindings).

  (** Type inference for NNRC when given the type of the environment *)

  Fixpoint infer_nnrc_core_type (tenv:tbindings) (n:nnrc) {struct n} : option rtype :=
    match n with
    | NNRCGetConstant v =>
      tdot τconstants v
    | NNRCVar v =>
      lookup equiv_dec tenv v
    | NNRCConst d => infer_data_type (normalize_data brand_relation_brands d)
    | NNRCBinop b n1 n2 =>
      let binf (τ₁ τ₂:rtype) := infer_binary_op_type b τ₁ τ₂ in
      olift2 binf (infer_nnrc_core_type tenv n1) (infer_nnrc_core_type tenv n2)
    | NNRCUnop u n1 =>
        let unf (τ₁:rtype) := infer_unary_op_type u τ₁ in
        olift unf (infer_nnrc_core_type tenv n1)
    | NNRCLet v n1 n2 =>
      let τ₁ := infer_nnrc_core_type tenv n1 in
      let let_infer τ := infer_nnrc_core_type ((v,τ)::tenv) n2 in
      olift let_infer τ₁
    | NNRCFor v n1 n2 =>
      let τ₁ := infer_nnrc_core_type tenv n1 in
      let for_infer τ := lift Coll (infer_nnrc_core_type ((v,τ)::tenv) n2) in
      olift for_infer (olift tuncoll τ₁)
    | NNRCIf n0 n1 n2 =>
      match infer_nnrc_core_type tenv n0 with
      | Some τ₀ =>
        match `τ₀ with
        | Bool₀ =>
          let oτ₁ := infer_nnrc_core_type tenv n1 in
          let oτ₂ := infer_nnrc_core_type tenv n2 in
          match (oτ₁, oτ₂) with
            | (Some τ₁, Some τ₂) =>
              if (rtype_eq_dec τ₁ τ₂) (* Probably should be generalized using join... *)
              then Some τ₁
              else None
            | (_, _) => None
          end
        | _ => None
        end
      | None => None
      end
    | NNRCEither n0 v1 n1 v2 n2 =>
      match olift tuneither (infer_nnrc_core_type tenv n0) with
      | Some (τl, τr) =>
          let oτ₁ := infer_nnrc_core_type ((v1,τl)::tenv) n1 in
          let oτ₂ := infer_nnrc_core_type ((v2,τr)::tenv) n2 in
          match (oτ₁, oτ₂) with
            | (Some τ₁, Some τ₂) =>
              if (rtype_eq_dec τ₁ τ₂) (* Probably should be generalized using join... *)
              then Some τ₁
              else None
            | (_, _) => None
          end
      | _ => None
      end
    | NNRCGroupBy g sl n1 =>
      None (* For core, always fails *)
    end.

  Lemma infer_nnrc_core_type_correct {τout} (tenv:tbindings) (n:nnrc) :
    infer_nnrc_core_type tenv n = Some τout ->
    nnrc_core_type τconstants tenv n τout.
  Proof.
    revert tenv τout.
    nnrc_cases (induction n) Case; intros; simpl in *.
    - Case "NNRCGetConstant"%string.
      apply type_cNNRCGetConstant; assumption.
    - Case "NNRCVar"%string.
      apply type_cNNRCVar; assumption.
    - Case "NNRCConst"%string.
      apply type_cNNRCConst.
      apply infer_data_type_correct. assumption.
    - Case "NNRCBinop"%string.
      specialize (IHn1 tenv); specialize (IHn2 tenv).
      destruct (infer_nnrc_core_type tenv n1); destruct (infer_nnrc_core_type tenv n2); simpl in *;
      try discriminate.
      specialize (IHn1 r eq_refl); specialize (IHn2 r0 eq_refl).
      apply (@type_cNNRCBinop m τconstants r r0 τout tenv); try assumption.
      apply infer_binary_op_type_correct; assumption.
    - Case "NNRCUnop"%string.
      specialize (IHn tenv).
      destruct (infer_nnrc_core_type tenv n); simpl in *;
      try discriminate.
      specialize (IHn r eq_refl).
      apply (@type_cNNRCUnop m τconstants r τout tenv); try assumption.
      apply infer_unary_op_type_correct; assumption.
    - Case "NNRCLet"%string.
      specialize (IHn1 tenv).
      destruct (infer_nnrc_core_type tenv n1); simpl in *; try discriminate.
      specialize (IHn2 ((v,r) :: tenv)).
      destruct (infer_nnrc_core_type ((v, r) :: tenv) n2); simpl in *; try discriminate.
      inversion H; subst; clear H.
      specialize (IHn1 r eq_refl).
      specialize (IHn2 τout eq_refl).
      apply (type_cNNRCLet τconstants v tenv n1 n2 IHn1 IHn2).
    - Case "NNRCFor"%string.
      specialize (IHn1 tenv).
      destruct (infer_nnrc_core_type tenv n1); simpl in *; try discriminate.
      case_eq (tuncoll r); intros; rewrite H0 in *; simpl in H.
      + apply tuncoll_correct in H0.
        specialize (IHn2 ((v,r0) :: tenv)).
        destruct (infer_nnrc_core_type ((v, r0) :: tenv) n2); simpl in *; try discriminate.
        inversion H; subst; clear H.
        specialize (IHn1 (Coll r0) eq_refl).
        specialize (IHn2 r1 eq_refl).
        apply (type_cNNRCFor τconstants v tenv n1 n2 IHn1 IHn2).
      + discriminate.
    - Case "NNRCIf"%string.
      specialize (IHn1 tenv).
      specialize (IHn2 tenv).
      specialize (IHn3 tenv).
      destruct (infer_nnrc_core_type tenv n1); simpl in *; try discriminate.
      destruct r; try congruence; simpl in H.
      destruct x; try congruence; simpl in H.
      destruct (infer_nnrc_core_type tenv n2); simpl in *; try discriminate.
      destruct (infer_nnrc_core_type tenv n3); simpl in *; try discriminate.
      destruct (rtype_eq_dec r r0); simpl in *; try congruence.
      rewrite e0 in *; clear e0.
      inversion H; clear H; subst.
      assert (exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true) Bool₀ e = Bool) by (apply rtype_fequal; reflexivity).
      rewrite H in IHn1; clear H.
      specialize (IHn1 Bool eq_refl).
      specialize (IHn2 τout eq_refl).
      specialize (IHn3 τout eq_refl).
      apply type_cNNRCIf; assumption.
    - Case "NNRCEither"%string.
      specialize (IHn1 tenv).
      destruct (infer_nnrc_core_type tenv n1); simpl in *; try discriminate.
      unfold tuneither in H.
      destruct r; simpl in H; try discriminate.
      destruct x; simpl in H; try discriminate.
      match_case_in H; intros; rewrite H0 in H; try discriminate.
      match_case_in H; intros; rewrite H1 in H; try discriminate.
      match_destr_in H.
      red in e0.
      invcs H; subst.
      specialize (IHn1 (exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true)
                              (Either₀ x1 x2) e) eq_refl).
      specialize (IHn2 _ _ H0).
      specialize (IHn3 _ _ H1).
      eapply type_cNNRCEither; eauto.
      erewrite <- Either_canon; eauto.
    - Case "NNRCGroupBy"%string.
      congruence. (* Type checking always fails for groupby in core NNRC *)
  Qed.

End TcNNRCInfer.