Require Import prosa.model.priority.edf.
Require Export prosa.analysis.facts.model.rbf.
Require Export prosa.analysis.facts.model.sequential.
Require Export prosa.results.edf.rta.bounded_pi.
Require Export prosa.analysis.facts.busy_interval.priority_inversion.

(** Throughout this file, we assume ideal uni-processor schedules. *)
Require Import prosa.model.processor.ideal.

(** Throughout this file, we assume the basic (i.e., Liu & Layland) readiness model. *)
Require Import prosa.model.readiness.basic.

(** * RTA for EDF  with Bounded Non-Preemptive Segments *)

(** In this section we instantiate the Abstract RTA for EDF-schedulers
    with Bounded Priority Inversion to EDF-schedulers for ideal
    uni-processor model of real-time tasks with arbitrary
    arrival models _and_ bounded non-preemptive segments. *)

(** Recall that Abstract RTA for EDF-schedulers with Bounded Priority
    Inversion does not specify the cause of priority inversion. In
    this section, we prove that the priority inversion caused by
    execution of non-preemptive segments is bounded. Thus the Abstract
    RTA for EDF-schedulers is applicable to this instantiation. *)
Section RTAforEDFwithBoundedNonpreemptiveSegmentsWithArrivalCurves.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.
  Context `{TaskDeadline Task}.
  Context `{TaskRunToCompletionThreshold Task}.
  Context `{TaskMaxNonpreemptiveSegment Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** For clarity, let's denote the relative deadline of a task as D. *)
  Let D tsk := task_deadline tsk.

  (** Consider the EDF policy that indicates a higher-or-equal priority relation.
     Note that we do not relate the EDF policy with the scheduler. However, we
     define functions for Interference and Interfering Workload that actively use
     the concept of priorities. *)
  Let EDF := EDF Job.

  (** Consider any arrival sequence with consistent, non-duplicate arrivals. *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.
  Hypothesis H_arr_seq_is_a_set : arrival_sequence_uniq arr_seq.

  (** Next, consider any ideal uni-processor schedule of this arrival sequence ... *)
  Variable sched : schedule (ideal.processor_state Job).
  Hypothesis H_jobs_come_from_arrival_sequence:
    jobs_come_from_arrival_sequence sched arr_seq.

  (** ... where jobs do not execute before their arrival or after completion. *)
  Hypothesis H_jobs_must_arrive_to_execute : jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute : completed_jobs_dont_execute sched.

  (** In addition, we assume the existence of a function mapping jobs
      to theirs preemption points ... *)
  Context `{JobPreemptable Job}.

  (** ... and assume that it defines a valid preemption
     model with bounded non-preemptive segments. *)
  Hypothesis H_valid_model_with_bounded_nonpreemptive_segments:
    valid_model_with_bounded_nonpreemptive_segments
      arr_seq sched.

  (** Assume we have sequential tasks, i.e, jobs from the
     same task execute in the order of their arrival. *)
  Hypothesis H_sequential_tasks : sequential_tasks sched.

  (** Next, we assume that the schedule is a work-conserving schedule... *)
  Hypothesis H_work_conserving : work_conserving arr_seq sched.

  (** ... and the schedule respects the policy defined by the [job_preemptable]
     function (i.e., jobs have bounded non-preemptive segments). *)
  Hypothesis H_respects_policy : respects_policy_at_preemption_point arr_seq sched.

  (** Consider an arbitrary task set ts, ... *)
  Variable ts : list Task.

  (** ... assume that all jobs come from the task set, ... *)
  Hypothesis H_all_jobs_from_taskset : all_jobs_from_taskset arr_seq ts.

  (** ... and the cost of a job cannot be larger than the task cost. *)
  Hypothesis H_valid_job_cost:
    arrivals_have_valid_job_costs arr_seq.

  (** Let max_arrivals be a family of valid arrival curves, i.e., for
     any task [tsk] in ts [max_arrival tsk] is (1) an arrival bound of
     [tsk], and (2) it is a monotonic function that equals 0 for the
     empty interval delta = 0. *)
  Context `{MaxArrivals Task}.
  Hypothesis H_valid_arrival_curve : valid_taskset_arrival_curve ts max_arrivals.
  Hypothesis H_is_arrival_curve : taskset_respects_max_arrivals arr_seq ts.

  (** Let [tsk] be any task in ts that is to be analyzed. *)
  Variable tsk : Task.
  Hypothesis H_tsk_in_ts : tsk \in ts.

  (** Consider a valid preemption model... *)
  Hypothesis H_valid_preemption_model:
    valid_preemption_model arr_seq sched.

  (** ...and a valid task run-to-completion threshold function. That is,
     [task_run_to_completion_threshold tsk] is (1) no bigger than [tsk]'s
     cost, (2) for any job of task [tsk] job_run_to_completion_threshold
     is bounded by task_run_to_completion_threshold. *)
  Hypothesis H_valid_run_to_completion_threshold:
    valid_task_run_to_completion_threshold arr_seq tsk.

  (** We introduce as an abbreviation [rbf] for the task request bound function,
     which is defined as [task_cost(T) × max_arrivals(T,Δ)] for a task T. *)
  Let rbf := task_request_bound_function.

  (** Next, we introduce [task_rbf] as an abbreviation for the task
     request bound function of task [tsk]. *)
  Let task_rbf := rbf tsk.

  (** Using the sum of individual request bound functions, we define the request bound
     function of all tasks (total request bound function). *)
  Let total_rbf := total_request_bound_function ts.

  (** Next, we define an upper bound on interfering workload received from jobs
     of other tasks with higher-than-or-equal priority. *)
  Let bound_on_total_hep_workload  A Δ :=
    \sum_(tsk_o <- ts | tsk_o != tsk)
     rbf tsk_o (minn ((A + ε) + D tsk - D tsk_o) Δ).

  (** Let's define some local names for clarity. *)
  Let max_length_of_priority_inversion :=
    max_length_of_priority_inversion arr_seq.
  Let task_rbf_changes_at A := task_rbf_changes_at tsk A.
  Let bound_on_total_hep_workload_changes_at :=
    bound_on_total_hep_workload_changes_at ts tsk.
  Let response_time_bounded_by := task_response_time_bound arr_seq sched.
  Let is_in_search_space := is_in_search_space ts tsk.

  (** We also define a bound for the priority inversion caused by jobs with lower priority. *)
  Definition blocking_bound :=
    \max_(tsk_o <- ts | (tsk_o != tsk) && (D tsk < D tsk_o))
     (task_max_nonpreemptive_segment tsk_o - ε).

  (** ** Priority inversion is bounded *)
  (** In this section, we prove that a priority inversion for task [tsk] is bounded by
      the maximum length of non-preemptive segments among the tasks with lower priority. *)
  Section PriorityInversionIsBounded.

    (** First, we prove that the maximum length of a priority
        inversion of job j is bounded by the maximum length of a
        non-preemptive section of a task with lower-priority task
        (i.e., the blocking term). *)
    Lemma priority_inversion_is_bounded_by_blocking:
      forall j t,
        arrives_in arr_seq j ->
        job_task j = tsk ->
        t <= job_arrival j ->
        max_length_of_priority_inversion j t <= blocking_bound.
    Proof.
      intros j t ARR TSK LE; unfold max_length_of_priority_inversion, blocking_bound.
      apply leq_trans with
          (\max_(j_lp <- arrivals_between arr_seq 0 t | ~~ EDF j_lp j)
            (task_max_nonpreemptive_segment (job_task j_lp) - ε)).
      - apply leq_big_max.
        intros j' JINB NOTHEP.
        rewrite leq_sub2r //.
        apply in_arrivals_implies_arrived in JINB.
          by apply H_valid_model_with_bounded_nonpreemptive_segments.
      - apply /bigmax_leq_seqP.
        intros j' JINB NOTHEP.
        apply leq_bigmax_cond_seq with (i0 := (job_task j')) (F := fun tsk => task_max_nonpreemptive_segment tsk - 1).
        { apply H_all_jobs_from_taskset.
          apply mem_bigcat_nat_exists in JINB.
            by inversion JINB as [ta' [JIN' _]]; exists ta'. }
        { have NINTSK: job_task j' != tsk.
          { apply/eqP; intros TSKj'.
            rewrite /EDF -ltnNge in NOTHEP.
            rewrite /job_deadline /absolute_deadline.job_deadline_from_task_deadline in NOTHEP.
            rewrite TSKj' TSK ltn_add2r in NOTHEP.
            move: NOTHEP; rewrite ltnNge; move => /negP T; apply: T.
            apply leq_trans with t; last by done.
            eapply in_arrivals_implies_arrived_between in JINB; last by eauto 2.
            move: JINB; move => /andP [_ T].
              by apply ltnW.
          }
          apply/andP; split; first by done.
          rewrite /EDF -ltnNge in NOTHEP.
          rewrite -TSK.
          have ARRLE: job_arrival j' < job_arrival j.
          { apply leq_trans with t; last by done.
            eapply in_arrivals_implies_arrived_between in JINB; last by eauto 2.
              by move: JINB; move => /andP [_ T].
          }
          rewrite /job_deadline /absolute_deadline.job_deadline_from_task_deadline in NOTHEP.
          rewrite /D; ssromega.
        }
    Qed.

    (** Using the lemma above, we prove that the priority inversion of the task is bounded by
       the maximum length of a nonpreemptive section of lower-priority tasks. *)
    Lemma priority_inversion_is_bounded:
      priority_inversion_is_bounded_by arr_seq sched tsk blocking_bound.
    Proof.
      move => j ARR TSK POS t1 t2 PREF; move: (PREF) => [_ [_ [_ /andP [T _]]]].
      destruct (leqP (t2 - t1) blocking_bound) as [NEQ|NEQ].
      { apply leq_trans with (t2 - t1); last by done.
        rewrite /cumulative_priority_inversion /is_priority_inversion.
        rewrite -[X in _ <= X]addn0 -[t2 - t1]mul1n -iter_addn -big_const_nat.
        rewrite leq_sum //.
        intros t _; case: (sched t); last by done.
          by intros s; destruct (hep_job s j).
      }
      edestruct @preemption_time_exists as [ppt [PPT NEQ2]]; eauto 2 with basic_facts.
      move: NEQ2 => /andP [GE LE].
      apply leq_trans with (cumulative_priority_inversion sched j t1 ppt);
        last apply leq_trans with (ppt - t1).
      - rewrite /cumulative_priority_inversion /is_priority_inversion.
        rewrite (@big_cat_nat _ _ _ ppt) //=; last first.
        { rewrite ltn_subRL in NEQ.
          apply leq_trans with (t1 + blocking_bound); last by apply ltnW.
          apply leq_trans with (t1 + max_length_of_priority_inversion j t1); first by done.
            by rewrite leq_add2l; eapply priority_inversion_is_bounded_by_blocking; eauto 2. }
        rewrite -[X in _ <= X]addn0 leq_add2l leqn0.
        rewrite big_nat_cond big1 //; move => t /andP [/andP [GEt LTt] _ ].
        case SCHED: (sched t) => [s | ]; last by done.
        edestruct @not_quiet_implies_exists_scheduled_hp_job
          with (K := ppt - t1) (t := t) as [j_hp [ARRB [HP SCHEDHP]]]; eauto 2 with basic_facts.
        { exists ppt; split.  by done.  by rewrite subnKC //; apply/andP; split. }
        { by rewrite subnKC //; apply/andP; split. }
        apply/eqP; rewrite eqb0 Bool.negb_involutive.
        enough (EQ : s = j_hp); first by subst.
        move: SCHED => /eqP SCHED; rewrite -scheduled_at_def in SCHED.
          by eapply ideal_proc_model_is_a_uniprocessor_model; [exact SCHED | exact SCHEDHP].
      - rewrite /cumulative_priority_inversion /is_priority_inversion.
        rewrite -[X in _ <= X]addn0 -[ppt - t1]mul1n -iter_addn -big_const_nat.
        rewrite leq_sum //.
        intros t _; case: (sched t); last by done.
          by intros s; destruct (hep_job s j).
      -  rewrite leq_subLR.
         apply leq_trans with (t1 + max_length_of_priority_inversion j t1); first by done.
           by rewrite leq_add2l; eapply priority_inversion_is_bounded_by_blocking; eauto 2.
    Qed.

  End PriorityInversionIsBounded.

  (** ** Response-Time Bound *)
  (** In this section, we prove that the maximum among the solutions of the response-time
      bound recurrence is a response-time bound for [tsk]. *)
  Section ResponseTimeBound.

    (** Let L be any positive fixed point of the busy interval recurrence. *)
    Variable L : duration.
    Hypothesis H_L_positive : L > 0.
    Hypothesis H_fixed_point : L = total_rbf L.

    (** Consider any value [R], and assume that for any given arrival
        offset [A] in the search space, there is a solution of the
        response-time bound recurrence which is bounded by [R]. *)
    Variable R : duration.
    Hypothesis H_R_is_maximum:
      forall (A : duration),
        is_in_search_space L A ->
        exists (F : duration),
          A + F = blocking_bound
                  + (task_rbf (A + ε) - (task_cost tsk - task_run_to_completion_threshold tsk))
                  + bound_on_total_hep_workload  A (A + F) /\
          F + (task_cost tsk - task_run_to_completion_threshold tsk) <= R.

    (** Then, using the results for the general RTA for EDF-schedulers, we establish a
         response-time bound for the more concrete model of bounded nonpreemptive segments.
         Note that in case of the general RTA for EDF-schedulers, we just _assume_ that
         the priority inversion is bounded. In this module we provide the preemption model
         with bounded nonpreemptive segments and _prove_ that the priority inversion is
         bounded. *)
    Theorem uniprocessor_response_time_bound_edf_with_bounded_nonpreemptive_segments:
      response_time_bounded_by tsk R.
    Proof.
      eapply uniprocessor_response_time_bound_edf; eauto 2.
        by apply priority_inversion_is_bounded.
    Qed.

  End ResponseTimeBound.

End RTAforEDFwithBoundedNonpreemptiveSegmentsWithArrivalCurves.


(**-- Simply Typed Lambda-Calculus Boolean Extensions --**)

(* I am using Coq 8.12.0. *)

(* ################################################################# *)
(** * Auxilaries *)

Set Warnings "-notation-overridden,-parsing".

Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Unicode.Utf8_core. (* to make most symbols easy to read *)

Open Scope string_scope.

(* Bool *)

Ltac destr_bool :=
 intros; destruct_all bool; simpl in *; trivial; try discriminate.

Lemma not_true_iff_false: ∀ b: bool,
  b ≠ true ↔ b = false.
Proof.
  destr_bool; intuition.
Qed.

(* String *)

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

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

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

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

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

(* Total maps *)

Definition total_map (A:Type) := string → A.

Definition t_empty {A:Type} (v : A) : total_map A :=
  (λ _, v).

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

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

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

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

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

Theorem t_update_neq : ∀ (X:Type) v x1 x2
                         (m : total_map X),
  x1 ≠ x2 →
  (m & {x1 ↦ v}) x2 = m x2.
Proof.
  intros X v x1 x2 m H. unfold t_update.
  apply beq_string_false_iff in H. rewrite H. reflexivity.
Qed.

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

Theorem t_update_same : ∀ X x (m : total_map X),
  m & { x ↦ m x } = m.
Proof.
  intros X x m. unfold t_update. apply functional_extensionality.
  intros y. destruct (beq_stringP x y) as [H | H].
  - rewrite H. reflexivity.
  - reflexivity.
Qed.

Theorem t_update_permute : ∀ (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 ≠ x1 →
  m & { x2 ↦ v2 ; x1 ↦ v1 }
  =  m & { x1 ↦ v1 ; x2 ↦ v2 }.
Proof.
  intros X v1 v2 x1 x2 m H1.
  unfold t_update. apply functional_extensionality. intros y.
  destruct (beq_stringP x1 y) as [H | H].
  - rewrite H in H1. apply beq_string_false_iff in H1.
    rewrite H1. reflexivity.
  - reflexivity.
Qed.

(* Partial maps *)

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

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

Notation "∅" := empty.

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

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

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

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

Theorem update_neq : ∀ (X:Type) v x1 x2
                       (m : partial_map X),
  x2 ≠ x1 →
  (m & {{ x2 ↦ v }}) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

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

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

Theorem update_permute : ∀ (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 ≠ x1 →
  m & {{x2 ↦ v2 ; x1 ↦ v1}}
  = m & {{x1 ↦ v1 ; x2 ↦ v2}}.
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.

(* ################################################################# *)
(** * Useful tactics *)

Ltac solve_by_inverts n :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
  end end.

Ltac solve_by_invert :=
  solve_by_inverts 2.

(* ################################################################# *)
(** * The original system: STLC with booleans *)

Module STLCBool.

(* Simple types *)
Inductive ty : Type :=
  | Bool  : ty
  | Arrow : ty → ty → ty
  .

(* Terms *)
Inductive tm : Type :=
    (* Pure STLC *)
  | var : string → tm                (* variable *)
  | app : tm → tm → tm              (* application *)
  | abs : string → ty → tm → tm    (* abstraction *)
    (* Booleans *)
  | tt  : tm                          (* true *)
  | ff  : tm                          (* false *)
  | ite : tm → tm → tm → tm        (* if-then-else *)
  .

(* Values *)
Inductive value : tm → Prop :=
  | v_abs : ∀ x T t, value (abs x T t)   (* abstractions *)
  | v_true : value tt                         (* true *)
  | v_false : value ff                        (* false *)
  .

Hint Constructors value.

(* Substitution *)
Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst x s t :=
  match t with
  | var x' =>
      if beq_string x x' then s else t
  | abs x' T t1 =>
      abs x' T (if beq_string x x' then t1 else ([x:=s] t1))
  | app t1 t2 =>
      app ([x:=s] t1) ([x:=s] t2)
  | tt =>
      tt
  | ff =>
      ff
  | ite t1 t2 t3 =>
      ite ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(* Small-step operational semantics *)
Reserved Notation "t1 '⇒' t2" (at level 40).

Inductive step : tm → tm → Prop :=
  | E_Beta : ∀ x T t12 v2,
      value v2 →
      (app (abs x T t12) v2) ⇒ [x:=v2]t12
  | E_App1 : ∀ t1 t1' t2,
      t1 ⇒ t1' →
      app t1 t2 ⇒ app t1' t2
  | E_App2 : ∀ v1 t2 t2',
      value v1 →
      t2 ⇒ t2' →
      app v1 t2 ⇒ app v1 t2'
  | E_IfTrue : ∀ t1 t2,
      (ite tt t1 t2) ⇒ t1
  | E_IfFalse : ∀ t1 t2,
      (ite ff t1 t2) ⇒ t2
  | E_If : ∀ t1 t1' t2 t3,
      t1 ⇒ t1' →
      (ite t1 t2 t3) ⇒ (ite t1' t2 t3)

where "t1 '⇒' t2" := (step t1 t2).

Hint Constructors step.

(* Typing context *)
Definition ctx := partial_map ty.

(* Typing judgments *)
Reserved Notation "Γ '⊢' t '∈' T" (at level 40).

Inductive has_type : ctx → tm → ty → Prop :=
  | T_Var : ∀ Γ x T,
      Γ x = Some T →
      Γ ⊢ var x ∈ T
  | T_Abs : ∀ Γ x T11 T12 t12,
      Γ & {{ x ↦ T11 }} ⊢ t12 ∈ T12 →
      Γ ⊢ abs x T11 t12 ∈ Arrow T11 T12
  | T_App : ∀ T11 T12 Γ t1 t2,
      Γ ⊢ t1 ∈ Arrow T11 T12 →
      Γ ⊢ t2 ∈ T11 →
      Γ ⊢ app t1 t2 ∈ T12
  | T_True : ∀ Γ,
       Γ ⊢ tt ∈ Bool
  | T_False : ∀ Γ,
       Γ ⊢ ff ∈ Bool
  | T_If : ∀ t1 t2 t3 T Γ,
       Γ ⊢ t1 ∈ Bool →
       Γ ⊢ t2 ∈ T →
       Γ ⊢ t3 ∈ T →
       Γ ⊢ ite t1 t2 t3 ∈ T

where "Γ '⊢' t '∈' T" := (has_type Γ t T).

Hint Constructors has_type.

(* Free occurrences *)
Inductive appears_free_in : string → tm → Prop :=
  | afi_var : ∀ x,
      appears_free_in x (var x)
  | afi_app1 : ∀ x t1 t2,
      appears_free_in x t1 →
      appears_free_in x (app t1 t2)
  | afi_app2 : ∀ x t1 t2,
      appears_free_in x t2 →
      appears_free_in x (app t1 t2)
  | afi_abs : ∀ x y T11 t12,
      y ≠ x  →
      appears_free_in x t12 →
      appears_free_in x (abs y T11 t12)
  | afi_if1 : ∀ x t1 t2 t3,
      appears_free_in x t1 →
      appears_free_in x (ite t1 t2 t3)
  | afi_if2 : ∀ x t1 t2 t3,
      appears_free_in x t2 →
      appears_free_in x (ite t1 t2 t3)
  | afi_if3 : ∀ x t1 t2 t3,
      appears_free_in x t3 →
      appears_free_in x (ite t1 t2 t3).

Hint Constructors appears_free_in.

(* A term is _closed_ if it contains no free variables: *)
Definition closed (t:tm) := ∀ x, ¬ appears_free_in x t.

(* Context invariance *)
Lemma free_in_context : ∀ x t T Γ,
  appears_free_in x t →
  Γ ⊢ t ∈ T →
  ∃ T', Γ x = Some T'.
Proof.
  intros x t T Γ H H0.
  generalize dependent Γ. (* Quantify a variable again. *)
  generalize dependent T.
  induction H;
         intros; try solve [inversion H0; eauto].
  - (* afi_abs *)
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite update_neq in H7; assumption.
Qed.

Corollary typable_empty__closed : ∀ t T,
  ∅ ⊢ t ∈ T  →
  closed t.
Proof with eauto.
  intros t T H x contra.
  apply free_in_context with (T:=T) (Γ:=empty) in contra...
  destruct contra as [T' HT']. inversion HT'.
Qed.

(* Context invariance lemma *)
Lemma context_invariance : ∀ Γ Γ' t T,
  Γ ⊢ t ∈ T  →
  (∀ x, appears_free_in x t → Γ x = Γ' x) →
  Γ' ⊢ t ∈ T.
Proof with eauto.
  intros.
  generalize dependent Γ'.
  induction H; intros; auto.
  - (* T_Var *)
    apply T_Var. rewrite <- H0...
  - (* T_Abs *)
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Γ'] we use to
       instantiate is [Γ & {{x↦T11}}] *)
    unfold update. unfold t_update.
    destruct (beq_string x x1) eqn: Hx0x1...
    rewrite beq_string_false_iff in Hx0x1. auto.
  - (* T_App *)
    apply T_App with T11...
Qed.

Corollary empty_context_invariance : ∀ Γ T t,
  ∅ ⊢ t ∈ T →
  Γ ⊢ t ∈ T.
Proof.
  intros Γ T t H.
  eapply context_invariance. eassumption.
  apply typable_empty__closed in H. unfold closed in H.
  intros. apply (H x) in H0. inversion H0.
Qed.

(* Substitution lemma *)
Lemma substitution_preserves_typing : ∀ Γ x U t v T,
  Γ & {{ x ↦ U }} ⊢ t ∈ T →
  ∅ ⊢ v ∈ U   →
  Γ ⊢ [x:=v]t ∈ T.
Proof with eauto.
  intros Γ x U t v T Ht Ht'.
  generalize dependent Γ. generalize dependent T.
  induction t; intros T Γ H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  - (* tvar *)
    rename s into y. destruct (beq_stringP x y) as [Hxy|Hxy].
    + (* x=y *)
      subst.
      rewrite update_eq in H2.
      inversion H2; subst.
      apply empty_context_invariance...
    + (* x≠y *)
      apply T_Var. rewrite update_neq in H2...
  - (* tabs *)
    rename s into y. rename t into T. apply T_Abs.
    destruct (beq_stringP x y) as [Hxy | Hxy].
    + (* x=y *)
      subst. rewrite update_shadow in H5. apply H5.
    + (* x≠y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_stringP y z) as [Hyz | Hyz]; subst; trivial.
      rewrite <- beq_string_false_iff in Hxy.
      rewrite Hxy...
Qed.

(* Main theorem of type preservation *)
Theorem preservation : ∀ t t' T,
  ∅ ⊢ t ∈ T →
  t ⇒ t' →
  ∅ ⊢ t' ∈ T.
Proof with eauto.
  remember (@empty ty) as Γ.
  intros t t' T HT. generalize dependent t'.
  induction HT;
       intros t' HE; subst Γ; subst;
       try solve [inversion HE; subst; auto].
  - (* T_App *)
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [eauto] takes care of them *)
    + (* ST_AppAbs *)
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

End STLCBool.

(* ################################################################# *)
(** * Q1: T-FunnyAbs *)

Module STLCBool_FunnyAbs.

(* Simple types *)
Inductive ty : Type :=
  | Bool  : ty
  | Arrow : ty → ty → ty
  .

(* Terms *)
Inductive tm : Type :=
    (* Pure STLC *)
  | var : string → tm                (* variable *)
  | app : tm → tm → tm              (* application *)
  | abs : string → ty → tm → tm    (* abstraction *)
    (* Booleans *)
  | tt  : tm                          (* true *)
  | ff  : tm                          (* false *)
  | ite : tm → tm → tm → tm        (* if-then-else *)
  .

(* Values *)
Inductive value : tm → Prop :=
  | v_abs : ∀ x T t, value (abs x T t)   (* abstractions *)
  | v_true : value tt                         (* true *)
  | v_false : value ff                        (* false *)
  .

Hint Constructors value.

(* Substitution *)
Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst x s t :=
  match t with
  | var x' =>
      if beq_string x x' then s else t
  | abs x' T t1 =>
      abs x' T (if beq_string x x' then t1 else ([x:=s] t1))
  | app t1 t2 =>
      app ([x:=s] t1) ([x:=s] t2)
  | tt =>
      tt
  | ff =>
      ff
  | ite t1 t2 t3 =>
      ite ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(* Small-step operational semantics *)
Reserved Notation "t1 '⇒' t2" (at level 40).

Inductive step : tm → tm → Prop :=
  | E_Beta : ∀ x T t12 v2,
      value v2 →
      (app (abs x T t12) v2) ⇒ [x:=v2]t12
  | E_App1 : ∀ t1 t1' t2,
      t1 ⇒ t1' →
      app t1 t2 ⇒ app t1' t2
  | E_App2 : ∀ v1 t2 t2',
      value v1 →
      t2 ⇒ t2' →
      app v1 t2 ⇒ app v1 t2'
  | E_IfTrue : ∀ t1 t2,
      (ite tt t1 t2) ⇒ t1
  | E_IfFalse : ∀ t1 t2,
      (ite ff t1 t2) ⇒ t2
  | E_If : ∀ t1 t1' t2 t3,
      t1 ⇒ t1' →
      (ite t1 t2 t3) ⇒ (ite t1' t2 t3)

where "t1 '⇒' t2" := (step t1 t2).

Hint Constructors step.

(* Typing context *)
Definition ctx := partial_map ty.

(* Typing judgments *)
Reserved Notation "Γ '⊢' t '∈' T" (at level 40).

Inductive has_type : ctx → tm → ty → Prop :=
  | T_Var : ∀ Γ x T,
      Γ x = Some T →
      Γ ⊢ var x ∈ T
  | T_Abs : ∀ Γ x T11 T12 t12,
      Γ & {{ x ↦ T11 }} ⊢ t12 ∈ T12 →
      Γ ⊢ abs x T11 t12 ∈ Arrow T11 T12
  | T_App : ∀ T11 T12 Γ t1 t2,
      Γ ⊢ t1 ∈ Arrow T11 T12 →
      Γ ⊢ t2 ∈ T11 →
      Γ ⊢ app t1 t2 ∈ T12
  | T_True : ∀ Γ,
       Γ ⊢ tt ∈ Bool
  | T_False : ∀ Γ,
       Γ ⊢ ff ∈ Bool
  | T_If : ∀ t1 t2 t3 T Γ,
       Γ ⊢ t1 ∈ Bool →
       Γ ⊢ t2 ∈ T →
       Γ ⊢ t3 ∈ T →
       Γ ⊢ ite t1 t2 t3 ∈ T
    (* FunnyAbs *)
  | T_FunnyAbs : ∀ x t,
       ∅ ⊢ abs x Bool t ∈ Bool  (* <--- here is empty *)

where "Γ '⊢' t '∈' T" := (has_type Γ t T).

Hint Constructors has_type.

Notation ill := (abs "x" Bool (var "z")).

Theorem preservation_not_hold : ∃ t t' T,
  ∅ ⊢ t ∈ T ∧
  t ⇒ t' ∧
  ¬ (∅ ⊢ t' ∈ T).
Proof.
  exists (app (abs "x" Bool (abs "y" Bool (var "x"))) ill).  (* t *)
  exists (["x":=ill](abs "y" Bool (var "x"))).               (* t' *)
  exists (Arrow Bool Bool).                                  (* T *)
  split. eauto.
  split. auto.
  simpl. unfold not. intros H. inversion H; subst; clear H.
  inversion H2; subst; clear H2.
  assert (Hcontra: empty "y" = (empty & {{ "y" ↦ Bool }}) "y") by
    (rewrite H0; auto).
  inversion Hcontra.
Qed.

End STLCBool_FunnyAbs.

(* ################################################################# *)
(** * Q2: T-FunnyAbs' *)

Module STLCBool_FunnyAbs'.

(* Simple types *)
Inductive ty : Type :=
  | Bool  : ty
  | Arrow : ty → ty → ty
  .

(* Terms *)
Inductive tm : Type :=
    (* Pure STLC *)
  | var : string → tm                (* variable *)
  | app : tm → tm → tm              (* application *)
  | abs : string → ty → tm → tm    (* abstraction *)
    (* Booleans *)
  | tt  : tm                          (* true *)
  | ff  : tm                          (* false *)
  | ite : tm → tm → tm → tm        (* if-then-else *)
  .

(* Values *)
Inductive value : tm → Prop :=
  | v_abs : ∀ x T t, value (abs x T t)   (* abstractions *)
  | v_true : value tt                         (* true *)
  | v_false : value ff                        (* false *)
  .

Hint Constructors value.

(* Substitution *)
Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst x s t :=
  match t with
  | var x' =>
      if beq_string x x' then s else t
  | abs x' T t1 =>
      abs x' T (if beq_string x x' then t1 else ([x:=s] t1))
  | app t1 t2 =>
      app ([x:=s] t1) ([x:=s] t2)
  | tt =>
      tt
  | ff =>
      ff
  | ite t1 t2 t3 =>
      ite ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(* Small-step operational semantics *)
Reserved Notation "t1 '⇒' t2" (at level 40).

Inductive step : tm → tm → Prop :=
  | E_Beta : ∀ x T t12 v2,
      value v2 →
      (app (abs x T t12) v2) ⇒ [x:=v2]t12
  | E_App1 : ∀ t1 t1' t2,
      t1 ⇒ t1' →
      app t1 t2 ⇒ app t1' t2
  | E_App2 : ∀ v1 t2 t2',
      value v1 →
      t2 ⇒ t2' →
      app v1 t2 ⇒ app v1 t2'
  | E_IfTrue : ∀ t1 t2,
      (ite tt t1 t2) ⇒ t1
  | E_IfFalse : ∀ t1 t2,
      (ite ff t1 t2) ⇒ t2
  | E_If : ∀ t1 t1' t2 t3,
      t1 ⇒ t1' →
      (ite t1 t2 t3) ⇒ (ite t1' t2 t3)

where "t1 '⇒' t2" := (step t1 t2).

Hint Constructors step.

(* Typing context *)
Definition ctx := partial_map ty.

(* Typing judgments *)
Reserved Notation "Γ '⊢' t '∈' T" (at level 40).

Inductive has_type : ctx → tm → ty → Prop :=
  | T_Var : ∀ Γ x T,
      Γ x = Some T →
      Γ ⊢ var x ∈ T
  | T_Abs : ∀ Γ x T11 T12 t12,
      Γ & {{ x ↦ T11 }} ⊢ t12 ∈ T12 →
      Γ ⊢ abs x T11 t12 ∈ Arrow T11 T12
  | T_App : ∀ T11 T12 Γ t1 t2,
      Γ ⊢ t1 ∈ Arrow T11 T12 →
      Γ ⊢ t2 ∈ T11 →
      Γ ⊢ app t1 t2 ∈ T12
  | T_True : ∀ Γ,
       Γ ⊢ tt ∈ Bool
  | T_False : ∀ Γ,
       Γ ⊢ ff ∈ Bool
  | T_If : ∀ t1 t2 t3 T Γ,
       Γ ⊢ t1 ∈ Bool →
       Γ ⊢ t2 ∈ T →
       Γ ⊢ t3 ∈ T →
       Γ ⊢ ite t1 t2 t3 ∈ T
    (* FunnyAbs *)
  | T_FunnyAbs : ∀ x t Γ,
       Γ ⊢ abs x Bool t ∈ Bool    (* <--- Γ *)

where "Γ '⊢' t '∈' T" := (has_type Γ t T).

Hint Constructors has_type.

(* Free occurrences *)
Inductive appears_free_in : string → tm → Prop :=
  | afi_var : ∀ x,
      appears_free_in x (var x)
  | afi_app1 : ∀ x t1 t2,
      appears_free_in x t1 →
      appears_free_in x (app t1 t2)
  | afi_app2 : ∀ x t1 t2,
      appears_free_in x t2 →
      appears_free_in x (app t1 t2)
  | afi_abs : ∀ x y T11 t12,
      y ≠ x  →
      appears_free_in x t12 →
      appears_free_in x (abs y T11 t12)
  | afi_if1 : ∀ x t1 t2 t3,
      appears_free_in x t1 →
      appears_free_in x (ite t1 t2 t3)
  | afi_if2 : ∀ x t1 t2 t3,
      appears_free_in x t2 →
      appears_free_in x (ite t1 t2 t3)
  | afi_if3 : ∀ x t1 t2 t3,
      appears_free_in x t3 →
      appears_free_in x (ite t1 t2 t3).

Hint Constructors appears_free_in.

(* Context invariance lemma: note that we require
   `Γ x = Γ' x` only when `x in Γ`. *)
Lemma context_invariance : ∀ Γ Γ' t T,
  Γ ⊢ t ∈ T  →
  (∀ x, appears_free_in x t → Γ x ≠ None →
             Γ x = Γ' x) →
  Γ' ⊢ t ∈ T.
Proof with eauto.
  intros.
  generalize dependent Γ'.
  induction H; intros; auto.
  - (* T_Var *)
    apply T_Var. rewrite <- H0...
    rewrite H. unfold not. intros contra. inversion contra.
  - (* T_Abs *)
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Γ'] we use to
       instantiate is [Γ & {{x↦T11}}] *)
    unfold update. unfold t_update.
    destruct (beq_string x x1) eqn: Hx0x1...
    rewrite beq_string_false_iff in Hx0x1. auto.
  - (* T_App *)
    apply T_App with T11...
Qed.

Corollary empty_context_invariance : ∀ Γ T t,
  ∅ ⊢ t ∈ T →
  Γ ⊢ t ∈ T.
Proof.
  intros Γ T t H.
  eapply context_invariance. eassumption.
  unfold not. intros x _ contra. elimtype False. apply contra.
  auto.
Qed.

(* Substitution lemma *)
Lemma substitution_preserves_typing : ∀ Γ x U t v T,
  Γ & {{ x ↦ U }} ⊢ t ∈ T →
  ∅ ⊢ v ∈ U   →
  Γ ⊢ [x:=v]t ∈ T.
Proof with eauto.
  intros Γ x U t v T Ht Ht'.
  generalize dependent Γ. generalize dependent T.
  induction t; intros T Γ H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  - (* tvar *)
    rename s into y. destruct (beq_stringP x y) as [Hxy|Hxy].
    + (* x=y *)
      subst.
      rewrite update_eq in H2.
      inversion H2; subst. apply empty_context_invariance. assumption.
    + (* x≠y *)
      apply T_Var. rewrite update_neq in H2...
  - (* tabs *)
    rename s into y. rename t into T. apply T_Abs.
    destruct (beq_stringP x y) as [Hxy | Hxy].
    + (* x=y *)
      subst. rewrite update_shadow in H5. apply H5.
    + (* x≠y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_stringP y z) as [Hyz | Hyz]; subst; trivial.
      rewrite <- beq_string_false_iff in Hxy.
      rewrite Hxy...
Qed.

(* Main theorem of type preservation *)
Theorem preservation : ∀ t t' T,
  ∅ ⊢ t ∈ T →
  t ⇒ t' →
  ∅ ⊢ t' ∈ T.
Proof with eauto.
  remember (@empty ty) as Γ.
  intros t t' T HT. generalize dependent t'.
  induction HT;
       intros t' HE; subst Γ; subst;
       try solve [inversion HE; subst; auto].
  - (* T_App *)
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [eauto] takes care of them *)
    + (* ST_AppAbs *)
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

End STLCBool_FunnyAbs'.

(* Answers Summary *)

Check STLCBool_FunnyAbs.preservation_not_hold.
Check STLCBool_FunnyAbs'.preservation.

(**-- End --**)


(*AST of SMEDL*)
(*Syntax related to the monitor is defined in this file, which will be used in definition of semantics*)
Require Import
  Coq.Strings.String
  Coq.Lists.List
  Coq.Bool.Bool
  Coq.Vectors.Vector
  Coq.ZArith.ZArith
  Coq.ZArith.Zdigits
  Coq.QArith.QArith_base
  Coq.QArith.Qabs
  Coq.FSets.FMapList
  Coq.FSets.FMapFacts
  Coq.Init.Notations
  Coq.Classes.EquivDec.

Require Import Coq.Sorting.Permutation.

Set Implicit Arguments.
Set Decidable Equality Schemes
(*Set Boolean Equality Schemes.*)
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

Require Import Coq.Strings.Ascii.

Open Scope N_scope.

Definition typeErr : string := "Type error".
Definition zeroErr: string := "zero divisor".

(*Used to distinct between normal value and error*)
Inductive ErrorOrResult{T} :=
| Result : forall v: T, @ErrorOrResult T
| Error : forall s: string, @ErrorOrResult T.

Section AST.

(* type            = ?/[a-zA-Z][A-Za-z0-9_]*/? ;
   identifier      = ?/[a-zA-Z][A-Za-z0-9_]*/? ;
   identifier_list = @:identifier {',' @:identifier}* | () ;
   target          = identifier  ;
   integer         = ?/[-+]?[0-9]+/? ;
   float           = ?/[-+]?[0-9]*\.?[0-9]+/? ; *)

(*supported type in SMEDL*)
Inductive typ :=
| Int
| Float
| Str
| Pointer
| Opaque
| Thread
.

Scheme Equality for typ.

(* variable_declaration
       = type:type var:identifier {',' var:identifier}* ';' ; *)

(* atom = integer | float | identifier | 'true' | 'false' | string | 'null' ; *)

Inductive atom : Set :=
  | AInt   : Z -> atom
  | AFloat : Q -> atom
  | AIdent : string -> atom
  | ABool  : bool -> atom
  | ANull  : atom
  | AString : string -> atom.

   Scheme Equality for atom.
Check atom_eq_dec.

(*typing environment*)
Definition typ_env := (list (atom * typ)).

(*supported value in SMEDL*)
(*Z and nat has different usage, but nat may be removed later*)
Definition range_typ : Set := (Z+Q+string+nat).

Definition range_typ_dec (re:range_typ):  forall re', {re = re'} + {re <> re'}.
Proof. repeat decide equality.   Qed.

Check range_typ_dec.
(*value environment*)
(*used to represent the scope in SMEDL*)
Definition value_env := (list (atom *( typ * range_typ))).

(*return domination*)
Definition dom (A:Type) (B: Type) (env: list (A*B)): list A :=
map (fun v:(A*B) => fst v) env.

Definition string_dec_bool (s1:string) (s2:string) : bool :=
if string_dec s1 s2 then true else false.

(*currently not used*)
Inductive uniq (A : Type) : list (atom * A) -> Prop :=
|  uniq_nil : uniq nil
| uniq_push : forall (x : atom)
                  (a : A) (E : list (atom * A)),
                uniq E ->
                ~(In x (dom E)) -> uniq ((x,a)::E).

Inductive uniqList (A : Type) : list (A) -> Prop :=
|  uniqL_nilL: uniqList nil
| uniqL_push : forall
                  (a : A) (E : list ( A)),
                uniqList E ->
                ~(In a (E)) -> uniqList ((a)::E).

Lemma uniqListNoDupEq: forall (A:Type) l,  uniqList l <-> @NoDup A l.
Proof. intros.
split.
- induction l. intros. constructor.
 intros. inversion H. subst. apply NoDup_cons;auto.
- induction l. intros. constructor. intros. inversion H;subst. apply uniqL_push;auto.
Qed.

(*auxiliary lemma*)
(*append of two jointed unique list is a uniqlist*)
Lemma uniqApp': forall (A:Type) (l1 l2:list A),
uniqList l1 -> uniqList l2 -> (forall i, In i l1 -> ~(In i l2)) ->
(forall i, In i l2 -> ~(In i l1)) -> uniqList(l1 ++ l2).
Proof. intros A l1.
induction l1. intros. simpl. auto.
intros. inversion H. subst.
assert (~ In a l2). apply H1. simpl. left. auto.
simpl. apply uniqL_push. apply IHl1. auto. auto. intros. apply H1. simpl. right. auto.
intros. apply H2 in H4. unfold not in H4. unfold not. intros. apply H4.
simpl. right. auto. unfold not. intros.
apply in_app_iff in H4. destruct H4.
unfold not in H6. apply H6. auto. unfold not in H3. apply H3. auto.
Qed.

(*auxiliary function, bool version of "In" *)
Fixpoint inList (A: Type) (decA: forall (x y:A), {x=y} + {x<>y}) (x: A) (lst : list A) : bool :=
match lst with
| nil => false
| y::lst' => if decA x y then true else (inList decA x lst')
end.

(*two lists are permutation of each other*)
Definition equivList {A: Type}   (l1: list A) (l2: list A) : Prop :=
Permutation l1 l2.

(*auxiliary function, update value of a varialbe in the environment*)
Fixpoint updateValueEnv (a: atom) (t: typ) (v: option range_typ) (en:value_env): value_env  :=
match v with
| None => en
| Some v' =>
match a with
| AIdent i => match en with
                        | nil => (a,(t,v'))::nil
                        | (a',(t',v''))::en' => if  atom_eq_dec a a' then
                                                           if typ_eq_dec  t t' then (a',(t',v'))::(updateValueEnv a t (Some v') en')
                                                                    else
                                                                    (a',(t',v'')) :: (updateValueEnv a t (Some v') en')
                                                     else
                                                              (a',(t',v'')) :: (updateValueEnv a t (Some v') en')
                   end

| _ => en
end
end.

(*auxiliary function, create a new environment based on the variable names, types and values*)
Fixpoint createValueEnv (nlst: list string) (tlst: list typ) (vlst: list range_typ): (ErrorOrResult):=
match nlst,tlst,vlst with
| s::nlst', t::tlst', v::vlst' => match createValueEnv nlst' tlst' vlst' with
                                                       | Error (s) => (Error s)
                                                       | Result (ve) => Result ((AIdent s,(t,v)):: ve)
                                                    end
| _, _, _ => Error ("number of list not matched")
end.

(*auxiliary function,get the type of a variable from the environment*)
Fixpoint getType (a: atom) (en:typ_env) : option typ :=
match a with
| AIdent i => match en with
                        | nil => None
                        | (a',v)::en' => if  atom_eq_dec a a' then Some v else getType a en'
                   end
| _ => None
end.

(*auxiliary function,get the value of a variable from the environment*)
Fixpoint getValue (a: atom) (en:value_env) : option range_typ :=
match a with
| AIdent i => match en with
                        | nil => None
                        | (a',(_,v))::en' => if  atom_eq_dec a a' then Some v else getValue a en'
                   end
| _ => None
end.

(*extend environment*)
(*assume that newly added variables are fresh to the environment*)
Definition extendEnv (A:Type) (en: list (atom * A)) (pen: list (atom * A)) : list (atom * A) := app en pen.

(*check if the value is consistent with the type*)
(*not used for now*)
Definition typeCheck (prod: (atom *( typ * range_typ))) : Prop:=
(exists v', (fst (snd prod)) =Int /\ (snd (snd prod)) = inl (inl (inl v')))
\/ (exists v', (fst (snd prod)) =Float /\ (snd (snd prod)) = inl (inl (inr v')))
\/ (exists v', (fst (snd prod)) =Str /\ (snd (snd prod)) = inl (inr v'))
\/ (exists v', (fst (snd prod)) =Pointer /\ (snd (snd prod)) = inr v')
\/  (exists v', (fst (snd prod)) =Thread /\ (snd (snd prod)) = inr v')
\/  (exists v', (fst (snd prod)) =Opaque /\ (snd (snd prod)) = inr v').

(* expression = or_ex:and_expr {'||' or_ex:and_expr}+ | @:and_expr ;
   expression_list = @:expression {',' @:expression}* | () ;
   and_expr = and_ex:sub_expr {'&&' and_ex:sub_expr}+ | @:sub_expr ;
   sub_expr = {'!!'}*'!(' not_ex:expression ')'
            | {'!!'}*'(' @:expression ')'
            | @:comp_expr ;
   comp_expr = comp:arith_expr
                 {operator:('>=' | '<=' | '==' | '!=' | '>' | '<')
                      comp:arith_expr}+
             | '(' @:comp_expr ')'
             | @:arith_expr ;
   arith_expr = arith:term {operator:('+' | '-' | '*' | '/' | '%') arith:term}+
              | @:term ;
   term = {unary:('+' | '-' | '~' | '!')}* atom:atom {trailer:trailer}*
        | {unary:('+' | '-' | '~')}* '(' @:arith_expr ')' ;
   trailer = '[' [index:expression] ']'
           | '(' [params:expression_list] ')'
           | '.' dot:identifier {trailer:trailer}* ; *)

Inductive expr : Set :=
  (* or_expr *)
  | EOr : expr -> expr -> expr

  (* and_expr *)
  | EAnd : expr -> expr -> expr

  (* sub_expr *)
  (* | ESubNot : nat -> expr -> expr *)
  (* | ESub : nat -> expr -> expr *)

  (* comp_expr *)
  | EEq  : expr -> expr -> expr
  | ENeq : expr -> expr -> expr
  | ELt  : expr -> expr -> expr
  | ELe  : expr -> expr -> expr
  | EGt  : expr -> expr -> expr
  | EGe  : expr -> expr -> expr

  (* arith_expr *)
  | EPlus  : expr -> expr -> expr
  | EMinus : expr -> expr -> expr
  | EMult  : expr -> expr -> expr
  | EDiv   : expr -> expr -> expr
  | EMod   : expr -> expr -> expr

  (* term *)
  | EPos : expr -> expr
  | ENeg : expr -> expr
(*  | ECmp : expr -> expr*)
  | ENot : expr -> expr

  | EAtom  : atom -> expr

     (* TODO *)
  | EIdx : atom -> N -> expr

  | EApp : atom -> list expr -> expr

    (* TODO *)
  | EDot : expr -> expr -> expr.

SearchAbout list sumbool.

(* event_definition =
       error:['error'] event_id:identifier ['(' params:parameter_list ')']
           ['=' definition:expression] ;
   parameter_list = @:type {',' @:type}* | () ;
   event_definition_list = @:event_definition {',' @:event_definition}* ';' ; *)

 Lemma expr_eq_dec : forall e1 e2: expr, {e1 = e2} + {e1 <> e2}.
Proof.
 fix rec 1.
 repeat decide equality.
Qed.

(*Instance expr_eq_dec1: EqDec expr eq. *)

Record exprlist :={
lst: list expr
}.

Lemma exprlist_eq_dec :
 forall e1 e2: exprlist, {e1 = e2} + {e1 <> e2}.
Proof. pose proof expr_eq_dec. repeat decide equality.
Qed.

Inductive EventKind := Internal | Imported | Exported.

Definition eventKind_dec (n m : EventKind) : {n = m} + { n <> m}.
Proof. repeat decide equality.
Qed.

Record event_definition : Set := {
  eventKind   : EventKind;
  eventError  : bool;
  eventId     : string;
  eventParams : list typ;
 (* eventParams : list string;*)
  (*eventDef    : option expr*)
}.

Definition event_definition_dec (n m : event_definition) : {n = m} + { n <> m}.
Proof. repeat decide equality.
Qed.

Record correct_event_definition (ev : event_definition) : Prop := {
}.

(* actions = '{' actions:action_item_list '}' ;
   action_item_list = @:action_item ';' { @:action_item ';' }* ;
   action_item
       = state_update:state_update
       | raise_stmt:raise_stmt
       | instantiation:instantiation_stmt
       | call_stmt:call_stmt ;
   raise_stmt = 'raise' id:identifier ['(' expr_list+:expression_list ')'] ;
   instantiation_stmt
       = 'new' id:identifier ['(' state_update_list+:state_update_list ')'] ;
   call_stmt = target:target '(' expr_list+:expression_list ')' ;

   state_update = target:target operator:('++' | '--')
       | target:target operator:'=' expression:expression ;
   state_update_list = @:state_update {',' @:state_update}* | () ; *)

Inductive state_update : Set :=
 (* | SUIncrement : expr -> state_update
  | SUDecrement : expr -> state_update*)
  | SUAssign : expr -> expr -> state_update.

Lemma state_update_eq_dec :
 forall e1 e2: state_update, {e1 = e2} + {e1 <> e2}.
Proof. intros. decide equality. apply expr_eq_dec.
apply expr_eq_dec.
Qed.

(*Instantiation and CallStmt are not used for now*)
Inductive action : Set :=
  | StateUpdate : state_update -> action
  | RaiseStmt (ident : string) (exprs : list expr) : action
  | Instantiation (ident : string) (updates : list state_update) : action
  | CallStmt (target : string) (args : list expr) : action.

Lemma action_eq_dec :
 forall e1 e2: action, {e1 = e2} + {e1 <> e2}.
Proof. intros. pose proof  state_update_eq_dec.
pose proof expr_eq_dec.
repeat decide equality.
Qed.

(* event_instance = expression:expression ['when' when:expression] ; *)

Record event_instance : Set := {
  event: event_definition; (*event definition of this instance*)
  eventArgs     : list string; (*indentifiers*)
  eventWhenExpr : option expr
}.

Definition event_instance_dec (n m : event_instance) : {n = m} + { n <> m}.
Proof.  intros. decide equality. Focus 3.
apply event_definition_dec.
Focus 2.
repeat decide equality.
 decide equality.
apply expr_eq_dec.
Qed.

Check string_dec.

(* step_definition = step_event:event_instance [step_actions:actions] ; *)

Definition scenario_state := string.

Record step : Set := {
  pre_state : scenario_state; (*source state of the step*)
  stepEvent : event_instance;
  stepActions : list action;
  pro_state : scenario_state (*target state of the step*)
}.

Definition step_dec (n m : step) : {n = m} + { n <> m}.
Proof.  pose proof action_eq_dec. pose proof expr_eq_dec.
 repeat decide equality.
Qed.

(* trace_definition
       = start_state:identifier '->'
           {trace_steps+:step_definition '->'}+  end_state:identifier
           ['else' [else_actions:actions] '->' else_state:identifier] ; *)

Record trace : Set := {
  startState  : string;
  traceSteps  : list step;      (* non-empty *)
  endState    : string;
  elseActions : list action;
  elseState   : option string
}.

Definition trace_dec (n m : trace) : {n = m} + { n <> m}.
Proof.  pose proof expr_eq_dec.
 repeat decide equality. Qed.

Record correct_trace (tr : trace) : Prop := {
  _ : (0 < length (traceSteps tr))%nat
}.

(* scenario_definition
       = atomic:['atomic'] scenario_id:identifier
           ':' traces:{trace_definition}+ ; *)

(*state machine*)
Record scenario : Set := {
  isAtomic   : bool;
  scenarioId : string;
  traces     : list trace       (* non-empty *);
  alphabet : list event_definition (*list of events triggering the transition in the scenario*)
}.

Definition scenario_dec (n m : scenario) : {n = m} + { n <> m}.
Proof. pose proof expr_eq_dec.
 repeat decide equality. Qed.

Record correct_scenario (s : scenario) : Prop := {
  _ : List.Forall correct_trace (traces s);
  _ : (0 < length (traces s))%nat
}.

(*mapping from scenario to its current state*)
(*assume that with in the same monitor, all states in different state machine have a unique name*)
Definition scenario_env := (list (scenario*scenario_state)).

Definition scenario_state_dec (n m : scenario*scenario_state) : {n = m} + { n <> m}.
Proof. pose proof scenario_dec. pose proof string_dec.
 repeat decide equality. Qed.

Print string_dec.
Fixpoint getScenarioState (sce:scenario) (env: scenario_env) : option  scenario_state :=
match env with
| nil => None
| (s,e)::en' => if (string_dec) (scenarioId sce) (scenarioId s) then Some e else getScenarioState sce en'
end.

Fixpoint updateScenarioState' (sce:scenario) (st:scenario_state) (env:scenario_env) :  scenario_env :=
match env with
| nil => nil
| (s,e)::en' => if string_dec (scenarioId s) (scenarioId sce) then (s,st)::updateScenarioState' sce st en' else (s,e)::updateScenarioState' sce st en'
end.

(* import_definition = '#import' import_id:identifier ;
   object =
       imports+:{import_definition}*
       'object' object:identifier
       ['identity' identity+:{variable_declaration}+]
       ['state' state+:{variable_declaration}+]
       'events'
           { 'internal' internal_events+:event_definition_list
           | 'exported' exported_events+:event_definition_list}*
           'imported' imported_events+:event_definition_list
           { 'imported' imported_events+:event_definition_list
           | 'internal' internal_events+:event_definition_list
           | 'exported' exported_events+event_definition_list}*
       'scenarios'
           scenarios+:{scenario_definition}+ $ ; *)

(*monitor*)
Record object : Type := {
  imports    : list string;
  objectId   : string;
  identities : typ_env;      (* name -> type *)
  variables  : typ_env;      (* name -> type *)
  events     : list event_definition;
  scenarios  : list scenario          (* non-empty *)
}.

Definition object_dec (n m : object) : {n = m} + { n <> m}.
Proof. pose proof expr_eq_dec.
 repeat decide equality. Qed.

(*check if the event is an imported event*)
Definition importedEvent (ev : event_definition) : Prop :=
  match eventKind ev with
  | Imported => True
  | Internal => False
  | Exported => False
  end.

(*check if the event is an imported or internal event*)
Definition importedOrInternalEvent (ev : event_definition) : Prop :=
 (match eventKind ev with
  | Imported => True
  | Internal => True
  | Exported => False
  end).

Record correct_object (obj : object) : Prop := {
  _ : List.Forall correct_event_definition (events obj);
  _ : List.Exists importedEvent (events obj);
  _ : List.Forall correct_scenario (scenarios obj);
  _ : (0 < length (scenarios obj))%nat
}.

End AST.

Arguments AInt _.
Arguments AFloat _.
Arguments ABool _.
Arguments AIdent _.
Arguments ANull.

Arguments EOr _ _.
Arguments EAnd _ _.

Arguments EEq _ _.
Arguments ENeq _ _.

Arguments ELt _ _.
Arguments ELe _ _.
Arguments EGt _ _.
Arguments EGe _ _.

Arguments EPlus _ _.
Arguments EMinus _ _.
Arguments EMult _ _.
Arguments EDiv _ _.
Arguments EMod _ _.

Arguments EPos _.
Arguments ENeg _.
(* Arguments ECmp _. *)
Arguments ENot _.

Arguments EAtom _.
Arguments EIdx _ _.
Arguments EApp _ _.
Arguments EDot _ _.

Arguments expr.

Section Monad.

(*aux function for evaluation*)
Definition Bind {T} : @ErrorOrResult T -> (T -> @ErrorOrResult T) -> @ErrorOrResult T :=
  fun val func =>
    match val with
    | Error err => Error err
    | Result v => (func v)
    end.

Notation ret v := (Result v).

Notation "x <- m ; y" := (Bind m (fun x => y))
                           (at level 51, right associativity,
                            format "'[v' x  <-  m ; '/' y ']'").

Definition BindZ : ErrorOrResult -> (Z -> ErrorOrResult) -> ErrorOrResult :=
  fun val func =>
    v <- val;
    match v with
    | AInt n => func n
    | _ => Error typeErr
    end.

Definition BindQ : ErrorOrResult -> (Q -> ErrorOrResult) -> ErrorOrResult :=
  fun val func =>
    v <- val;
    match v with
    | AFloat q => func q
    | _  => Error typeErr
    end.

Definition BindNum : ErrorOrResult -> (Z+Q -> ErrorOrResult) -> ErrorOrResult :=
  fun val func =>
    v <- val;
    match v with
    | AFloat q => func (inr q)
    | AInt n => func (inl n)
    | _  => Error typeErr
    end.

Definition BindBool : ErrorOrResult -> (bool -> ErrorOrResult) -> ErrorOrResult :=
  fun val func =>
    v <- val;
    match v with
    | ABool b => func b
    | _  => Error typeErr
    end.

Definition BindStr : ErrorOrResult -> (string -> ErrorOrResult) -> ErrorOrResult :=
  fun val func =>
    v <- val;
    match v with
    | AString s => func s
    | _  => Error typeErr
    end.

Definition BindData: ErrorOrResult -> (Z+Q+bool+string -> ErrorOrResult) -> ErrorOrResult :=
  fun val func =>
    v <- val;
    match v with
    | AString s => func (inr s)
    | ABool b => func (inl (inr b))
    | AInt n => func (inl (inl (inl n)))
    | AFloat q => func (inl (inl (inr q)))
    | _  => Error typeErr
    end.

Definition BindNumNotZero: ErrorOrResult -> (Z+Q -> ErrorOrResult) -> ErrorOrResult :=
  fun val func =>
    v <- val;
    match v with
    | AInt n => match n with
                      | Z0 =>  Error zeroErr
                      | _ => func (inl n)
                      end
    | AFloat q => match q with
                          | (0#1) =>  Error zeroErr
                          | _ => func  (inr q)
                          end
    | _  => Error typeErr
    end.

End Monad.

Notation "x <z- m ; y" := (BindZ m (fun x => y))
                             (at level 51, right associativity,
                              format "'[v' x  <z-  m ; '/' y ']'").

Notation "x <q- m ; y" := (BindQ m (fun x => y))
                             (at level 51, right associativity,
                              format "'[v' x  <q-  m ; '/' y ']'").

Notation "x <num- m ; y" := (BindNum m (fun x => y))
                             (at level 51, right associativity,
                              format "'[v' x  <num-  m ; '/' y ']'").

Notation "x <numn0- m ; y" := (BindNumNotZero m (fun x => y))
                             (at level 51, right associativity,
                              format "'[v' x  <numn0-  m ; '/' y ']'").

Notation "x <bool- m ; y" := (BindBool m (fun x => y))
                              (at level 51, right associativity,
                               format "'[v' x  <bool-  m ; '/' y ']'").

Notation "x <data- m ; y" := (BindData m (fun x => y))
                              (at level 51, right associativity,
                               format "'[v' x  <data-  m ; '/' y ']'").

Notation retInt v := (Result (AInt v)).
Notation retBool v := (Result (ABool v)).
Notation retFloat v := (Result (AFloat v)).
Notation retStr v := (Result (AString v)).

Section Denotation.

Definition Expr := expr.

Import ListNotations.

Local Open Scope Z_scope.
Local Open Scope string_scope.

(*expr evaluation*)
(*use monad to hide error info*)
Fixpoint evalMonad (env:value_env) (e:expr): ErrorOrResult :=
match e with
|EOr x y => b1 <bool- (evalMonad env x);
                   b2 <bool- evalMonad env y;
                   retBool ((b1 || b2))
|EAnd x y => b1 <bool- evalMonad env x;
                   b2 <bool- evalMonad env y;
                   retBool ((b1 && b2))
| ENot x => b1 <bool- evalMonad env x;
                   retBool ( (negb b1))
| EEq x y => n1 <data- evalMonad env x;
                    n2 <data- evalMonad env y;
                    match n1, n2 with
                    | (inl (inl (inl i))), (inl (inl (inl j))) => retBool ( (i =? j))
                    | (inl (inl (inl i))), (inl (inl (inr q))) => retBool ( (Qeq_bool (inject_Z i) q))
                    | (inl (inl (inr p))),(inl (inl (inl j))) => retBool ( (Qeq_bool p (inject_Z j)))
                    | (inl (inl (inr p))),(inl (inl (inr q))) =>  retBool ( (Qeq_bool p q))
                    |  (inl (inr b1)),  (inl (inr b2)) => retBool ( (eqb b1 b2))
                    | (inr s1), (inr s2) => retBool (string_dec_bool s1 s2)
                    | _, _  => Error typeErr
                   end
| ENeq x y => n1 <data- evalMonad env x;
                    n2 <data- evalMonad env y;
                    match n1, n2 with
                    | (inl (inl (inl i))), (inl (inl (inl j))) => retBool ( negb (i =? j))
                    | (inl (inl (inl i))), (inl (inl (inr q))) => retBool ( negb (Qeq_bool (inject_Z i) q))
                    | (inl (inl (inr p))),(inl (inl (inl j))) => retBool ( negb (Qeq_bool p (inject_Z j)))
                    | (inl (inl (inr p))),(inl (inl (inr q))) =>  retBool (negb (Qeq_bool p q))
                    |  (inl (inr b1)),  (inl (inr b2)) => retBool ( negb (eqb b1 b2))
                    | (inr s1), (inr s2) => retBool (negb (string_dec_bool s1 s2))
                    | _, _  => Error typeErr
                   end
| ELt x y => n1 <num- evalMonad env x;
                    n2 <num- evalMonad env y;
                    match n1, n2 with
                    | (inl i), (inl j) => retBool (  (i <? j))
                    |  (inl i), (inr q)=> retBool (  (Qle_bool (inject_Z i) q) && (negb (Qeq_bool (inject_Z i) q)))
                    | (inr p), (inl j) => retBool (  (Qle_bool p (inject_Z j) && negb (Qeq_bool p (inject_Z j))))
                    | (inr p), (inr q) =>  retBool ( (Qle_bool p q) && (negb (Qeq_bool p q)))
                   end

| ELe x y => n1 <num- evalMonad env x;
                    n2 <num- evalMonad env y;
                    match n1, n2 with
                    | (inl i), (inl j) => retBool (  (i <? j))
                    |  (inl i), (inr q) => retBool (  (Qle_bool (inject_Z i) q) )
                    | (inr p), (inl j) => retBool (  (Qle_bool p (inject_Z j) ))
                    | (inr p), (inr q) =>  retBool ( (Qle_bool p q) )
                   end

| EGt x y =>  n1 <num- evalMonad env x;
                    n2 <num- evalMonad env y;
                    match n1, n2 with
                    | (inl i), (inl j)  => retBool (  (i >? j))
                    |  (inl i), (inr q) => retBool (negb (Qle_bool (inject_Z i) q) )
                    | (inr p), (inl j) => retBool ( negb (Qle_bool p (inject_Z j) ))
                    | (inr p), (inr q) =>  retBool (negb (Qle_bool p q) )
                   end
| EGe x y => n1 <num- evalMonad env x;
                    n2 <num- evalMonad env y;
                    match n1, n2 with
                    | (inl i), (inl j)  => retBool ( negb  (i <? j))
                    |  (inl i), (inr q) => retBool ( negb( (Qle_bool (inject_Z i) q) && (negb (Qeq_bool (inject_Z i) q))))
                    | (inr p), (inl j) => retBool ( negb(  (Qle_bool p (inject_Z j) && negb (Qeq_bool p (inject_Z j)))))
                    | (inr p), (inr q) =>  retBool ( negb( (Qle_bool p q) && (negb (Qeq_bool p q))))
                   end

| EPlus x y => n1 <num- evalMonad env x;
                    n2 <num- evalMonad env y;
                    match n1, n2 with
                    | (inl i), (inl j)  => retInt (i+j)
                    |  (inl i), (inr q) => retFloat ((inject_Z i + q))
                    | (inr p), (inl j) => retFloat ((p + inject_Z j))
                    | (inr p), (inr q) =>  retFloat (p + q)
                   end

| EMinus x y => n1 <num- evalMonad env x;
                    n2 <num- evalMonad env y;
                    match n1, n2 with
                    | (inl i), (inl j)  => retInt (i-j)
                    |  (inl i), (inr q) => retFloat ((inject_Z i - q))
                    | (inr p), (inl j) => retFloat ((p - inject_Z j))
                    | (inr p), (inr q) =>  retFloat (p - q)
                   end

| EMult x y => n1 <num- evalMonad env x;
                    n2 <num- evalMonad env y;
                    match n1, n2 with
                    | (inl i), (inl j)  => retInt (i*j)
                    |  (inl i), (inr q) => retFloat ((inject_Z i * q))
                    | (inr p), (inl j) => retFloat ((p * inject_Z j))
                    | (inr p), (inr q) =>  retFloat (p * q)
                   end

| EDiv x y => n1 <num- evalMonad env x;
                    n2 <numn0- evalMonad env y;
                    match n1, n2 with
                    | (inl i), (inl j)  => retInt (i*j)
                    |  (inl i), (inr q) => retFloat ((inject_Z i * q))
                    | (inr p), (inl j) => retFloat ((p * inject_Z j))
                    | (inr p), (inr q) =>  retFloat (p * q)
                   end

| EMod x y => n1 <z- evalMonad env x;
                    n2 <z- evalMonad env y;
                    retInt (n1 mod n2)

| EPos x => n1 <num- evalMonad env x;
                    match n1 with
                    | inl (n) => retInt (Z.abs n)
                    | inr (q) => retFloat (Qabs q)
                    end

| ENeg x => n1 <num- evalMonad env x;
                    match n1 with
                    | inl (n) => retInt (-n)
                    | inr (q) => retFloat (-q)
                    end

|EAtom x => match x with
    | AIdent i => match getValue  (AIdent i) env with
                        | None => Error typeErr
                        |  Some (inl (inl (inl z))) => retInt (z)
                        | Some (inl (inl (inr q))) => retFloat (q)
                        | Some (inl (inr s)) => retStr (s)
                        | _ => Error typeErr
                        end
    | AInt z => retInt (z)
    | AFloat q =>  retFloat (q)
    | AString s => retStr (s)
    | ANull => retInt (0)
    | ABool b => if b then retInt (1) else retInt (0)
    end

| _ => Error typeErr
end.

End Denotation.