(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file implements finite set as unordered lists without duplicates
removed. This implementation forms a monad. *)
From prelude Require Export collections list.

Record listset A := Listset { listset_car: list A }.
Arguments listset_car {_} _.
Arguments Listset {_} _.

Section listset.
Context {A : Type}.

Instance listset_elem_of: ElemOf A (listset A) := λ x l, x ∈ listset_car l.
Instance listset_empty: Empty (listset A) := Listset [].
Instance listset_singleton: Singleton A (listset A) := λ x, Listset [x].
Instance listset_union: Union (listset A) := λ l k,
  let (l') := l in let (k') := k in Listset (l' ++ k').
Global Opaque listset_singleton listset_empty.

Global Instance: SimpleCollection A (listset A).
Proof.
  split.
  - by apply not_elem_of_nil.
  - by apply elem_of_list_singleton.
  - intros [?] [?]. apply elem_of_app.
Qed.
Lemma listset_empty_alt X : X ≡ ∅ ↔ listset_car X = [].
Proof.
  destruct X as [l]; split; [|by intros; simplify_eq/=].
  intros [Hl _]; destruct l as [|x l]; [done|]. feed inversion (Hl x); left.
Qed.
Global Instance listset_empty_dec (X : listset A) : Decision (X ≡ ∅).
Proof.
 refine (cast_if (decide (listset_car X = [])));
  abstract (by rewrite listset_empty_alt).
Defined.

Context `{∀ x y : A, Decision (x = y)}.

Instance listset_intersection: Intersection (listset A) := λ l k,
  let (l') := l in let (k') := k in Listset (list_intersection l' k').
Instance listset_difference: Difference (listset A) := λ l k,
  let (l') := l in let (k') := k in Listset (list_difference l' k').
Instance listset_intersection_with: IntersectionWith A (listset A) := λ f l k,
  let (l') := l in let (k') := k in Listset (list_intersection_with f l' k').
Instance listset_filter: Filter A (listset A) := λ P _ l,
  let (l') := l in Listset (filter P l').

Instance: Collection A (listset A).
Proof.
  split.
  - apply _.
  - intros [?] [?]. apply elem_of_list_intersection.
  - intros [?] [?]. apply elem_of_list_difference.
Qed.
Instance listset_elems: Elements A (listset A) := remove_dups ∘ listset_car.
Global Instance: FinCollection A (listset A).
Proof.
  split.
  - apply _.
  - intros. apply elem_of_remove_dups.
  - intros. apply NoDup_remove_dups.
Qed.
Global Instance: CollectionOps A (listset A).
Proof.
  split.
  - apply _.
  - intros ? [?] [?]. apply elem_of_list_intersection_with.
  - intros [?] ??. apply elem_of_list_filter.
Qed.
End listset.

(** These instances are declared using [Hint Extern] to avoid too
eager type class search. *)
Hint Extern 1 (ElemOf _ (listset _)) =>
  eapply @listset_elem_of : typeclass_instances.
Hint Extern 1 (Empty (listset _)) =>
  eapply @listset_empty : typeclass_instances.
Hint Extern 1 (Singleton _ (listset _)) =>
  eapply @listset_singleton : typeclass_instances.
Hint Extern 1 (Union (listset _)) =>
  eapply @listset_union : typeclass_instances.
Hint Extern 1 (Intersection (listset _)) =>
  eapply @listset_intersection : typeclass_instances.
Hint Extern 1 (IntersectionWith _ (listset _)) =>
  eapply @listset_intersection_with : typeclass_instances.
Hint Extern 1 (Difference (listset _)) =>
  eapply @listset_difference : typeclass_instances.
Hint Extern 1 (Elements _ (listset _)) =>
  eapply @listset_elems : typeclass_instances.
Hint Extern 1 (Filter _ (listset _)) =>
  eapply @listset_filter : typeclass_instances.

Instance listset_ret: MRet listset := λ A x, {[ x ]}.
Instance listset_fmap: FMap listset := λ A B f l,
  let (l') := l in Listset (f <$> l').
Instance listset_bind: MBind listset := λ A B f l,
  let (l') := l in Listset (mbind (listset_car ∘ f) l').
Instance listset_join: MJoin listset := λ A, mbind id.

Instance: CollectionMonad listset.
Proof.
  split.
  - intros. apply _.
  - intros ??? [?] ?. apply elem_of_list_bind.
  - intros. apply elem_of_list_ret.
  - intros ??? [?]. apply elem_of_list_fmap.
  - intros ? [?] ?. unfold mjoin, listset_join, elem_of, listset_elem_of.
    simpl. by rewrite elem_of_list_bind.
Qed.


Require Import FiatFormal.Data.List.
Require Import FiatFormal.Tactics.

(********************************************************************)
(** * Evaluation Contexts of lists *)
(*  A context defined by one place in a list of exps, where all
    the exps to the left of it in the list are values:
         v0 v1 v2 xx x4 x5 x6
                  ^^
    This is useful when enforcing a left-to-right evaluation
    order for a list of exps, like in the arguments of an XCon *)
Inductive exps_ctx
      {exp :Type}         (* type of expressions *)
      (Val: exp -> Prop)  (* predicate to determine whether the exp a value *)
   :  (exp -> list exp)   (* fn to fill the hole in the list evaluation context *)
   -> Prop :=
 | XscHead
   :  forall xs
   ,  exps_ctx Val (fun xx => xx :: xs)

 | XscCons
   :  forall v C
   ,  Val v
   -> exps_ctx Val C
   -> exps_ctx Val (fun xx => v :: C xx).

Hint Constructors exps_ctx.

(* Swapping related expresions in contexts *)
Lemma exps_ctx_Forall2_swap
 :  forall {exp: Type} {B:   Type}
           (Val:  exp -> Prop)
           (R:    exp -> B -> Prop)
           (C:    exp -> list exp)
           (x x': exp)
           (ys:   list B)
 ,  exps_ctx Val C
 -> (forall y, R x y -> R x' y)
 -> Forall2 R (C x)  ys
 -> Forall2 R (C x') ys.
Proof.
 intros. gen ys.
 induction H; intros.
  destruct ys.
   inverts H1.
   eapply Forall2_cons. eapply H0.
    inverts H1. auto.
    inverts H1. auto.

  inverts H2.
   eapply Forall2_cons.
   auto. auto.
Qed.

(* If all the elements in a list context have a property then
   then they also have this property individually. *)
Lemma exps_ctx_Forall
 :  forall {exp: Type}
           (Val: exp -> Prop)
           (C:   exp -> list exp)
           (P:   exp -> Prop)
           (x:   exp)
 ,  exps_ctx Val C
 -> Forall P (C x)
 -> P x.
Proof.
 intros.
 induction H.
  inverts H0. auto.
  inverts H0. auto.
Qed.

Lemma exps_ctx_Forall2_exists_left
 :  forall {exp: Type} {B: Type}
           (Val: exp -> Prop)
           (C:   exp -> list exp)
           (R:   exp -> B -> Prop)
           (x:   exp)
           (ys:  list B)
 ,  exps_ctx Val C
 -> Forall2 R (C x) ys
 -> (exists y, R x y).
Proof.
 intros. gen ys.
 induction H; intros.
  destruct ys.
   inverts H0.
   inverts H0. eauto.
  inverts H1.
  eapply IHexps_ctx. eauto.
Qed.

(* Used when evaluating all the expressions in a list.
   If all the exps in a list are either wnf or have some property,
   then they're either all wnf
     or there is a context consisting of a run of wnf expressions
        followed by one with the property.

   For example:
     C = w1 w2 w3 w4 x1 ?? ?? ?? ??

   This is a context consisting of a run of four wnfs, followed
   by an expression x1 with the desired property. The rest may or
   may not be wnfs, but the'll all have the property.
*)
Lemma exps_ctx_run
 :  forall {exp: Type} {B: Type}
           (Val:  exp -> Prop)
           (P:    exp -> Prop)
           (xs:   list exp)
 ,  Forall (fun x => Val x \/ P x) xs
 -> Forall Val xs
 \/ (exists C x', exps_ctx Val C
               /\ xs = C x'
               /\ P x').
Proof.
 intros.
 induction xs.
  left. auto.
  inverts H.

  inverts H2.
   lets D: IHxs H3. clear IHxs.
   inverts D.
    left. auto.
    right.
     destruct H0 as [C].
     destruct H0 as [x'].
      inverts H0. inverts H2.
      lets D2: (@XscCons exp Val) H H1.
      exists (fun xx => a :: C xx).
      exists x'. auto.

    lets D: IHxs H3. clear IHxs.
    inverts D.
     right.
     lets D2: (@XscHead exp Val) xs.
     exists (fun xx => xx :: xs).
     exists a. auto.

    destruct H0 as [C].
    destruct H0 as [x'].
     inverts H0. inverts H2.
     right.
     exists (fun xx => xx :: C x').
     exists a.
     lets D2: (@XscHead exp Val) (C x').
     auto.
Qed.

(********************************************************************)
(* Joint contexts of lists.
   This is used when we evaluate a list of expressions left to right
   where each expression needs to be a value before we move onto
   the next one. *)
Inductive exps_ctx2
      {exp: Type}        (* type of expressions *)
      (Val: exp -> Prop) (* predicate to determine whether an exp is a value *)
   :  (exp -> list exp)  (* fn for first  evaluation context *)
   -> (exp -> list exp)  (* fn for second evaluation context *)
   -> Prop :=
 | Xsc2Head
   :  forall xs ys
   ,  exps_ctx2 Val (fun xx => xx :: xs)  (fun yy => yy :: ys)

 | Xsc2Cons
   :  forall v C1 C2
   ,  Val v
   -> exps_ctx2 Val C1 C2
   -> exps_ctx2 Val (fun xx => v :: C1 xx) (fun yy => v :: C2 yy).

Hint Constructors exps_ctx2.

(* Take the left of a joint context *)
Lemma exps_ctx2_left
 : forall exp Val C1 C2
 , @exps_ctx2 exp Val C1 C2 -> @exps_ctx exp Val C1.
Proof.
 intros.
 induction H; auto.
Qed.

(* Take the right of a joint context *)
Lemma exps_ctx2_right
 : forall exp Val C1 C2
 , @exps_ctx2 exp Val C1 C2 -> @exps_ctx exp Val C2.
Proof.
 intros.
 induction H; auto.
Qed.

(* Used when evaluating a list of expressions.
   We take an expression from the first list, evaluate it, and
   place the result in the second. For this to happen we need
   to find an appropriate joint evaluation context.

   If we can produce a wnf for every expression in the first list,
   then either all exps are already wnf
     or we can find a joint context consisting of a run of wnf
        expressions, followed by an expression that we can evaluate.

   For example:
    C1 =  w1 w2 w3 x4 ?? ?? ??
    C2 =  w1 w2 w3 w4 ?? ?? ??

   Here we have such a joint context. The first three values in
   each are idential and already wnf. We then have x4 and y4,
   where x4 can be evaluated into y4. The rest may or may not
   be wnfs, but they'll still be related.

   v1 v2 v3 v4 XX x6 x7 x8 x9
   v1 v2 v3 v4 XX v6 v7 v8 v

*)
Lemma exps_ctx2_run
 :   forall {exp:   Type}
            (Val:   exp -> Prop)
            (R:     exp -> exp -> Prop)
            (xs ys: list exp)
 ,   Forall2 (fun x y => R x y /\ Val y /\ (Val x -> y = x)) xs ys
 ->  Forall Val xs
 \/ (exists C1 C2 x' y'
         ,  R x' y'
         /\ exps_ctx2 Val C1 C2
         /\ xs = C1 x'
         /\ ys = C2 y').
Proof.
 intros exp Val R xs ys HR.
 induction HR.
  Case "nil".
   left. auto.

  Case "cons".
   rename l  into xs.
   rename l' into ys.
   inverts H. inverts H1.
   inverts IHHR.
   SCase "xs whnf".
    right.
    exists (fun xx => xx :: xs).
    exists (fun xx => xx :: ys).
    exists x.
    exists y. auto.

   SCase "xs ctx".
    right.
    destruct H1 as [C1].
    destruct H1 as [C2].
    destruct H1 as [x'].
    destruct H1 as [y'].
    inverts H1. inverts H4. inverts H5.

    exists (fun xx => xx :: C1 x').
    exists (fun yy => yy :: C2 y').
    exists x. exists y.
    repeat (split; auto).
Qed.

Lemma exps_In_C_pmk : forall A x P C,
    exps_ctx P C -> @In A x (C x).
Proof.
  intros. gen x.
  induction H; eauto.
Qed.


(** * Synthesis.Front : Definition of the source language of our compiler  *)

Require Import Common.
Require Import DList.
Require Import Core.
Require Word Vector.

(** In order to factorise a bit development, we do not have exactly
the same definition as the one in the paper, where each primitive is
inlined in the following action data-type. Instead, with have a
dependently typed notion of primitive, that encapsulates interaction
with the external state. The paper corresponds to a version of the
[action] definiton where [primitive] is inlined. *)

Inductive primitive (Phi : state) : list type -> type -> Type:=
| input_read : forall t, var Phi (Tinput t) -> primitive Phi nil t
(* register operations *)
| register_read : forall t, var Phi (Treg t) ->  primitive Phi nil t
| register_write : forall t, var Phi (Treg t) -> primitive Phi (t:: nil) Tunit
(* register file primitives *)
| regfile_read : forall n t (v : var Phi (Tregfile n t)), primitive Phi ([ (Tint n)])%list  t
| regfile_write : forall n t (v : var Phi (Tregfile n t)), primitive Phi ([ (Tint n); t])%list  Tunit.

Section s.

  Variable Phi : state.
  (** * Definition of [expr] *)

  Section t.
    Variable Var : type -> Type.
    Inductive expr :  type -> Type :=
    | Evar : forall t (v : Var t), expr t
    | Eandb : expr B -> expr B -> expr B
    | Eorb  : expr B -> expr B -> expr B
    | Exorb : expr B -> expr B -> expr B
    | Enegb : expr B -> expr B

    (* "type-class" *)
    | Eeq   : forall t, expr t -> expr t -> expr B

    (* integer operations *)
    | Elt   : forall n, expr (Int n) -> expr (Int n) -> expr B
    | Ele   : forall n, expr (Int n) -> expr (Int n) -> expr B
    | Eadd  : forall n, expr (Int n) -> expr (Int n) -> expr (Int n)
    | Esub  : forall n, expr (Int n) -> expr (Int n) -> expr (Int n)
    | Elow  : forall n m, expr (Int (n + m)) -> expr (Int n)
    | Ehigh  : forall n m, expr (Int (n + m)) -> expr (Int m)
    | EcombineLH   : forall n m, expr (Int n) -> expr (Int m) -> expr (Int (n + m))

    | Econstant : forall  ty (c : constant ty), expr ( ty)

    | Emux : forall t, expr B -> expr t -> expr t -> expr t

    (* Tuple operations *)
    | Efst : forall l t , expr (Ttuple (t::l)) -> expr t
    | Esnd : forall l t , expr (Ttuple (t::l)) -> expr (Ttuple l)
    | Enth : forall l t (m : var l t), expr (Ttuple l) -> expr t
    | Etuple : forall l (exprs : DList.T (expr) l), expr (Ttuple l).

    (** * Definition of [action] *)
    Inductive action : type -> Type :=
    | Return : forall t (exp : expr t), action t
    | Bind :
      forall t u
        (a : action  t)
        (f : Var t -> action u),
        action u
    | Assert : forall (e : expr B), action Tunit
    | Primitive :
      forall args res (p : primitive Phi args res)
        (exprs : DList.T (expr) args),
        action res
    | OrElse : forall t, action t -> action t -> action t.
  End t.

  Definition Action t := forall Var, action Var t.
  Definition Expr t := forall Var, expr Var t.

  (** * Semantics of [expr] *)

  Fixpoint eval_expr (t : type) (e : expr eval_type t) : eval_type t :=
    match e with
      | Evar t v => v
      | Eandb a b => andb (eval_expr _ a) (eval_expr _ b)
      | Eorb a b => orb (eval_expr _ a) (eval_expr _ b)
      | Exorb a b => xorb (eval_expr _ a) (eval_expr _ b)
      | Enegb a => negb (eval_expr _ a)

      (* "type-class" *)
      | Eeq t a b => type_eq t (eval_expr t a) (eval_expr t b)

      (* integer operations *)
      | Elt n a b => @Word.lt n (eval_expr _ a) (eval_expr _ b)
      | Ele n a b => @Word.le n (eval_expr _ a) (eval_expr _ b)
      | Eadd n a b => @Word.add n (eval_expr _ a) (eval_expr _ b)
      | Esub n a b => @Word.sub n (eval_expr _ a) (eval_expr _ b)
      | Elow n m a => @Word.low n m (eval_expr _ a)
      | Ehigh n m a => @Word.high n m (eval_expr _ a)
      | EcombineLH n m a b => @Word.combineLH n m (eval_expr _ a) (eval_expr _ b)
      | Emux t b x y => if eval_expr _ b then eval_expr t x else eval_expr t y
      | Econstant ty c => c
      | Etuple l exprs =>
          DList.to_tuple eval_expr exprs
      | Enth l t v e =>
          Tuple.get l t v (eval_expr (Ttuple l) e)
      | Efst l t  e =>
          Tuple.fst  (eval_expr _ e)
      | Esnd l t  e =>
          Tuple.snd  (eval_expr _ e)
    end.
End s.

Delimit Scope expr_scope with expr.
Delimit Scope action_scope with action.

Arguments expr Var _%list.
Arguments action _%list _ _.

(** * Notations for actions and expressions  *)

Arguments Bind {Phi Var t u} _%action _%action.
Arguments Return {Phi Var t} _%expr.

Definition Bind' {Phi Var t u} a (f : expr Var t -> action Phi Var u) :=
    Bind (a) (fun x => let x := Evar _ _ x in f x).

(** A notation for the general bind, with [a] being an action  *)
Notation "'do' x <- a ; b" := (Bind' a (fun x =>  b))
                               (at level 200, x ident, a at level 100, b at level 200)
                          : action_scope.

(** A notation for the general bind, when the right hand side is an expression  *)
Notation "'do' x <~ a ; b " := (Bind' (Return a) (fun x =>  b))
                                (at level 200, x ident, a at level 100, b at level 200)
                              : action_scope.

Notation "'ret' x" := (Return x) (at level 0) : action_scope .

Arguments Assert {Phi Var} e%expr.

Definition When {Phi Var t} e a : action Phi Var t := @Bind Phi Var _ _ (Assert e) (fun _ => a).
Arguments When {Phi Var t} _%expr _%action.
Notation " 'when' e 'do' B" := (When e B) (at level 200, e at level 100, B at level 200).

Arguments Primitive {Phi Var} args res _ _%expr.

(** Primitives *)
Arguments register_read {Phi t} _.
Notation "'read' [: v ]" := (Primitive nil _ (register_read v) DList.nil) (no associativity).
Notation "! v" := (Primitive nil _ (register_read v) DList.nil ) (no associativity, at level 71).

Arguments register_write {Phi t} _.
Notation "'write' [: v <- w ]" := (Primitive (cons _ nil) Tunit (register_write v) (DList.cons (w)%expr (DList.nil))) (no associativity).
Notation "v ::= w" := (Primitive (cons _ nil) Tunit (register_write v) (DList.cons (w)%expr (DList.nil))) (no associativity, at level 71).

Arguments regfile_read {Phi n t} _.
Notation "'read' M [: v ]" := (Primitive ([ (_)])%list _ (regfile_read M ) (DList.cons (v)%expr (DList.nil))) (no associativity).

Arguments regfile_write {Phi n t} _ .
Notation "'write' M [: x <- v ]" := (Primitive ([ (_); _])%list _ (regfile_write M ) (DList.cons (x)%expr (DList.cons (v)%expr (DList.nil)))) (no associativity).

(** Expressions  *)
Arguments Enth  {Var l t} m _%expr.
Arguments Evar  {Var t} _.

Notation "~ x" :=  (Enegb _  x)%expr : expr_scope.
Notation "a || b" := (Eorb _ a b)%expr : expr_scope.
Notation "a && b" := (Eandb _ a b)%expr : expr_scope.
Notation "a - b" := (Esub _ _ a b)%expr : expr_scope.
Notation "a + b" := (Eadd _ _ a b)%expr : expr_scope.
Notation "a = b" := (Eeq _ _ a b)%expr : expr_scope.
Notation "a < b" := (Elt _ _ a b)%expr : expr_scope.
Notation "x <= y" := (Ele _ _ x y)%expr : expr_scope.
Notation "x <> y" := (~(x = y))%expr : expr_scope.
Notation low x := (Elow _ _ _ x).
Notation high x := (Ehigh _ _ _ x).
Notation combineLH x y := (EcombineLH _ _ _ x y).

Arguments Econstant {Var ty} _.
Notation "#i x" := (Econstant (Cword x)) (at level 0).
Notation "#b x" := (Econstant (Cbool x)) (at level 0).
Notation "#" := Econstant.

Definition Ctt : constant Tunit := tt.

Arguments Efst {Var l t} _%expr.
Arguments Esnd {Var l t} _%expr.

Arguments Emux {Var t} _%expr _%expr _%expr.
Notation "b ? l : r" := (Emux b l r) (at level 200, l, r at level 200).

Notation apply x f := (f x) (only parsing).

(* A do-notation for tuple-expressions *)
Definition Asplit {Phi Var l t u}  f (a: expr Var (Ttuple (t::l))) : action Phi Var u:=
  (do x <- ret (Efst a);
   do y <- ret (Esnd a);
   f x y)%action.

Notation "'do' ( x , .. , y ) <~ a ; b" :=
(apply a (Asplit (fun x => .. ( Asplit (fun y _ => b)) .. ))) (at level 200, x closed binder, a at level 100, b at level 200): action_scope.

Arguments Etuple {Var l} _%dlist.
Notation "[ 'tuple' x , .. , y ]" := (Etuple (x :: .. (y :: [ :: ]) .. )%dlist) (only parsing): expr_scope.

(*
 Unfortunately, this notation cannot be defined due to a bug... It redefines the notation for the pairs in every scope
  Notation "( x , .. , z )" := (Etuple (x :: .. (z :: [ :: ]) .. )%dlist) (at level 0): expr_scope.
*)

Module Diff.
  Section t.
    Variable Phi : state.
    Definition T := DList.T (option ∘ eval_mem) Phi.
    (* first *)
    Definition add (Delta : T) t (v : var Phi t) w :  T :=
      match DList.get v Delta  with
        | None =>  (DList.set v (Some w) Delta)
        | Some x => Delta
      end.

  End t.

  Definition init (Phi : state ): T Phi := DList.init (fun _ => None) Phi.

  Fixpoint apply (Phi : state) : T Phi -> DList.T eval_mem Phi -> DList.T eval_mem Phi :=
    match Phi with
      | nil => fun _ _ => [ :: ]
      | cons t Phi => fun Delta E =>
                     match DList.hd Delta with
                       | None => (DList.hd E :: apply Phi (DList.tl Delta) (DList.tl E))
                       | Some d => d :: apply Phi (DList.tl Delta) (DList.tl E)
                     end
    end%dlist.

End Diff.

Module Sem.

  (** * Definition of of the semantics of [action] *)

  Module Dyn.
    (** dynamic semantics:
    - continuation passing style: the current diff is threaded through the execution
    - illegal behaviors are denoted by None *)
    Section t.
      Variable Phi : state.
      (* semantics :  Action Phi t -> T t  *)

      Definition T t := eval_state Phi -> Diff.T Phi -> option (t * Diff.T Phi).

      Definition Return {t} (e : t) : T t  := fun st d => Some (e, d).

      Definition Bind {s t} : T s -> (s -> T t) -> T t :=
        fun (x : T s) (f : s -> T t) (st : eval_state Phi) (d : Diff.T Phi) =>
          match x st d with
              Some (e, d') =>  f e st d'
            | None => None
          end.

      Definition Retry {t} : T t := fun _ _ => None.

      Definition OrElse {t} : T t -> T t -> T t :=
        fun a b st Delta => match a st Delta with
                         | None => b st Delta
                         | Some Delta => Some Delta
                       end.

      Definition primitive_denote  args res (p : primitive Phi args res) (exprs : DList.T eval_type args) : T (eval_type res).
      refine (match
          p in (primitive _ l t) return (DList.T eval_type l -> T (eval_type t))
        with
          | input_read t v =>
            fun _ (st: eval_state Phi) Delta =>
            Some (DList.get v st, Delta)
          | register_read t v =>
              fun _ (st : eval_state Phi)
                  (Delta : Diff.T Phi) => Some (DList.get v st, Delta)
          | register_write t v =>
              fun (exprs : DList.T eval_type [t]) (_ : eval_state Phi) (Delta : Diff.T Phi) =>
                let w := DList.hd exprs in
                  Some (tt, Diff.add Phi Delta (Treg t) v w)
          | regfile_read n t v  =>
              fun (exprs : DList.T eval_type [ (Tint n)])
                  (st : eval_state Phi) (Delta : Diff.T Phi) =>
                let rf := DList.get  v st in
                let adr := DList.hd exprs in
                let v := Regfile.get rf (adr) in Some (v, Delta)
          | regfile_write n t v =>
              fun (exprs : DList.T eval_type [ (Tint n); t])
                  (st : eval_state Phi) (Delta : Diff.T Phi) =>
                let rf := DList.get  v st in
                let (adr, w) := (DList.hd exprs, DList.hd (DList.tl exprs)) in
                let rf :=  Regfile.set rf adr w
                in
                  Some (tt, Diff.add Phi Delta (Tregfile n t) v rf)
        end exprs).
      Defined.
    End t.
  End Dyn.

  (** dynamic semantics:
    - all guard failures are represented by None.
    - continuation passing style: the current diff is threaded through the execution
  *)
  Section t.
    Variable Phi : state.
    Fixpoint eval_action (t : type) (a : action Phi eval_type t) :
      (Dyn.T Phi (eval_type t)) :=
      match a with
        | Return t exp => Dyn.Return Phi (eval_expr _ exp)
        | Bind t u a f =>
            let act := eval_action _ a in
              let f' := (fun e => eval_action u (f e)) in
                Dyn.Bind Phi act f'
        | Assert e =>
            let g := eval_expr _ e in
              match g with
                | true => Dyn.Return Phi tt
                | false => Dyn.Retry  Phi
              end
        | Primitive args res p exprs =>
            Dyn.primitive_denote Phi args res p (DList.map eval_expr  exprs)
        | OrElse t a b => Dyn.OrElse Phi (eval_action _ a) (eval_action _ b)
      end.

  End t.
  Arguments eval_action {Phi} {t} _%action _ _.

End Sem.

Definition Eval Phi (st: eval_state Phi)  t (A : Action Phi t ) Delta :=  @Sem.eval_action Phi t (A _) st Delta.

(** * Next-step function

  The next-step function computes what should be the next state of a
circuit.

TODO: remark that Diff.init initialize even the Inputs with None,
which is not wrong, but prevents us from reasonning about circuits
that depend on their inputs. *)

Definition Next {t} Phi st (A : Action Phi t)  : option (eval_type t * eval_state Phi ):=
  let Delta := Eval Phi st _ A (Diff.init Phi) in
    match Delta with
      | None => None
      | Some Delta => Some (fst Delta, Diff.apply Phi (snd Delta) st)
    end.

(** We define two functions that computes the output of a circuit --
without internal state.  *)

Definition output  (t : type) (A : action nil eval_type t) :
    option (eval_type t) :=
    match Sem.eval_action  A DList.DList.nil (Diff.init []%list)  with
      | Some p => Some (fst p)
      | None => None
    end.

Definition Output (t : type) (A : Action nil t) := output t (A eval_type).

Module Close.
  Section t.
  (** * Closing a circuit.

      Circuits are oftne manipulated in an "open" fashion, using
      variables instead of inputs. The function [internalize] takes as
      input a circuit generator of type [Var t -> action Phi u], and
      produces a circuit of type [action (Phi :: Tinput t) u], with the
      variable being replaced by a formal input
   *)
  Variable Var : type -> Type.

  Definition primitive_generalize args res l1 (p : primitive l1 args res) l2:
    primitive (List.app  l1 l2) args res :=
    match p with
      | input_read t x => input_read _ _  (var_lift x )
      | register_read t x => register_read (var_lift x)
      | register_write t x => register_write (var_lift x)
      | regfile_read n t v => regfile_read  (var_lift v)
      | regfile_write n t v => regfile_write (var_lift v)
    end.

  Definition generalize (l1 : list mem) T (a : action l1 Var T) : forall l2, action (List.app l1 l2) Var T.
  refine (let fix aux (l1 : list mem) T (a : action l1 Var T) :
                  forall l2, action (List.app l1 l2) Var T :=
                match a  with
                  | Return t exp => fun l2 => Return (exp)
                  | Bind t u a f => fun l2 => let a' := aux _ _ a l2 in Bind a' (fun x => aux _ _ (f x) _)
                  | Assert e => fun l2 => Assert e
                  | Primitive args res p exprs => fun l2 : list mem =>
                                                   Primitive args res
                                                             (primitive_generalize args res _ p l2)
                                                             exprs
                  | OrElse t b1 b2 => fun l2 => OrElse _ _ t (aux _ _ b1 l2) (aux _ _ b2 l2)
                end
            in aux l1 T a
           ).
  Defined.

  Fixpoint var_last {A} (l : list A) (t : A) : var (List.app l [t]) t :=
    match l with
      | nil => var_0
      | hd :: q => var_S (var_last q t)
      end%list.

  Definition internalize {Phi T U} (c : Var T -> action Phi Var U) :
    action (List.app Phi [Tinput T]) Var U :=
    let v := (var_last Phi (Tinput T)) in
    (Bind  (Primitive nil T  (input_read (List.app Phi [Tinput T]) T  v) DList.DList.nil) (fun x =>
      generalize _ _ (c x) _))%action.
  End t.
End Close.

Definition Close := Close.internalize.


(* Since the variable names are now strings, we need to import the required libraries *)
Include Nat.
Local Open Scope nat_scope.
Require Import Strings.String.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.
Require Import List.
Scheme Equality for list.
Import ListNotations.

(* ErrorNat encapsulates the constructor error_nat,
   which is useful in the case of arithmetic operations like division by 0*)
Inductive ErrorNat :=
  | error_nat: ErrorNat
  | num: nat -> ErrorNat.

Inductive ErrorBool :=
  | error_bool: ErrorBool
  | boolean: bool -> ErrorBool.

Inductive ErrorStr :=
  | error_str: ErrorStr
  | str: string -> ErrorStr.

Coercion num: nat >-> ErrorNat.
Coercion boolean: bool >-> ErrorBool.
Coercion str: string >-> ErrorStr.

(* A general type which includes all kind of types *)
Inductive Result :=
  | err_undecl: Result
  | err_assign: Result
  | default: Result
  | res_nat: ErrorNat -> Result
  | res_bool: ErrorBool -> Result
  | res_str: ErrorStr -> Result.

Scheme Equality for Result.

(* An environment which maps variable names (strings) to the Result type *)
Definition Env := string -> Result.

(* Initial environment *)
Definition env : Env := fun x => err_undecl.

(* Initially each variable is undeclared *)
Compute (env "x").

Definition check_eq_over_types (t1 : Result) (t2 : Result) : bool :=
  match t1 with
    | err_undecl => match t2 with
                      | err_undecl => true
                      | _ => false
                    end
    | err_assign => match t2 with
                      | err_assign => true
                      | _ => false
                    end
    | default => match t2 with
                   | default => true
                   | _ => false
                 end
    | res_nat x => match t2 with
                     | res_nat y => true
                   	 | _ => false
                 	 end
    | res_bool x => match t2 with
                    	| res_bool y => true
                    	| _ => false
                  	end
    | res_str x => match t2 with
                     | res_str y => true
                     | _ => false
                   end
  end.

Compute (check_eq_over_types (res_bool true) (res_bool false)).
Compute (check_eq_over_types (res_nat 0) err_undecl).

Definition update (env : Env) (x : string) (v : Result) : Env :=
  fun y =>
    if (eqb y x)
    then
      if (andb (check_eq_over_types err_undecl (env y)) (negb (check_eq_over_types default v)))
      then err_undecl
      else
        if (andb (check_eq_over_types err_undecl (env y)) (check_eq_over_types default v))
        then default
        else
          if (orb (check_eq_over_types default (env y)) (check_eq_over_types v (env y)))
          then v
          else err_assign
    else (env y).

Notation "S [ V /' X ]" := (update S X V) (at level 0).

Compute (env "y").
Compute (update (update env "y" (default)) "y" (res_bool true) "y").
Compute (update (update env "y" (default)) "y" (res_str "test") "y").
Compute ((update (update (update env "y" default) "y" (res_nat 10)) "y" (res_bool true)) "y").
Compute ((update (update (update env "y" default) "y" (res_nat 10)) "y" (res_str "test")) "y").

(* Notations used for the Big-Step semantics *)
Reserved Notation "A =[ S ]=> N" (at level 60).
Reserved Notation "B ={ S }=> B'" (at level 70).
Reserved Notation "B -{ S }-> B'" (at level 70).

(* Strings *)
Inductive SExp :=
  | svar: string -> SExp
  | sconst: ErrorStr -> SExp.

Coercion svar: string >-> SExp.
Coercion sconst: ErrorStr >-> SExp.

Definition seval_fun (a : SExp) (env : Env) : ErrorStr :=
  match a with
    | svar v => match (env v) with
                  | res_str s => s
                  | _ => error_str
                end
    | sconst v => v
  end.

Inductive seval : SExp -> Env -> ErrorStr -> Prop :=
  | s_var: forall v sigma, svar v -{ sigma }-> match (sigma v) with
                                                 | res_str x => x
                                                 | _ => error_str
                                               end
  | s_const: forall s sigma, sconst s -{ sigma }-> s
  where "B -{ S }-> B'" := (seval B S B').

(* Arithmetic expressions *)
Inductive AExp :=
  | avar: string -> AExp
  | anum: ErrorNat -> AExp
  | aplus: AExp -> AExp -> AExp
  | aminus: AExp -> AExp -> AExp
  | amul: AExp -> AExp -> AExp
  | adiv: AExp -> AExp -> AExp
  | amod: AExp -> AExp -> AExp
	| strlen: SExp -> AExp.

Coercion anum: ErrorNat >-> AExp.
Coercion avar: string >-> AExp.

Notation "A +' B" := (aplus A B)(at level 50, left associativity).
Notation "A -' B" := (aminus A B)(at level 50, left associativity).
Notation "A *' B" := (amul A B)(at level 48, left associativity).
Notation "A /' B" := (adiv A B)(at level 48, left associativity).
Notation "A %' B" := (amod A B)(at level 45, left associativity).
Notation "'strlen(' A ')'" := (strlen A)(at level 50, left associativity).

Definition plus_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => num (v1 + v2)
    end.

Definition minus_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num n1, num n2 => if Nat.ltb n1 n2
                        then error_nat
                        else num (n1 - n2)
    end.

Definition mul_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => num (v1 * v2)
    end.

Definition div_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | _, num 0 => error_nat
    | num v1, num v2 => num (Nat.div v1 v2)
    end.

Definition mod_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | _, num 0 => error_nat
    | num v1, num v2 => num (v1 - v2 * (Nat.div v1 v2))
    end.

Fixpoint length (s : string) : nat :=
  match s with
  	| EmptyString => 0
  	| String c s' => S (length s')
  end.

Definition strlen_ErrorNat (s : ErrorStr) : ErrorNat :=
	match s with
		| error_str => error_nat
		| str s1 => num (length s1)
	end.

Compute (strlen_ErrorNat "").
Compute (strlen_ErrorNat "lungime").

Fixpoint aeval_fun (a : AExp) (env : Env) : ErrorNat :=
  match a with
  | avar v => match (env v) with
                | res_nat n => n
                | _ => error_nat
              end
  | anum v => v
  | aplus a1 a2 => (plus_ErrorNat (aeval_fun a1 env) (aeval_fun a2 env))
  | aminus a1 a2 => (minus_ErrorNat (aeval_fun a1 env) (aeval_fun a2 env))
  | amul a1 a2 => (mul_ErrorNat (aeval_fun a1 env) (aeval_fun a2 env))
  | adiv a1 a2 => (div_ErrorNat  (aeval_fun a1 env) (aeval_fun a2 env))
  | amod a1 a2 => (mod_ErrorNat (aeval_fun a1 env) (aeval_fun a2 env))
	| strlen s => (strlen_ErrorNat (seval_fun s env))
  end.

(* Big-Step semantics for arithmetic operations *)
Inductive aeval : AExp -> Env -> ErrorNat -> Prop :=
  | const: forall n sigma, anum n =[ sigma ]=> n
  | var: forall v sigma, avar v =[ sigma ]=>  match (sigma v) with
                                                | res_nat x => x
                                                | _ => error_nat
                                              end
  | addition: forall a1 a2 i1 i2 sigma n,
         			a1 =[ sigma ]=> i1 ->
         			a2 =[ sigma ]=> i2 ->
         			n = (plus_ErrorNat i1 i2) ->
         			a1 +' a2 =[ sigma ]=> n
  | substract: forall a1 a2 i1 i2 sigma n,
               a1 =[ sigma ]=> i1 ->
               a2 =[ sigma ]=> i2 ->
               n = (minus_ErrorNat i1 i2) ->
               a1 -' a2 =[ sigma ]=> n
  | times: forall a1 a2 i1 i2 sigma n,
           a1 =[ sigma ]=> i1 ->
           a2 =[ sigma ]=> i2 ->
           n = (mul_ErrorNat i1 i2) ->
           a1 *' a2 =[ sigma ]=> n
  | division: forall a1 a2 i1 i2 sigma n,
              a1 =[ sigma ]=> i1 ->
              a2 =[ sigma ]=> i2 ->
              n = (div_ErrorNat  i1 i2) ->
              a1 /' a2 =[ sigma ]=> n
  | modulo': forall a1 a2 i1 i2 sigma n,
             a1 =[ sigma ]=> i1 ->
             a2 =[ sigma ]=> i2 ->
             n = (mod_ErrorNat i1 i2) ->
             a1 %' a2 =[ sigma ]=> n
	| str_len: forall s i sigma n,
						 s -{ sigma }-> i ->
						 n = (strlen_ErrorNat i) ->
						 strlen(s) =[ sigma ]=> n
  where "a =[ sigma ]=> n" := (aeval a sigma n).

Example substract_error : 1 -' 2 =[ env ]=> error_nat.
Proof.
  eapply substract.
  - apply const.
  - apply const.
  - simpl. reflexivity.
Qed.

Example division_error : 10 /' 0 =[ env ]=> error_nat.
Proof.
  eapply division.
  - apply const.
  - apply const.
  - simpl. reflexivity.
Qed.

Example modulo_error : 10 %' 0 =[ env ]=> error_nat.
Proof.
  eapply modulo'.
  - apply const.
  - apply const.
  - simpl. reflexivity.
Qed.

(* Boolean expressions *)
Inductive BExp :=
  | berror
  | btrue
  | bfalse
  | bvar: string -> BExp
  | blt: AExp -> AExp -> BExp
  | bgt: AExp -> AExp -> BExp
  | bequal: AExp -> AExp -> BExp
  | bnot: BExp -> BExp
  | band: BExp -> BExp -> BExp
  | bor: BExp -> BExp -> BExp
	| strcmp: SExp -> SExp -> BExp.

Notation "A <' B" := (blt A B)(at level 70).
Notation "A >' B" := (bgt A B)(at level 70).
Notation "A =' B" := (bequal A B)(at level 70).
Notation "!' A" := (bnot A)(at level 51, left associativity).
Notation "A &&' B" := (band A B)(at level 52, left associativity).
Notation "A ||' B" := (bor A B)(at level 53, left associativity).
Notation "'strcmp(' A ',' B ')'" := (strcmp A B)(at level 50, left associativity).

Definition lt_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => boolean (Nat.ltb v1 v2)
  end.

Definition gt_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => boolean (Nat.ltb v2 v1)
  end.

Definition equal_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => boolean (Nat.eqb v1 v2)
  end.

Definition not_ErrorBool (n :ErrorBool) : ErrorBool :=
  match n with
    | error_bool => error_bool
    | boolean v => boolean (negb v)
  end.

Definition and_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | boolean v1, boolean v2 => boolean (andb v1 v2)
  end.

Definition or_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | boolean v1, boolean v2 => boolean (orb v1 v2)
  end.

Definition strcmp_ErrorBool (s1 s2 : ErrorStr) : ErrorBool :=
  match s1, s2 with
    | error_str, _ => error_bool
    | _, error_str => error_bool
    | str str1, str str2 => boolean (eqb str1 str2)
  end.

Compute (strcmp_ErrorBool "ana" "Ana").
Compute (strcmp_ErrorBool "ana" "ana").

Fixpoint beval_fun (a : BExp) (envnat : Env) : ErrorBool :=
  match a with
    | btrue => true
    | bfalse => false
    | berror => error_bool
    | bvar v => match (env v) with
                  | res_bool n => n
                  | _ => error_bool
                end
    | blt a1 a2 => (lt_ErrorBool (aeval_fun a1 envnat) (aeval_fun a2 envnat))
    | bgt a1 a2 => (gt_ErrorBool (aeval_fun a1 envnat) (aeval_fun a2 envnat))
    | bequal a1 a2 => (equal_ErrorBool (aeval_fun a1 envnat) (aeval_fun a2 envnat))
    | bnot b1 => (not_ErrorBool (beval_fun b1 envnat))
    | band b1 b2 => (and_ErrorBool (beval_fun b1 envnat) (beval_fun b2 envnat))
    | bor b1 b2 => (or_ErrorBool (beval_fun b1 envnat) (beval_fun b2 envnat))
		| strcmp s1 s2 => (strcmp_ErrorBool (seval_fun s1 env) (seval_fun s2 env))
  end.

Inductive beval : BExp -> Env -> ErrorBool -> Prop :=
  | b_error: forall sigma, berror  ={ sigma }=> error_bool
  | b_true: forall sigma, btrue ={ sigma }=> true
  | b_false: forall sigma, bfalse ={ sigma }=> false
  | b_var: forall v sigma, bvar v ={ sigma }=>  match (sigma v) with
                                               		| res_bool x => x
                                                  | _ => error_bool
                                                end
  | b_lessthan: forall a1 a2 i1 i2 sigma b,
                a1 =[ sigma ]=> i1 ->
                a2 =[ sigma ]=> i2 ->
                b = (lt_ErrorBool i1 i2) ->
                a1 <' a2 ={ sigma }=> b
  | b_greaterthan: forall a1 a2 i1 i2 sigma b,
                 	 a1 =[ sigma ]=> i1 ->
                   a2 =[ sigma ]=> i2 ->
                   b = (gt_ErrorBool i1 i2) ->
                   a1 >' a2 ={ sigma }=> b
  | b_equal: forall a1 a2 i1 i2 sigma b,
             a1 =[ sigma ]=> i1 ->
             a2 =[ sigma ]=> i2 ->
             b = (equal_ErrorBool i1 i2) ->
             a1 =' a2 ={ sigma }=> b
  | b_not: forall a1 i1 sigma b,
           a1 ={ sigma }=> i1 ->
           b = (not_ErrorBool i1) ->
           !'a1 ={ sigma }=> b
  | b_and: forall a1 a2 i1 i2 sigma b,
           a1 ={ sigma }=> i1 ->
           a2 ={ sigma }=> i2 ->
           b = (and_ErrorBool i1 i2) ->
           (a1 &&' a2) ={ sigma }=> b
  | b_or: forall a1 a2 i1 i2 sigma b,
          a1 ={ sigma }=> i1 ->
          a2 ={ sigma }=> i2 ->
          b = (or_ErrorBool i1 i2) ->
          (a1 ||' a2) ={ sigma }=> b
	| b_strcmp: forall s1 s2 string1 string2 sigma b,
              s1 -{ sigma }-> string1 ->
              s2 -{ sigma }-> string2 ->
              b = (strcmp_ErrorBool string1 string2) ->
              strcmp(s1,s2) ={ sigma }=> b
where "B ={ S }=> B'" := (beval B S B').

Example boolean_operation : bnot (150 <' "n") ={ env }=> error_bool.
Proof.
  eapply b_not.
  eapply b_lessthan.
  - eapply const.
  - eapply var.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Inductive vector :=
  | error_vector
  | vector_nat: list ErrorNat -> vector
  | vector_bool: list ErrorBool -> vector
  | vector_str: list ErrorStr -> vector.

Inductive Stmt :=
  | nat_decl: string -> AExp -> Stmt
  | bool_decl: string -> BExp -> Stmt
  | str_decl: string -> SExp -> Stmt
  | vectorN_decl: string -> nat -> vector -> Stmt
	| vectorB_decl: string -> nat -> vector -> Stmt
	| vectorS_decl: string -> nat -> vector -> Stmt
  | nat_assign: string -> AExp -> Stmt
  | bool_assign: string -> BExp -> Stmt
  | str_assign: string -> SExp -> Stmt
  | vectorN_assign: string -> vector -> Stmt
  | vectorB_assign: string -> vector -> Stmt
  | vectorS_assign: string -> vector -> Stmt
	| struct: string -> Stmt -> Stmt
  | sequence: Stmt -> Stmt -> Stmt
  | ifthenelse: BExp -> Stmt -> Stmt -> Stmt
  | ifthen: BExp -> Stmt -> Stmt
  | while: BExp -> Stmt -> Stmt
  | switch: AExp -> list Cases -> Stmt
  with Cases := | def: Stmt -> Cases
                | case: nat -> Stmt -> Cases.

Notation "X n= A" := (nat_assign X A)(at level 90).
Notation "X b= A" := (bool_assign X A)(at level 90).
Notation "X s= A" := (str_assign X A)(at level 90).
Notation "X [ i ] nv= A":= (vectorN_assign X i A)(at level 90).
Notation "X [ i ] bv= A":= (vectorB_assign X i A)(at level 90).
Notation "X [ i ] sv= A":= (vectorS_assign X i A)(at level 90).
Notation "'Unsigned' X ::= A" := (nat_decl X A)(at level 90).
Notation "'Bool' X ::= A" := (bool_decl X A)(at level 90).
Notation "'String' X ::= A" := (str_decl X A)(at level 90).
Notation "'NatVector' X [ i ] ::= { A }" := (vectorN_decl X (vector_nat i (cons A nil)))(at level 90).
(* Notation "'NatVector' X [ i ] ::= { A1 , A2 , ... , An }" := (vector_decl X (vector_nat i (cons nat(A1) (cons nat(A2) .. (cons nat(An) nil) ..))))(at level 90). *)
Notation "'BoolVector' X [ i ] ::= { A }" := (vectorB_decl X (vector_bool i (cons A nil)))(at level 90).
(* Notation "'BoolVector' X [ i ] ::= { A1 , A2 , ... , An }" := (vector_decl X (vector_bool i (cons nat(A1) (cons nat(A2) .. (cons nat(An) nil) ..))))(at level 90). *)
Notation "'StrVector' X [ i ] ::= { A }" := (vectorS_decl X (vector_str i (cons A nil)))(at level 90).
(* Notation "'StrVector' X [ i ] ::= { A1 , A2 , ... , An }" := (vector_decl X (vector_str i (cons nat(A1) (cons nat(A2) .. (cons nat(An) nil) ..))))(at level 90). *)
Notation "'Struct' X { A }" := (struct X A)(at level 91).
Notation "S1 ;; S2" := (sequence S1 S2)(at level 93, right associativity).
Notation "'fordo' ( A -- B -- C ) { S }" := (A ;; while B ( S ;; C ))(at level 97).
Notation "'default' : { A }" := (default A)(at level 96).
Notation "'case' ( A ) : { B }" := (case A B)(at level 96).
Notation "'switch' ( A ) : { B } " := (switch A (cons B nil))(at level 97).
(* Notation "'switch' ( A ) : { B1 ; B2 ; ... ; Bn }" := (switch A (cons B1 (cons B2 .. (cons Bn nil) ..)))(at level 97). *)

Fixpoint eval_fun (s : Stmt) (env : Env) (gas: nat) : Env :=
	match gas with
		| 0 => env
    | S gas' => match s with
                	| sequence S1 S2 => eval_fun S2 (eval_fun S1 env gas') gas'
                  | nat_decl a aexp => update (update env a default) a (res_nat (aeval_fun aexp env))
                  | bool_decl b bexp => update (update env b default) b (res_bool (beval_fun bexp env))
                  | str_decl s sexp => update (update env s default) s (res_str (seval_fun sexp env))
									| vect_nat_decl a aexp => update (update env a default) a (res_nat (aeval_fun aexp env))
                  | vect_bool_decl b bexp => update (update env b default) b (res_bool (beval_fun bexp env))
                  | vect_str_decl s sexp => update (update env s default) s (res_str (seval_fun sexp env))
                  | nat_assign a aexp => update env a (res_nat (aeval_fun aexp env))
                  | bool_assign b bexp => update env b (res_bool (beval_fun bexp env))
                  | str_assign s aexp => update env s (res_str (seval_fun sexp env))
									| vect_nat_assign a aexp => update env a (res_nat (aeval_fun aexp env))
                  | vect_bool_assign b bexp => update env b (res_bool (beval_fun bexp env))
                  | vect_str_assign s aexp => update env s (res_str (seval_fun sexp env))
									| struct s => eval_fun s env gas'
                  | ifthen cond s' => match (beval_fun cond env) with
                                        | error_bool => env
                                        | boolean v => match v with
                                                         | true => eval_fun s' env gas'
                                                         | false => env
                                                       end
                                      end
                  | ifthenelse cond S1 S2 => match (beval_fun cond env) with
                                               | error_bool => env
                                               | boolean v  => match v with
                                                                 | true => eval_fun S1 env gas'
                                                                 | false => eval_fun S2 env gas'
                                                               end
                                             end
                  | while cond s' => match (beval_fun cond env) with
                                       | error_bool => env
                                       | boolean v => match v with
                                                        | true => eval_fun (s' ;; (while cond s')) env gas'
                                                        | false => env
                                                      end
                                     end
                  | switch cond s' => match (beval_fun cond env with
                                        | (* I am stuck *)
                end
  end.

Reserved Notation "S -[ Sigma ]-> Sigma'" (at level 60).

Inductive eval : Stmt -> Env -> Env -> Prop :=
  | e_nat_decl: forall a i x sigma sigma',
                a =[ sigma ]=> i ->
                sigma' = (update sigma x (res_nat i)) ->
                (x n= a) -[ sigma ]-> sigma'
  | e_nat_assign: forall a i x sigma sigma',
                  a =[ sigma ]=> i ->
                  sigma' = (update sigma x (res_nat i)) ->
                  (x n= a) -[ sigma ]-> sigma'
  | e_bool_decl: forall a i x sigma sigma',
                 a ={ sigma }=> i ->
                 sigma' = (update sigma x (res_bool i)) ->
                 (x b= a) -[ sigma ]-> sigma'
  | e_bool_assign: forall a i x sigma sigma',
                   a ={ sigma }=> i ->
                   sigma' = (update sigma x (res_bool i)) ->
                   (x b= a) -[ sigma ]-> sigma'
  | e_str_decl: forall a i x sigma sigma',
                a ={ sigma }=> i ->
                sigma' = (update sigma x (res_str i)) ->
                (x s= a) -[ sigma ]-> sigma'
  | e_str_assign: forall a i x sigma sigma',
                  a ={ sigma }=> i ->
                  sigma' = (update sigma x (res_str i)) ->
                  (x s= a) -[ sigma ]-> sigma'
  | e_vectorN_decl: forall a i x sigma sigma',
                		a ={ sigma }=> i ->
                		sigma' = (update sigma x (res_nat i)) ->
                		(x s= a) -[ sigma ]-> sigma'
  | e_vectorN_assign: forall a i x sigma sigma',
                  		a ={ sigma }=> i ->
                  		sigma' = (update sigma x (res_nat i)) ->
                  		(x s= a) -[ sigma ]-> sigma'
	| e_vectorB_decl: forall a i x sigma sigma',
                		a ={ sigma }=> i ->
                		sigma' = (update sigma x (res_bool i)) ->
                		(x s= a) -[ sigma ]-> sigma'
  | e_vectorB_assign: forall a i x sigma sigma',
                  		a ={ sigma }=> i ->
                  		sigma' = (update sigma x (res_bool i)) ->
                  		(x s= a) -[ sigma ]-> sigma'
	| e_vectorS_decl: forall a i x sigma sigma',
                		a ={ sigma }=> i ->
                		sigma' = (update sigma x (res_str i)) ->
                		(x s= a) -[ sigma ]-> sigma'
  | e_vectorS_assign: forall a i x sigma sigma',
                  		a ={ sigma }=> i ->
                  		sigma' = (update sigma x (res_str i)) ->
                  		(x s= a) -[ sigma ]-> sigma'
	| e_struct: forall s sigma sigma',
							struct s -[ sigma ]-> sigma'
  | e_seq: forall s1 s2 sigma sigma1 sigma2,
           s1 -[ sigma ]-> sigma1 ->
           s2 -[ sigma1 ]-> sigma2 ->
           (s1 ;; s2) -[ sigma ]-> sigma2
  | e_if_then: forall b s sigma,
               ifthen b s -[ sigma ]-> sigma
  | e_if_then_elsetrue: forall b s1 s2 sigma sigma',
                        b ={ sigma }=> true ->
                        s1 -[ sigma ]-> sigma' ->
                        ifthenelse b s1 s2 -[ sigma ]-> sigma'
  | e_if_then_elsefalse: forall b s1 s2 sigma sigma',
                         b ={ sigma }=> false ->
                         s2 -[ sigma ]-> sigma' ->
                         ifthenelse b s1 s2 -[ sigma ]-> sigma'
  | e_whilefalse: forall b s sigma,
                  b ={ sigma }=> false ->
                  while b s -[ sigma ]-> sigma
  | e_whiletrue: forall b s sigma sigma',
                 b ={ sigma }=> true ->
                 (s ;; while b s) -[ sigma ]-> sigma' ->
                 while b s -[ sigma ]-> sigma'
  | e_switch: forall a i c b s sigma sigma',
              a ={ sigma }=> i ->
              b = (Nat.eqb i c) ->
              switch b s -[ sigma ]-> sigma'
  where "s -[ sigma ]-> sigma'" := (eval s sigma sigma').

(*Default values for every data type *)
Definition default_value (n : nat) : Result :=
	match n with
		| 0 => res_nat 0
		| 1 => res_bool false
		| 2 => res_str ""
		| _ => default
	end.

Definition type_declare (s : Stmt) : nat :=
	match s with
		| nat_decl => 0
		| bool_decl => 1
		| str_decl => 2
		| _ => 100
	end.

Definition while_stmt :=
	Nat "i" ::= 0 ;;
  Nat "sum" ::= 0 ;;
  while ("i" <' 6)
        (
           "sum" n= "sum" +' "i" ;;
           "i" n= "i" +' 1
        ).

Compute (eval_fun while_stmt env 100) "sum".

Definition for_stmt :=
	Nat "sum" ::= 0 ;;
  fordo ( Nat "i" ::= 0 -- "i" <' 6 -- "i" n= "i" +' 1 ) {
        	"sum" n= "sum" +' "i"
    		}.

Compute (eval_fun for_stmt env 100) "sum".


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : word 8 }.
Definition format := format_word ∘ data.
Definition invariant (_ : msg) := True.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.