(** * Generation of informations regarding the elements of an SITPN model *)

Require Import common.CoqLib.
Require Import common.GlobalFacts.
Require Import common.ListPlus.
Require Import sitpn.Sitpn.
Require Import sitpn.SitpnTypes.

Require Import common.ListDep.
Require Import common.GlobalTypes.
Require Import String.
Require Import common.StateAndErrorMonad.
Require Import common.ListMonad.
Require Import transformation.Sitpn2HVhdlTypes.
Require Import FunInd.

Section GenSitpnInfos.

  Variable sitpn : Sitpn.

  (* The instantiated state type is [SitpnInfo sitpn] *)

  Definition CompileTimeState := @Mon (Sitpn2HVhdlState sitpn).

  (** ** Informations about transitions. *)

  Section TransitionInfos.

    (** Returns the list of input places of transition [t].

        Correctness: Correct iff all input places of [t] are in the
        returned list, and the returned list has no duplicates. *)

    Definition get_inputs_of_t (t : T sitpn) : CompileTimeState (list (P sitpn)) :=
      (* Tests if a place is an input of t. *)
      let is_input_of_t := (fun p => if (pre p t) then true else false) in
      do Plist <- get_lofPs; Ret (filter is_input_of_t Plist).

    (** Returns the list of output places of transition [t].

        Correctness: Correct iff all output places of [p] are in the
        returned list, and the returned list has no duplicates.

        Does not raise an error if the returned list is nil because it
        doesn't mean that [t] is an isolated transition; however [t] is a
        "source" transition (without input). *)

    Definition get_outputs_of_t (t : T sitpn) : CompileTimeState (list (P sitpn)) :=
      (* Tests if a place is an input of t. *)
      let is_output_of_t := (fun p => if (post t p) then true else false) in
      do Plist <- get_lofPs; Ret (filter is_output_of_t Plist).

    (** Returns the list of conditions associated to transition [t].

    Correctness: Correct iff all conditions associated to [t] are in the
    returned list, and the returned has no duplicates.  *)

    Definition get_conds_of_t (t : T sitpn) : CompileTimeState (list (C sitpn)) :=
      (* Tests if a condition is associated to t. *)
      let is_cond_of_t := (fun c => (match has_C t c with one | mone => true | zero => false end)) in
      do Clist <- get_lofCs; Ret (filter is_cond_of_t Clist).

    (** Computes the information about transition t, and adds it to
        the current state. *)

    Definition add_tinfo (t : T sitpn) : CompileTimeState unit :=
      do inputs_of_t <- get_inputs_of_t t;
      do outputs_of_t <- get_outputs_of_t t;
      if (inputs_of_t ++ outputs_of_t)%list then
        Err ("add_tinfo: Transition " ++ $$t ++ " is an isolated transition.")
      else
        do conds_of_t <- get_conds_of_t t;
        set_tinfo (t, MkTransInfo _ inputs_of_t conds_of_t).

    (** Calls the function [add_tinfo] for each transition of [sitpn], thus
        modifying the current state. *)

    Definition generate_trans_infos : CompileTimeState unit :=
      do Tlist <- get_lofTs; iter add_tinfo Tlist.

  End TransitionInfos.

  (** ** Informations about places. *)

  Section PlaceInfos.

    (** Returns a triplet of lists [(tin, tc, tout)] where [tin] is
        the list of input transitions of [p], [tc] is the list of
        output transitions of [p] that are in conflict, and [tout] is
        the list of output transitions of [p] that are not in
        conflict.

        Correctness: Correct iff all input transitions of [p] are in
        [tin], and [tin] has no duplicate, and all output transitions
        of [p] are in [tc] and [tout], and [tout] and [tc] has no
        duplicate.  *)

    Definition get_neighbors_of_p (p : P sitpn) :
      CompileTimeState (list (T sitpn) * list (T sitpn) * list (T sitpn)) :=

      (* Adds the transition t to the list of input and/or output
         transitions of p. The list of output transitions of p is
         divided between the transitions in conflict [tc], and
         transitions without conflict [tout]. [tc] and [tout] are
         disjoint lists. *)

      let get_neighbor_of_p :=
          (fun (tin_tc_tout : (list (T sitpn) * list (T sitpn) * list (T sitpn))) t =>
             let '(tin, tc, tout) := tin_tc_tout in
             match post t p with
             | Some _ =>
               match pre p t with
               | Some (basic, _) => ((tin ++ [t])%list, (tc ++ [t])%list, tout)
               | Some ((inhibitor|test), _) => ((tin ++ [t])%list, tc, (tout ++ [t])%list)
               | None => ((tin ++ [t])%list, tc, tout)
               end
             | None =>
               match pre p t with
               | Some (basic, _) => (tin, (tc ++ [t])%list, tout)
               | Some ((inhibitor|test), _) => (tin, tc, (tout ++ [t])%list)
               | None => (tin, tc, tout)
               end
             end) in

      (* Iterates over the list of transitions, and builds the couple of
         lists (tinputs, touputs) of p along the way by applying
         function [is_neighbor_of_p].  *)
      do Tlist <- get_lofTs;
      match List.fold_left get_neighbor_of_p Tlist (nil, nil, nil) with
      | (nil, nil, nil) => Err ("get_neighbors_of_p: Place " ++ $$p ++ " is an isolated place.")
      | tin_tc_tout => Ret tin_tc_tout
      end.

    (** Returns the set of actions associated with place [p]. *)

    Definition get_acts_of_p (p : P sitpn) : CompileTimeState (list (A sitpn)) :=

      (* Filters the list of actions of [sitpn]. Keeps only the
         actions associated with place [p].  *)
      do Alist <- get_lofAs; Ret (filter (fun a => has_A p a) Alist).

    (** Functions to solve conflicts in a given conflict group, i.e, a
        set of transitions. *)

    Section ConflictResolution.

      (** Returns [true] if there exists a condition [c] in [conds]
          s.t. [c] is associated [t] and [not c] to [t'], or the other
          way around. Returns [false] otherwise.  *)

      Definition exists_ccond (t t' : T sitpn) (conds : list (C sitpn)) : bool :=
        let check_ccond_of_tt' := (fun c => match has_C t c, has_C t' c with
                                              one, mone | mone, one => true
                                            | _, _ => false
                                            end) in
        if (List.find check_ccond_of_tt' conds) then true else false.

      (** Returns [true] if there exists a condition [c] in the
          intersection of the list of conditions of [t] and [t'] that
          verify [C(c,t) = 1 and C(c,t') = -1] or [C(c,t) = -1 and
          C(c,t') = 1] (i.e, complementary conditions are associated
          to [t] and [t']). *)

      Definition mutex_by_cconds (t t' : T sitpn) : CompileTimeState bool :=
        do tinfo <- get_tinfo t;
        do tinfo' <- get_tinfo t';
        Ret (exists_ccond t t' (inter P1SigEq (P1SigEqdec Nat.eq_dec) (conds tinfo) (conds tinfo'))).

      (** Returns [true] if there exists a place [p] in [places]
          s.t. there exists a [basic] or [test] arc between [p] and
          [t], and an [inhib] arc between [p] and [t'], or the other
          way around. If such arcs exist, the weight of the inhib arc
          must be lower or equal to the weight of the basic or test
          arc. Returns [false] otherwise. *)

      Definition exists_inhib (t t' : T sitpn) (pls : list (P sitpn)) : bool :=
        let check_inhib_mutex :=
            (fun p => match pre p t, pre p t' with
                      | Some ((basic|test), ω), Some (inhibitor, ω')
                      | Some (inhibitor, ω'), Some ((basic|test), ω) =>
                        ω' <=? ω
                      | _, _ => false
                      end)
        in if (List.find check_inhib_mutex pls) then true else false.

      (** Returns [true] if there exists a place [p] in the
         intersection of the list of input places of [t] and [t']
         that mutually exclude [t] and [t'] by mean of an inhibitor
         arc. *)

      Definition mutex_by_inhib (t t' : T sitpn) : CompileTimeState bool :=
        do tinfo <- get_tinfo t;
        do tinfo' <- get_tinfo t';
        Ret (exists_inhib t t' (inter P1SigEq (P1SigEqdec Nat.eq_dec) (pinputs tinfo) (pinputs tinfo'))).

      (** Returns [true] is there exists no means of mutual exclusion
         between transitions [t] and [t']. Returns [false]
         otherwise.  *)

      Definition not_exists_mutex (t t' : T sitpn) : CompileTimeState bool :=
        do mbyinhib <- mutex_by_inhib t t';
        do mbycconds <- mutex_by_cconds t t';
        Ret (negb (mbyinhib || mbycconds)).

      (** Returns [true] if there exists at least one mean of mutual
         exclusion between [t] and all transitions in [cgoft]
         (conflict group of [t]). Returns [false] otherwise.  *)

      Definition all_conflicts_of_t_solved (t : T sitpn) (cgoft : list (T sitpn)) : CompileTimeState bool :=
        do res <- find (not_exists_mutex t) cgoft;
        if res then Ret false else Ret true.

      (** Returns [true] if all conflicts in the conflict group [cg]
          are solved by means of mutual exclusion, or if the conflict
          group is empty and has only one element. Returns [false]
          otherwise.  *)

      Definition all_conflicts_solved_by_mutex (cg : list (T sitpn)) : CompileTimeState bool :=
        do bl <- ListMonad.fold_left
                   (fun '(bprod, l) t => do b <- all_conflicts_of_t_solved t (tl l); Ret (bprod && b, (tl l)))
                   cg (true, cg);
        Ret (fst bl).

      Fixpoint all_conflicts_solved_by_mutex_without_foldl (cg : list (T sitpn)) {struct cg} : CompileTimeState bool :=
        match cg with
        | nil => Ret true
        | t :: tl =>
            (* If all conflicts of [t] are solved, then we can safely
           withdraw it from the conflict group. Indeed, it means
           that all the transitions of the tail are not in conflict
           with [t]. Therefore, [t] is not needed anymore. *)
            do b <- all_conflicts_of_t_solved t tl;
            if b then all_conflicts_solved_by_mutex_without_foldl tl else Ret false
        end.

      (** Injects transition [t] in the list [stranss] depending on
          the level of priority of [t] compared to the elements of the
          list [stranss].

        Returns the new priority-sorted list where [c] has been
        injected.

        Correctness hypotheses: (1) ~In t stranss, (2) NoDup stranss,
        (3) Elements of stranss are ordered by decreasing level of
        priority.

        Correct iff the returned list has no duplicate and its elements
        are ordered by decreasing level of priority. *)

      Fixpoint inject_t (t : T sitpn) (stranss : list (T sitpn)) {struct stranss} :
        CompileTimeState (list (T sitpn)) :=
        match stranss with
        (* If the list of priority-ordered transitions is empty, then
           returns a singleton list where [t] is the element with the
           highest priority. *)
        | [] => Ret [t]

        (* If there is a head element, compares the head element with t
           priority-wise. *)
        | x :: tl =>
            (* If [t] has a higher priority than [x], then puts [t] as the
               head element of [stranss], and returns the list. *)
            if pr_dec t x then Ret (t :: stranss)
            (* If [x] has a higher priority than [t], then tries to
               inject [t] in the list's tail.  *)
            else
                if pr_dec x t then
                  do stranss' <- inject_t t tl; Ret (x :: stranss')
                else
                  (* If [x ⊁ t] and [t ⊁ x] then error because the two
                     elements not comparable, and the priority
                     relation is not a total order over [t ∪ stranss]. *)
                  Err ("inject_t: transitions "
                         ++ $$t ++ " and "
                         ++ $$x ++ " are not comparable with the priority relation.")
        end.

      Functional Scheme inject_t_ind := Induction for inject_t Sort Prop.

      (** Takes a list of transitions [cgroup] (conflict group), and
          returns a new list of transitions where the elements of the
          confict group are ordered by level of firing priority.

          Raises an error if the priority relation is not a strict
          total order over the elements of [cgroup].  *)

      Definition sort_by_priority (cgroup : list (T sitpn)) :
        CompileTimeState (list (T sitpn)) :=
        (* [scgroup] stands for sorted conflict group *)
        fold_left (fun scgroup t => inject_t t scgroup) cgroup [].

    End ConflictResolution.

    (** Returns a PlaceInfo structure containing the information related
      to place [p], a place of [sitpn].

      Error cases :

      - p is an isolated place, i.e it doesn't have neither input nor
        output transitions.

      - the priority relation is not a strict total order over the
        output transitions of t.
     *)

    Definition add_pinfo (p : P sitpn) : CompileTimeState unit :=

      (* Gets the input, conflicting, and output transitions of place p.
         Error: p is an isolated place.
       *)
      do tin_tc_tout <- get_neighbors_of_p p;

      (* Gets the set of actions associated with [p]. *)
      do acts_of_p <- get_acts_of_p p;

      (* If all conflicts in [tc] are not solved by means of mutual
         exclusion, then transitions in [tc] must be sorted out by
         increasing order of priority before setting the PlaceInfo
         structure for place [p].

         Error: the priority relation is not a strict total order over
         the output transitions of p.  *)
      let '(tin, tc, tout) := tin_tc_tout in
      do b <- all_conflicts_solved_by_mutex tc;
      if b then
        set_pinfo (p, MkPlaceInfo _ tin [] (tc ++ tout) acts_of_p)
      else
        do stc <- sort_by_priority tc;
        set_pinfo (p, MkPlaceInfo _ tin stc tout acts_of_p).

    (** Computes information for all p ∈ P, and adds the infos to the
        current state. *)

    Definition generate_place_infos : CompileTimeState unit :=
      do Plist <- get_lofPs; iter add_pinfo Plist.

  End PlaceInfos.

  (** ** Informations about conditions, actions and functions *)

  Section InterpretationInfos.

    (** Returns the list of transitions associated to condition [c]. *)

    Definition get_transs_of_c (c : C sitpn) : CompileTimeState (list (T sitpn)) :=
      let is_trans_of_c := (fun t => (match has_C t c with one | mone => true | zero => false end)) in
      do Tlist <- get_lofTs; Ret (filter is_trans_of_c Tlist).

    (** Computes the information about transition c, and adds it to
        the current state. *)

    Definition add_cinfo (c : C sitpn) : CompileTimeState unit :=
      do transs_of_c <- get_transs_of_c c;
      set_cinfo (c, transs_of_c).

    (** Calls the function [add_cinfo] for each condition of [sitpn], thus
        modifying the current state. *)

    Definition generate_cond_infos : CompileTimeState unit :=
      do Clist <- get_lofCs; iter add_cinfo Clist.

    (** Returns the list of transitions associated to function [f]. *)

    Definition get_transs_of_f (f : F sitpn) : CompileTimeState (list (T sitpn)) :=
      do Tlist <- get_lofTs; Ret (filter (fun t => has_F t f) Tlist).

    (** Computes the information about function f, and adds it to
        the current state. *)

    Definition add_finfo (f : F sitpn) : CompileTimeState unit :=
      do transs_of_f <- get_transs_of_f f;
      set_finfo (f, transs_of_f).

    (** Calls the function [add_finfo] for each function of [sitpn];
        thus modifying the current state. *)

    Definition generate_fun_infos : CompileTimeState unit :=
      do Flist <- get_lofFs; iter add_finfo Flist.

    (** Returns the list of places associated to action [a]. *)

    Definition get_places_of_a (a : A sitpn) : CompileTimeState (list (P sitpn)) :=
      do Plist <- get_lofPs; Ret (filter (fun p => has_A p a) Plist).

    (** Computes the information about action a, and adds it to the
        current state. *)

    Definition add_ainfo (a : A sitpn) : CompileTimeState unit :=
      do places_of_a <- get_places_of_a a;
      set_ainfo (a, places_of_a).

    (** Calls the function [add_ainfo] for each action of
      [sitpn], thus modifying the current state. *)

    Definition generate_action_infos : CompileTimeState unit :=
      do Alist <- get_lofAs; iter add_ainfo Alist.

  End InterpretationInfos.

  (** ** Well-definition of an [Sitpn] *)

  Section CheckWellDefinedSitpn.

    (** Mostly checks that the priority relation is a strict
        order. However, now that the property is a part of the Sitpn
        record type, the check_wd_sitpn is no longer useful. Will
        probably delete it in versions to come. *)

    (** Assuming that x ≻ y, checks that x ≻ z if y ≻ z.  Returns an
        error if x ≻ y and y ≻ z but x ⊁ z.  *)

    Let check_trans (x y z : T sitpn) : CompileTimeState unit :=
      match pr_dec y z, pr_dec x z with
      | left _, right _ => Err ("check_trans: priority relation is not transitive. "
                                  ++ $$x ++ " ≻ " ++ $$y
                                  ++ " and " ++ $$y ++ " ≻ " ++ $$z
                                  ++ " but " ++ $$x ++ " ⊁ " ++ $$z)
      | _, _ => Ret tt
      end.

    (** Assuming that [x ≻ y], checks that if [y ≻ z] then [x ≻ z]
        holds for each [z ∈ trs].  *)

    Definition iter_xy_check_trans (x y : T sitpn) (trs : list (T sitpn)) :
      CompileTimeState unit :=
      iter (check_trans x y) trs.

    (** For each transition [y] in [trs], if [x ≻ y] then calls
        [iter_xy_check_trans] on [x], [y] and [trs∖{y}].  *)

    Definition foreach_x_check_trans (x : T sitpn) (trs : list (T sitpn)) :
      CompileTimeState unit :=
      let f := fun y trs' =>
                 if pr_dec x y
                 then iter_xy_check_trans x y trs'
                 else Ret tt
      in foreach f trs.

    (** Checks that the priority relation is transitive; returns an
        error if not. *)

    Definition check_pr_is_trans :=
      do Tlist <- get_lofTs; foreach foreach_x_check_trans Tlist.

    (** Checks that the priority relation is irreflexive; returns
        an error if not. *)

    Definition check_pr_is_irrefl : CompileTimeState unit :=
      let check_irrefl :=
          (fun t =>
             if pr_dec t t
             then Err ("pr_rel_is_strict_order: priority relation is reflexive for transition "
                         ++ $$t ++ ".")
             else Ret tt) in
      do Tlist <- get_lofTs; iter check_irrefl Tlist.

    (** Checks that the priority relation is a strict order, i.e,
        irreflexive and transitive. *)

    Definition pr_rel_is_strict_order : CompileTimeState unit :=
      do _ <- check_pr_is_irrefl; check_pr_is_trans.

    (** Returns an error if the list of places or transitions of
        [sitpn] are empty, or if the priority relation is not a strict
        order.

        This is a partial checking of the well-definition of an SITPN
        model. The other properties of the well-definition will
        checked all along the transformation (e.g. the SITPN model is
        conflict-free during the generation of place infos, etc.). *)

    Definition check_wd_sitpn : CompileTimeState unit :=
      (* Raises an error if sitpn has an empty set of places or transitions. *)
      if (places sitpn) then Err ("Found an empty set of places.")
      else
        if (transitions sitpn) then Err ("Found an empty set of transitions.")
        else pr_rel_is_strict_order.

    (** *** Well-definition of an [Sitpn] with nodup lists *)

    Definition Innodup2In {A}
               (decA : forall x y : A, {x = y} + {x <> y})
               {l : list A}
               (a : { a : A | In a (nodup decA l) }) : {a : A | In a l}.
      specialize (proj2_sig a) as pf;
        rewrite (nodup_In decA) in pf;
        exact (exist _ (proj1_sig a) pf).
    Defined.

    Definition pre2nodup (pre : P sitpn -> T sitpn -> option (ArcT * natstar)) :=
      fun p t => pre (Innodup2In Nat.eq_dec p) (Innodup2In Nat.eq_dec t).

    Definition post2nodup (post : T sitpn -> P sitpn -> option natstar) :=
      fun t p => post (Innodup2In Nat.eq_dec t) (Innodup2In Nat.eq_dec p).

    Definition M02nodup (M0 : P sitpn -> nat) :=
      fun p => M0 (Innodup2In Nat.eq_dec p).

    Definition Is2nodup (Is : T sitpn -> option TimeInterval) :=
      fun t => Is (Innodup2In Nat.eq_dec t).

    Definition hasCtonodup (has_C : T sitpn -> C sitpn -> MOneZeroOne) :=
      fun t c => has_C (Innodup2In Nat.eq_dec t) (Innodup2In Nat.eq_dec c).

    Definition hasAtonodup (has_A : P sitpn -> A sitpn -> bool) :=
      fun p a => has_A (Innodup2In Nat.eq_dec p) (Innodup2In Nat.eq_dec a).

    Definition hasFtonodup (has_F : T sitpn -> F sitpn -> bool) :=
      fun t f => has_F (Innodup2In Nat.eq_dec t) (Innodup2In Nat.eq_dec f).

    Definition pr2nodup (pr : T sitpn -> T sitpn -> Prop) :=
      fun x y => pr (Innodup2In Nat.eq_dec x) (Innodup2In Nat.eq_dec y).

    (* Definition check_wd_sitpn_nodup : CompileTimeState Sitpn := *)
    (*   (* Raises an error if sitpn has an empty set of places or transitions. *) *)
    (*   if (places sitpn) then Err ("Found an empty set of places.") *)
    (*   else *)
    (*     if (transitions sitpn) then Err ("Found an empty set of transitions.") *)
    (*     else *)
    (*       (* Builds a new [sitpn] where the list of places, transitions, *)
    (*          actions, functions and conditions have no duplicate *)
    (*          element. *) *)
    (*       let sitpn_nodup := *)
    (*           BuildSitpn (nodup Nat.eq_dec (places sitpn)) *)
    (*                      (nodup Nat.eq_dec (transitions sitpn)) *)
    (*                      (pre2nodup (@pre sitpn)) (post2nodup (@post sitpn)) *)
    (*                      (M02nodup (@M0 sitpn)) (Is2nodup (@Is sitpn)) *)
    (*                      (nodup Nat.eq_dec (conditions sitpn)) *)
    (*                      (nodup Nat.eq_dec (actions sitpn)) *)
    (*                      (nodup Nat.eq_dec (functions sitpn)) *)
    (*                      (hasCtonodup (@has_C sitpn)) *)
    (*                      (hasAtonodup (@has_A sitpn)) *)
    (*                      (hasFtonodup (@has_F sitpn)) *)
    (*                      (pr2nodup (@pr sitpn)) *)
    (*       in *)
    (*       (* do _ <- pr_rel_is_strict_order sitpn_nodup; *) *)
    (*       Ret sitpn_nodup. *)

  End CheckWellDefinedSitpn.

End GenSitpnInfos.

(** ** Informations about an [Sitpn] *)

(** Returns an SitpnInfo instance computed from [sitpn]. *)

Definition generate_sitpn_infos (sitpn : Sitpn) :=

  (* Turns the list of places, transitions, conditions, actions and
     functions of [sitpn], into dependently-typed lists, and sets them
     in the compile-time state. *)
  do Plist <- tmap (fun p s => Ret p s) (places sitpn) nat_to_P;
  do Tlist <- tmap (fun t s => Ret t s) (transitions sitpn) nat_to_T;
  do Clist <- tmap (fun c s => Ret c s) (conditions sitpn) nat_to_C;
  do Alist <- tmap (fun a s => Ret a s) (actions sitpn) nat_to_A;
  do Flist <- tmap (fun f s => Ret f s) (functions sitpn) nat_to_F;
  do _ <- set_lofPs Plist;
  do _ <- set_lofTs Tlist;
  do _ <- set_lofCs Clist;
  do _ <- set_lofAs Alist;
  do _ <- set_lofFs Flist;

  (* Call to [generate_trans_infos] must precede the call to
     [generate_place_infos] because the latter uses transition
     informations.  *)
  (* do _ <- check_wd_sitpn sitpn; *)
  do _ <- generate_trans_infos sitpn;
  do _ <- generate_place_infos sitpn;
  do _ <- generate_cond_infos sitpn;
  do _ <- generate_action_infos sitpn;
  generate_fun_infos sitpn.


Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype.
Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Ipdl.Tacs Lib.Dist Big Pars Lib.Set.
Require Import CoinFlip CFold CFSimComp CFReal.

Lemma pars_replace {chan : Type -> Type} (r2 : @ipdl chan) r1 rs :
  pars [:: r1 & rs] =p pars [:: r2 & rs] ->
  pars [:: r1 & rs] =p pars [:: r2 & rs].
  done.
Qed.

Lemma new_pars_replace_elim {chan : Type -> Type} t r1 r2 rs rs' :
  (forall c, @pars chan [:: Out c r1 & rs c] =p pars [:: Out c r1 & rs']) ->
  (forall c, pars [:: Out c r2 & rs c] =p pars [:: Out c r2 & rs']) ->
  (x <- new t ;; pars [:: Out x r1 & rs x]) =p (x <- new t ;; pars [:: Out x r2 & rs x]).
  intros.
  etransitivity.
  apply EqCongNew => c_.
  rewrite H.
  apply EqRefl.
  symmetry.
  etransitivity.
  apply EqCongNew => c.
  rewrite H0.
  apply EqRefl.
  rewrite new_pars_remove; rewrite //=.
  rewrite new_pars_remove; rewrite //=.
Qed.
Open Scope bool_scope.

Lemma CFRealIdealE {chan : Type -> Type} (k : nat) {n}
           (honest : pred 'I_(n.+2))
           (out advCommit : (n.+2).-tuple (chan k.-bv))
           (advOpen : (n.+2).-tuple (chan unit))
           (advCommitted : (n.+2).-tuple ((n.+2).-tuple (chan unit)))
           (advOpened : (n.+2).-tuple ((n.+2).-tuple (chan k.-bv))) :
  ~~ honest ord0 ->
  honest ord_max ->
  CFRealSimpl k honest out advCommit advOpen advCommitted advOpened =p
  SimComp_simpl7 k honest advCommit advOpen advCommitted advOpened out.
  intros.
  rewrite /CFRealSimpl.
  rewrite /SimComp_simpl7.

  setoid_rewrite (@newvec_newvec _ _ _ unit unit) at 1.
  rewrite newvec_newvec.
  apply EqCongNew_vec => open .
  rewrite newvec_newvec.
  apply EqCongNew_vec => committed .
  rewrite newvec_newvec.
  apply EqCongNew_vec => opened .
  rotate_news.
  apply EqCongNew_vec => sum_commits .
  apply EqCongNew_vec => sum_open .
  apply EqCongNew_vec => commit .
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
  apply EqProt_big_r; intros; apply EqCongReact; r_swap 0 1; done.
  swap_tac 0 3.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 3.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
  rewrite bigpar_mkcond.
  swap_tac 0 1.
  rewrite bigpar_mkcond.
  rewrite -par_in_pars.
  rewrite -bigpar_par.
  apply pars_cons_cong; rewrite //=.
  apply EqProt_big_r; intros.
  rewrite /Sim_CFParty.
  destruct (honest x); simpl.
  rewrite -eq_0par.
  apply EqCongNew_vec => v1 .
  apply EqCongNew_vec => v2 .
  align.
  rewrite -eq_par0.
  done.
Qed.

Lemma CoinFlip_main {chan : Type -> Type} (k : nat) {n}
           (honest : pred 'I_(n.+2))
           (out advCommit : (n.+2).-tuple (chan k.-bv))
           (advOpen : (n.+2).-tuple (chan unit))
           (advCommitted : (n.+2).-tuple ((n.+2).-tuple (chan unit)))
           (advOpened : (n.+2).-tuple ((n.+2).-tuple (chan k.-bv))) :
  ~~ honest ord0 ->
  honest ord_max ->
  CFReal k _ honest out advCommit advOpen advCommitted advOpened =p
    leak <- new k.-bv ;;
    ok <- new unit ;;
    pars [::
            Sim k honest leak ok advCommit advOpen advCommitted advOpened;
            CFIdeal k _ honest leak ok out
                 ].
  intros.
  rewrite CFRealSimplE.
  symmetry.
  etransitivity.
  instantiate (1 := SimComp k honest advCommit advOpen advCommitted advOpened out).
  done.

  rewrite SimComp_E1.
  rewrite SimComp_simpl2E //=.
  rewrite SimComp_simpl3E //=.
  rewrite SimComp_simpl4E //=.
  rewrite SimComp_simpl5E //=.
  rewrite SimComp_simpl6E //=.
  rewrite SimComp_simpl7E //=.
  rewrite CFRealIdealE //=.
Qed.


Require Import Coq.Lists.List.
Import ListNotations.

Require Import Tactics.
Require Import Axioms.
Require Import Sigma.
Require Import Equality.
Require Import Sequence.
Require Import Relation.
Require Import Ordinal.
Require Import Syntax.
Require Import SimpSub.
Require Import Dynamic.
Require Import Ofe.
Require Import Uniform.
Require Import Intensional.
Require Import Candidate.
Require Import System.
Require Import Semantics.
Require Import SemanticsKnot.
Require Import Judgement.
Require Import Hygiene.
Require Import ProperClosed.
Require Import ProperFun.
Require Import Shut.

Require Import ContextHygiene.
Require Import MapTerm.

Lemma cloctx_index :
  forall object i G (h : @hyp object),
    index i G h
    -> cloctx G
    -> hygieneh (fun j => j < length G - i - 1) h.
Proof.
intros object i G h Hindex.
induct Hindex.

(* 0 *)
{
intros h G Hcl.
cbn.
invertc Hcl.
intros _ Hcl.
rewrite -> ctxpred_length in Hcl.
eapply hygieneh_weaken; eauto.
intros j Hj.
omega.
}

(* S *)
{
intros j h' G h _ IH Hcl.
invertc Hcl.
intros Hcl _.
cbn.
apply IH; auto.
}
Qed.

Lemma seqctx_index :
  forall i s s' G j h,
    seqctx i s s' G
    -> index j G h
    -> seqhyp i (project s j) (project s' j) (substh (compose (sh (S j)) s) h) (substh (compose (sh (S j)) s') h).
Proof.
intros i s s' G j h Hseq Hindex.
revert s s' Hseq.
induct Hindex.

(* 0 *)
{
intros h G s1 s2 Hseq.
invert Hseq; [].
intros m1 m2 s1' s2' Hss Hm <- <-.
simpsub.
auto.
}

(* S *)
{
intros j h' G h Hindex IH s s' Hss.
invertc Hss; [].
intros m1 m2 s1' s2' Hss' _ <- <-.
simpsub.
auto.
}
Qed.

Lemma sound_hyp_tm_pre :
  forall G i a,
    index i G (hyp_tm a)
    -> seq G (deq (var i) (var i) (subst (sh (S i)) a)).
Proof.
intros G j a Hindex.
apply seq_i.
intros i s s' Hs.
so (seqctx_index _#6 (pwctx_impl_seqctx _#4 Hs) Hindex) as H.
simpsubin H.
(* For some reason, inversion is fouling up (sh (S j)), so we'll hide the ball. *)
remember (sh (S j)) as shsj eqn:Heqshsj.
invertc H.
intros R Hal Har Hm.
subst shsj.
exists R.
simpsub.
do2 4 split; auto.
Qed.

Lemma sound_hyp_tm :
  forall G i a,
    index i G (hyp_tm a)
    -> pseq G (deq (var i) (var i) (subst (sh (S i)) a)).
Proof.
intros G i a Hindex.
exists 0.
intros j _.
apply sound_hyp_tm_pre.
apply index_app_left; auto.
Qed.

Lemma sound_hyp_tp_pre :
  forall G i,
    index i G hyp_tp
    -> seq G (deqtype (var i) (var i)).
Proof.
intros G j Hindex.
rewrite -> seq_eqtype.
intros i s s' Hs.
so (seqctx_index _#6 (pwctx_impl_seqctx _#4 Hs) Hindex) as H.
simpsubin H.
invertc H.
intros R Hal Har.
exists R.
simpsub.
do2 3 split; auto.
Qed.

Lemma sound_hyp_tp :
  forall G i,
    index i G hyp_tp
    -> pseq G (deqtype (var i) (var i)).
Proof.
intros G i Hindex.
exists 0.
intros j _.
apply sound_hyp_tp_pre.
apply index_app_left; auto.
Qed.


Require Import Coq.Init.Wf Coq.Numbers.BinNums.
Require Import Coq.Arith.Arith.
Require Import Coq.FSets.FMapPositive.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.BaseTypes.
Require Export Fiat.Parsers.ContextFreeGrammar.Fix.Definitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Properties.
Require Import Fiat.Common.FMapExtensions.Wf.
Require Import Fiat.Common.
Require Import Fiat.Common.OptionFacts.
Module PositiveMapExtensions := FMapExtensionsWf PositiveMap.
Require Import Fiat.Common.SetoidInstances. (* must come after the above for instance priority *)

Set Implicit Arguments.
Local Open Scope grammar_fixedpoint_scope.

Section grammar_fixedpoint.
  Context {Char : Type}.

  Context (gdata : grammar_fixedpoint_data).

  Definition aggregate_state := PositiveMap.t (state gdata).

  Local Notation default_value := ⊤ (only parsing).

  Definition lookup_state (st : aggregate_state) (nt : default_nonterminal_carrierT)
    : state gdata
    := PositiveMapExtensions.find_default default_value (nonterminal_to_positive nt) st.

  Notation from_aggregate_state := lookup_state (only parsing).

  Definition aggregate_state_le : aggregate_state -> aggregate_state -> bool
    := PositiveMapExtensions.lift_leb state_le default_value.
  Definition aggregate_state_eq : aggregate_state -> aggregate_state -> bool
    := PositiveMapExtensions.lift_eqb state_beq default_value.
  Definition aggregate_state_lt (v1 v2 : aggregate_state) : bool
    := PositiveMapExtensions.lift_ltb state_beq state_le default_value v1 v2.

  Lemma PositiveMap_elements_iff {A m k v}
    : @PositiveMap.find A k m = Some v <-> In (k, v) (PositiveMap.elements m).
  Proof.
    rewrite PositiveMapExtensions.elements_iff_find.
    rewrite InA_alt; unfold PositiveMap.eq_key_elt, PositiveMap.E.eq; simpl.
    split; [ intros [[? ?] [[? ?] ?]] | intro H; exists (k, v) ];
      subst; repeat split; assumption.
  Qed.

  Lemma PositiveMap_elements_iff' {A m kv}
    : @PositiveMap.find A (fst kv) m = Some (snd kv) <-> In kv (PositiveMap.elements m).
  Proof.
    destruct kv; apply PositiveMap_elements_iff.
  Qed.

  Create HintDb aggregate_step_db discriminated.
  Hint Rewrite PositiveMap.fold_1 PositiveMap.gmapi nonterminal_to_positive_to_nonterminal positive_to_nonterminal_to_positive PositiveMap.gempty PositiveMapAdditionalFacts.gsspec (@state_beq_refl _ gdata) orb_true_iff orb_true_r orb_false_iff (@state_le_bottom_eq_bottom _ gdata) (@no_state_lt_bottom _ gdata) (@state_le_bottom_eq_bottom _ gdata) (@state_ge_top_eq_top _ gdata) (@bottom_lub_r _ gdata) (@bottom_lub_l _ gdata) (@top_lub_r _ gdata) (@top_lub_l _ gdata) (fun a b => @least_upper_bound_correct_l _ gdata a b : _ = true) (fun a b => @least_upper_bound_correct_r _ gdata a b : _ = true) (fun s => @bottom_bottom _ gdata s : _ = true) (fun s => @top_top _ gdata s : _ = true) beq_nat_true_iff @PositiveMapExtensions.lift_brelation_iff : aggregate_step_db.
  Hint Rewrite <- beq_nat_refl : aggregate_step_db.
  Hint Rewrite PositiveMapExtensions.map2_1bis_for_rewrite using reflexivity : aggregate_step_db.
  Hint Rewrite PositiveMapExtensions.fold_andb_true : aggregate_step_db.

  Local Ltac fold_andb_t_step :=
    idtac;
    match goal with
    | _ => progress intros
    | _ => progress subst
    | _ => congruence
    | _ => progress unfold PositiveMap.key in *
    | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
    | [ H : Some ?b <> Some false |- _ ] => destruct b eqn:?; [ clear H | congruence ]
    | [ H : (⊥ =b ?s) = false, H' : (⊥ < ?s) = false |- _ ]
      => let H'' := fresh in
         pose proof (bottom_bottom s) as H''; setoid_rewrite orb_true_iff in H''; destruct H''; congruence
    | [ H : context[PositiveMap.fold _ _ _ = true] |- _ ]
      => setoid_rewrite PositiveMapExtensions.fold_andb_true in H
    | [ |- context[PositiveMap.fold _ _ _ = true] ]
      => setoid_rewrite PositiveMapExtensions.fold_andb_true
    | [ |- true = false ] => symmetry
    | [ H : PositiveMap.fold _ _ _ = false |- false = true ]
      => rewrite <- H; clear H
    | [ H : context[PositiveMap.find _ (PositiveMap.map2 ?f _ _)] |- _ ]
      => setoid_rewrite (@PositiveMapExtensions.map2_1bis_for_rewrite _ _ _ f eq_refl) in H
    | [ |- context[PositiveMap.find _ (PositiveMap.map2 ?f _ _)] ]
      => setoid_rewrite (@PositiveMapExtensions.map2_1bis_for_rewrite _ _ _ f eq_refl)
    | [ H : context[PositiveMapExtensions.lift_brelation] |- _ ]
      => setoid_rewrite PositiveMapExtensions.lift_brelation_iff in H
    | [ |- context[PositiveMapExtensions.lift_brelation] ]
      => setoid_rewrite PositiveMapExtensions.lift_brelation_iff
    | [ H : ?x = _, H' : context[?x] |- _ ] => setoid_rewrite H in H'
    | [ H : ?x = _ |- context[?x] ] => setoid_rewrite H
    | [ H : and _ _ |- _ ] => destruct H
    | [ H : pointwise_relation _ eq ?x ?y, H' : context[step_constraints _ ?x] |- _ ]
      => rewrite H in H'
    | _ => progress autorewrite with aggregate_step_db in *
    | [ H : forall k : positive, _ |- _ ]
      => repeat match goal with
                | [ k' : positive |- _ ]
                  => unique pose proof (H k')
                | [ |- context[PositiveMap.find ?k' _] ]
                  => unique pose proof (H k')
                | [ _ : context[PositiveMap.find ?k' _] |- _ ]
                  => unique pose proof (H k')
                end;
         clear H
    | _ => progress simpl in *
    | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
    | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
    | [ |- _ <> _ ] => intro
    | [ H : or _ _ |- _ ] => destruct H
    | [ |- and _ _ ] => split
    | [ H : (?x < ?y) = true, H' : (?y < ?z) = true |- _ ]
      => unique pose proof (state_lt_Transitive H H' : (x < z) = true)
    | [ H : is_true (?x =b ?y) |- _ ]
      => rewrite H in *; clear x H
    | [ H : is_true (?x =b ?y) |- _ ]
      => rewrite <- H in *; clear x H
    | [ H : ?R ?x ?y |- _ ]
      => is_var x; rewrite H in *; clear x H
    | [ H : ?R ?x ?y |- _ ]
      => is_var y; rewrite <- H in *; clear y H
    end.
  Local Ltac fold_andb_t := repeat fold_andb_t_step.

  Global Instance aggregate_state_eq_Reflexive : Reflexive aggregate_state_eq | 1 := _.
  Global Instance aggregate_state_eq_Symmetric : Symmetric aggregate_state_eq | 1 := _.
  Global Instance aggregate_state_eq_Transitive : Transitive aggregate_state_eq | 1 := _.
  Global Instance aggregate_state_le_Reflexive : Reflexive aggregate_state_le | 1 := _.
  Global Instance aggregate_state_le_Transitive : Transitive aggregate_state_le | 1 := _.
  Global Instance aggregate_state_eq_Proper_Equal
    : Proper (@PositiveMap.Equal _ ==> @PositiveMap.Equal _ ==> eq) aggregate_state_eq | 100
    := _.
  Global Instance aggregate_state_le_Proper_Equal
    : Proper (@PositiveMap.Equal _ ==> @PositiveMap.Equal _ ==> eq) aggregate_state_le | 100
    := _.
  Global Instance aggregate_state_lt_Proper_Equal
    : Proper (@PositiveMap.Equal _ ==> @PositiveMap.Equal _ ==> eq) aggregate_state_lt | 100
    := _.
  Global Instance aggregate_state_le_Proper
    : Proper (aggregate_state_eq ==> aggregate_state_eq ==> eq) aggregate_state_le | 1
    := _.
  Global Instance aggregate_state_lt_Proper
    : Proper (aggregate_state_eq ==> aggregate_state_eq ==> eq) aggregate_state_lt | 1
    := _.

  Definition aggregate_state_lub_f : option (state gdata) -> option (state gdata) -> option (state gdata)
      := PositiveMapExtensions.defaulted_f default_value default_value least_upper_bound.

  Definition aggregate_state_lub (v1 v2 : aggregate_state) : aggregate_state
    := PositiveMap.map2 aggregate_state_lub_f v1 v2.

  Definition aggregate_prestep (v : aggregate_state) : aggregate_state
    := let helper := step_constraints gdata (from_aggregate_state v) in
       PositiveMap.mapi (fun nt => helper (positive_to_nonterminal nt)) v.

  Definition aggregate_step (v : aggregate_state) : aggregate_state
    := aggregate_state_lub v (aggregate_prestep v).

  Definition aggregate_state_lub_correct (v1 v2 : aggregate_state)
    : aggregate_state_le v1 (aggregate_state_lub v1 v2)
      /\ aggregate_state_le v2 (aggregate_state_lub v1 v2).
  Proof.
    unfold aggregate_state_le, aggregate_state_lub, aggregate_state_lub_f.
    setoid_rewrite PositiveMapExtensions.lift_brelation_iff.
    unfold PositiveMapExtensions.defaulted_f.
    repeat match goal with
           | [ |- and _ _ ] => split
           | _ => intro
           | _ => progress subst
           | [ H : ?x = _ |- context[?x] ] => setoid_rewrite H
           | [ H : ?x = _, H' : context[?x] |- _ ] => setoid_rewrite H in H'
           | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
           | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
           | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
           | [ |- is_true (?R ?x ?x) ] => reflexivity
           | _ => apply top_top
           | _ => apply least_upper_bound_correct_l
           | _ => apply least_upper_bound_correct_r
           | _ => congruence
           | [ H : _ |- _ ] => setoid_rewrite PositiveMapExtensions.map2_1bis_for_rewrite in H; [ | reflexivity.. ]
           end.
  Qed.

  Lemma find_aggregate_state_lub a b k
    : PositiveMap.find k (aggregate_state_lub a b)
      = aggregate_state_lub_f (PositiveMap.find k a) (PositiveMap.find k b).
  Proof.
    unfold aggregate_state_lub.
    fold_andb_t.
  Qed.

  Lemma nothing_empty_lt v : ~aggregate_state_lt (PositiveMap.empty _) v.
  Proof.
    setoid_rewrite PositiveMapExtensions.empty_ltb_nothing; [ congruence | ].
    setoid_rewrite state_ge_top_eq_top.
    intros; symmetry; assumption.
  Qed.

  Lemma aggregate_state_lt_wf : well_founded (Basics.flip aggregate_state_lt).
  Proof.
    apply PositiveMapExtensions.well_founded_lift_gtb.
    { eapply Wf.well_founded_subrelation; [ | eexact (@state_gt_wf _ gdata) ].
      unfold flip, state_le; intros x y H.
      destruct (y < x); [ reflexivity | simpl in * ].
      destruct (y =b x) eqn:Heqb; simpl in *; assumption. }
    { apply top_top. }
    { exact _. }
    { exact _. }
    { exact _. }
    { exact _. }
  Defined.

  Section wrap_wf.
    Context {A R} (Rwf : @well_founded A R).

    Definition lt_wf_idx_step
               (lt_wf_idx : nat -> well_founded R)
               (n : nat)
      : well_founded R.
    Proof.
      destruct n.
      { clear -Rwf; abstract apply Rwf. }
      { constructor; intros; apply lt_wf_idx; assumption. }
    Defined.

    Fixpoint lt_wf_idx (n : nat) : well_founded R
      := lt_wf_idx_step (@lt_wf_idx) n.
  End wrap_wf.

  Definition aggregate_state_lt_wf_idx (n : nat) : well_founded (Basics.flip aggregate_state_lt)
    := lt_wf_idx aggregate_state_lt_wf n.

  Definition step_lt {st}
    : aggregate_state_eq st (aggregate_step st) = false -> Basics.flip aggregate_state_lt (aggregate_step st) st.
  Proof.
    unfold Basics.flip.
    intros pf.
    destruct (aggregate_state_lt st (aggregate_step st)) eqn:H; [ reflexivity | exfalso ].
    unfold aggregate_step in *.
    pose proof (proj1 (aggregate_state_lub_correct st (aggregate_prestep st))) as H'.
    unfold aggregate_state_lt, PositiveMapExtensions.lift_ltb in *.
    fold aggregate_state_le in *.
    fold aggregate_state_eq in *.
    generalize dependent (aggregate_state_le st (aggregate_state_lub st (aggregate_prestep st))).
    generalize dependent (aggregate_state_eq st (aggregate_state_lub st (aggregate_prestep st))).
    clear.
    abstract (
        intros [] ? []; simpl; intros; congruence
      ).
  Defined.

  Global Instance aggregate_state_lub_Proper
    : Proper (aggregate_state_eq ==> aggregate_state_eq ==> aggregate_state_eq) aggregate_state_lub | 1.
  Proof.
    unfold aggregate_state_eq, aggregate_state_lub, aggregate_state_lub_f.
    refine PositiveMapExtensions.map2_defaulted_Proper_lift_brelation.
  Qed.

  Global Instance from_aggregate_state_Proper
    : Proper (aggregate_state_eq ==> eq ==> state_beq) from_aggregate_state | 1.
  Proof.
    unfold aggregate_state_eq, PositiveMapExtensions.lift_eqb, from_aggregate_state, PositiveMapExtensions.find_default, option_rect; repeat intro; fold_andb_t.
  Qed.

  Global Instance aggregate_step_Proper
    : Proper (aggregate_state_eq ==> aggregate_state_eq) aggregate_step | 1.
  Proof.
    intros x y H.
    assert (H' : pointwise_relation _ state_beq (from_aggregate_state x) (from_aggregate_state y)) by (intro; setoid_rewrite H; reflexivity).
    unfold aggregate_state_eq, PositiveMapExtensions.lift_eqb, aggregate_step, aggregate_state_lub, aggregate_prestep in *.
    setoid_rewrite PositiveMapExtensions.lift_brelation_iff in H.
    setoid_rewrite PositiveMapExtensions.lift_brelation_iff.
    repeat setoid_rewrite fold_option_rect_nodep.
    first [ setoid_rewrite (PositiveMapExtensions.map2_1bis_for_rewrite _ _ _ _ eq_refl)
          | setoid_rewrite (PositiveMapExtensions.map2_1bis_for_rewrite _ _ _ _ _); [ | reflexivity.. ] ].
    setoid_rewrite PositiveMap.gmapi.
    unfold option_rect_nodep, option_map.
    intro k; specialize (H k).
    generalize dependent (lookup_state x); generalize dependent (lookup_state y); intros;
      do 2 edestruct PositiveMap.find;
      fold_andb_t.
  Qed.

  Lemma lookup_state_aggregate_state_lub a b nt
    : lookup_state (aggregate_state_lub a b) nt = (lookup_state a nt ⊔ lookup_state b nt).
  Proof.
    unfold lookup_state, PositiveMapExtensions.find_default.
    rewrite find_aggregate_state_lub.
    unfold option_rect, aggregate_state_lub_f.
    fold_andb_t.
  Qed.

  Global Instance lookup_state_Proper
    : Proper (aggregate_state_eq ==> eq ==> state_beq) lookup_state | 1.
  Proof.
    unfold aggregate_state_eq, PositiveMapExtensions.lift_eqb, lookup_state, PositiveMapExtensions.find_default, option_rect; repeat intro; fold_andb_t.
  Qed.

  Lemma find_aggregate_prestep st nt
    : PositiveMap.find nt (aggregate_prestep st)
      = option_map (step_constraints gdata (lookup_state st) (positive_to_nonterminal nt))
                   (PositiveMap.find nt st).
  Proof.
    unfold aggregate_prestep.
    autorewrite with aggregate_step_db.
    unfold from_aggregate_state, option_rect, option_map.
    edestruct PositiveMap.find; reflexivity.
  Qed.

  Lemma find_aggregate_step st nt
    : PositiveMap.find nt (aggregate_step st)
      = option_map (fun v => v ⊔ step_constraints gdata (lookup_state st) (positive_to_nonterminal nt) v)
                   (PositiveMap.find nt st).
  Proof.
    unfold aggregate_step.
    rewrite find_aggregate_state_lub, find_aggregate_prestep.
    edestruct PositiveMap.find; reflexivity.
  Qed.

  Lemma lookup_state_aggregate_prestep st nt
    : lookup_state (aggregate_prestep st) nt
      = option_rect (fun _ => _)
                    (fun _ => step_constraints gdata (lookup_state st) nt (lookup_state st nt))
                    default_value
                    (PositiveMap.find (nonterminal_to_positive nt) st).
  Proof.
    unfold lookup_state.
    unfold PositiveMapExtensions.find_default.
    rewrite find_aggregate_prestep.
    unfold lookup_state.
    rewrite nonterminal_to_positive_to_nonterminal.
    unfold PositiveMapExtensions.find_default.
    unfold state in *; simpl in *.
    edestruct PositiveMap.find; reflexivity.
  Qed.

  Lemma lookup_state_aggregate_step st nt
    : lookup_state (aggregate_step st) nt
      = option_rect (fun _ => _)
                    (fun s => s ⊔ step_constraints gdata (lookup_state st) nt (lookup_state st nt))
                    default_value
                    (PositiveMap.find (nonterminal_to_positive nt) st).
  Proof.
    unfold lookup_state, PositiveMapExtensions.find_default.
    rewrite find_aggregate_step.
    unfold lookup_state, PositiveMapExtensions.find_default.
    rewrite nonterminal_to_positive_to_nonterminal.
    unfold state in *; simpl in *.
    edestruct PositiveMap.find; reflexivity.
  Qed.

  Section with_initial.
    Context (initial_nonterminals_data : list default_nonterminal_carrierT).

    Definition aggregate_state_max : aggregate_state
      := List.fold_right
           (fun nt st => PositiveMap.add (nonterminal_to_positive nt) ⊥ st)
           (PositiveMap.empty _)
           initial_nonterminals_data.

    Definition pre_Fix_grammar_helper : aggregate_state -> aggregate_state
      := Fix
           (aggregate_state_lt_wf_idx (10 * List.length initial_nonterminals_data))
           (fun _ => aggregate_state)
           (fun st Fix_grammar_internal
            => let st' := aggregate_step st in
               match Sumbool.sumbool_of_bool (aggregate_state_eq st st') with
               | left pf => st
               | right pf => Fix_grammar_internal st' (step_lt pf)
               end).

    Definition pre_Fix_grammar : aggregate_state
      := pre_Fix_grammar_helper aggregate_state_max.

    Lemma pre_Fix_grammar_helper_fixed st (H : aggregate_state_eq st (aggregate_step st))
      : aggregate_state_eq st (pre_Fix_grammar_helper st).
    Proof.
      unfold pre_Fix_grammar_helper.
      rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
      edestruct dec; [ | congruence ].
      reflexivity.
    Qed.

    Lemma pre_Fix_grammar_helper_commute v
      : aggregate_state_eq (pre_Fix_grammar_helper (aggregate_step v))
                           (aggregate_step (pre_Fix_grammar_helper v)).
    Proof.
      unfold pre_Fix_grammar_helper.
      induction (aggregate_state_lt_wf v) as [v H IHv].
      rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial);
        symmetry;
        rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial);
        symmetry.
      do 2 edestruct dec; try reflexivity;
        repeat match goal with
               | [ H : ?x = true |- _ ] => change (is_true x) in H
               end.
      { fold @pre_Fix_grammar_helper in *.
        rewrite <- pre_Fix_grammar_helper_fixed by assumption.
        assumption. }
      { match goal with
        | [ H : is_true (aggregate_state_eq ?x ?y), H' : context[?x] |- _ ]
          => rewrite <- H in H'
        end.
        congruence. }
      { apply IHv.
        apply step_lt; assumption. }
    Qed.

    Global Instance aggregate_state_eq_Proper_eq
      : Proper (eq ==> eq ==> eq) aggregate_state_eq
      := _.
    Global Instance aggregate_step_Proper_eq
      : Proper (eq ==> eq) aggregate_step
      := _.

    Lemma pre_Fix_grammar_fixedpoint
      : aggregate_state_eq pre_Fix_grammar (aggregate_step pre_Fix_grammar).
    Proof.
      unfold pre_Fix_grammar, pre_Fix_grammar_helper.
      generalize aggregate_state_max; intro a.
      rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
      edestruct dec as [pf|pf].
      { rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
        edestruct dec; [ | congruence ].
        assumption. }
      { induction (aggregate_state_lt_wf a) as [?? IH].
        rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
        symmetry;
          rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial);
          symmetry.
        rewrite pf; simpl.
        edestruct dec as [pf'|pf'].
        { rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
          rewrite pf'; simpl.
          assumption. }
        { apply IH; try assumption; []; clear IH.
          unfold Basics.flip, aggregate_state_lt, PositiveMapExtensions.lift_ltb.
          setoid_rewrite pf; simpl; rewrite andb_true_r.
          pose proof (fun x => aggregate_state_lub_correct x (aggregate_prestep x)) as H'.
          unfold aggregate_step in *.
          edestruct H'; eassumption. } }
    Qed.

    Lemma find_aggregate_state_max_rdp_spec k v
      : PositiveMap.find k aggregate_state_max = Some v
        <-> (v = ⊥ /\ rdp_list_is_valid_nonterminal initial_nonterminals_data (positive_to_nonterminal k)).
    Proof.
      unfold aggregate_state_max in *.
      generalize dependent initial_nonterminals_data; intros ls.
      induction ls as [|x xs IHxs].
      { simpl in *.
        autorewrite with aggregate_step_db in *.
        intuition (tauto || congruence || eauto). }
      { simpl in *.
        autorewrite with aggregate_step_db in *.
        edestruct PositiveMap.E.eq_dec; subst;
          autorewrite with aggregate_step_db in *;
          auto using eq_refl with nocore.
        { repeat intuition (congruence || subst || eauto). }
        { intuition (congruence || subst || eauto).
          { apply orb_true_iff; intuition. }
          { do 2 match goal with
                 | [ H : is_true (orb _ _) |- _ ] => apply orb_true_iff in H
                 | [ H : _ |- _ ] => setoid_rewrite beq_nat_true_iff in H
                 end.
            repeat intuition (congruence || subst || (autorewrite with aggregate_step_db in * ) || eauto). } } }
    Qed.

    Lemma find_aggregate_state_max k v
      : PositiveMap.find k aggregate_state_max = Some v
        -> PositiveMap.find k aggregate_state_max = Some ⊥.
    Proof.
      setoid_rewrite find_aggregate_state_max_rdp_spec.
      tauto.
    Qed.

    Lemma find_aggregate_state_max_exact k
      : PositiveMap.find k aggregate_state_max
        = if rdp_list_is_valid_nonterminal initial_nonterminals_data (positive_to_nonterminal k)
          then Some ⊥
          else None.
    Proof.
      pose proof (find_aggregate_state_max_rdp_spec k) as H;
        unfold is_true in *; split_iff; break_match.
      { intuition eauto. }
      { edestruct PositiveMap.find; [ | reflexivity ].
        specialize_all_ways; specialize_by (exact eq_refl).
        intuition congruence. }
    Qed.
  End with_initial.

  Section with_grammar.
    Context (G : pregrammar' Char).

    Let predata := @rdp_list_predata _ G.
    Local Existing Instance predata.

    Definition find_aggregate_state_max_spec k v
      : PositiveMap.find k (aggregate_state_max initial_nonterminals_data) = Some v
        <-> (v = ⊥ /\ is_valid_nonterminal initial_nonterminals_data (positive_to_nonterminal k))
      := find_aggregate_state_max_rdp_spec initial_nonterminals_data k v.

    Hint Rewrite find_aggregate_state_max_spec : aggregate_step_db.

    Lemma lookup_state_aggregate_state_max nt
      : lookup_state (aggregate_state_max initial_nonterminals_data) nt
        = if is_valid_nonterminal initial_nonterminals_data nt
          then ⊥
          else default_value.
    Proof.
      unfold lookup_state, PositiveMapExtensions.find_default, option_rect.
      destruct (PositiveMap.find (nonterminal_to_positive nt) (aggregate_state_max (@initial_nonterminals_data _ predata))) eqn:H; [ | ];
        setoid_rewrite H.
      { simpl in *.
        apply find_aggregate_state_max_spec in H.
        rewrite nonterminal_to_positive_to_nonterminal in H.
        destruct H as [? H']; subst; simpl in *; rewrite H'; intuition. }
      { match goal with |- context[if ?e then _ else _] => destruct e eqn:H' end;
        [ | reflexivity ].
        pose proof (find_aggregate_state_max_spec (nonterminal_to_positive nt) ⊥) as H''.
        rewrite nonterminal_to_positive_to_nonterminal, H' in H''.
        destruct H'' as [_ H''].
        rewrite H'' in H by intuition.
        congruence. }
    Qed.

    Lemma find_pre_Fix_grammar (nt : default_nonterminal_carrierT)
      : is_valid_nonterminal initial_nonterminals_data nt
        <-> PositiveMap.find (nonterminal_to_positive nt) (pre_Fix_grammar initial_nonterminals_data) <> None.
    Proof.
      unfold pre_Fix_grammar, pre_Fix_grammar_helper.
      assert (H : PositiveMap.find (nonterminal_to_positive nt) (aggregate_state_max initial_nonterminals_data) <> None
                  <-> is_valid_nonterminal initial_nonterminals_data nt).
      { pose proof (find_aggregate_state_max_spec (nonterminal_to_positive nt)) as H.
        rewrite nonterminal_to_positive_to_nonterminal in H.
        edestruct PositiveMap.find.
        { edestruct H as [H0 H1]; clear H.
          intuition congruence. }
        { specialize (H ⊥).
          intuition congruence. } }
      rewrite <- H; clear H.
      generalize dependent (aggregate_state_max initial_nonterminals_data); intro a; intros.
      induction (aggregate_state_lt_wf a) as [?? IH].
      rewrite Init.Wf.Fix_eq at 1 by (intros; edestruct dec; trivial).
      edestruct dec as [pf|pf]; [ reflexivity | ].
      rewrite <- IH by (apply step_lt; assumption).
      rewrite find_aggregate_step.
      unfold option_map; split; fold_andb_t.
    Qed.

    Lemma find_pre_Fix_grammar_to_lookup_state (nt : default_nonterminal_carrierT)
      : PositiveMap.find (nonterminal_to_positive nt) (pre_Fix_grammar initial_nonterminals_data)
        = if is_valid_nonterminal initial_nonterminals_data nt
          then Some (lookup_state (pre_Fix_grammar initial_nonterminals_data) nt)
          else None.
    Proof.
      let v := match goal with |- context[if ?v then _ else _] => v end in
      destruct v eqn:Hvalid.
      { apply find_pre_Fix_grammar in Hvalid.
        unfold lookup_state, PositiveMapExtensions.find_default, state in *; simpl in *.
        edestruct PositiveMap.find;
          [ reflexivity | congruence ]. }
      { destruct (PositiveMap.find (nonterminal_to_positive nt) (pre_Fix_grammar (@initial_nonterminals_data _ predata))) eqn:H; [ | reflexivity ].
        rewrite (proj2 (find_pre_Fix_grammar _)) in Hvalid; congruence. }
    Qed.

    Lemma find_pre_Fix_grammar_to_lookup_state' nt
      : PositiveMap.find nt (pre_Fix_grammar initial_nonterminals_data)
        = if is_valid_nonterminal initial_nonterminals_data (positive_to_nonterminal nt)
          then Some (lookup_state (pre_Fix_grammar initial_nonterminals_data) (positive_to_nonterminal nt))
          else None.
    Proof.
      rewrite <- find_pre_Fix_grammar_to_lookup_state, positive_to_nonterminal_to_positive.
      reflexivity.
    Qed.

    Lemma lookup_state_invalid_pre_Fix_grammar (nt : default_nonterminal_carrierT)
          (Hinvalid : is_valid_nonterminal initial_nonterminals_data nt = false)
      : lookup_state (pre_Fix_grammar initial_nonterminals_data) nt = default_value.
    Proof.
      unfold lookup_state, PositiveMapExtensions.find_default.
      pose proof (find_pre_Fix_grammar nt).
      rewrite Hinvalid in H; destruct H.
      unfold state in *; simpl in *.
      edestruct PositiveMap.find.
      { intuition congruence. }
      { reflexivity. }
    Qed.
  End with_grammar.
End grammar_fixedpoint.


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require map.Map.
Require list.Nth.
Require option.Option.
Require list.NthLength.
Require list.Append.
Require list.NthLengthAppend.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive array
  (a:Type) {a_WT:WhyType a} :=
  | mk_array : Z -> (@map.Map.map Z _ a a_WT) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a] [a_WT]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): (@map.Map.map
  Z _ a a_WT) := match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z)
  (v:a): (@array a a_WT) := (mk_array (length a1) (map.Map.set (elts a1) i
  v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (@array a a_WT) :=
  (mk_array n (map.Map.const v:(@map.Map.map Z _ a a_WT))).

(* Why3 assumption *)
Inductive buffer
  (a:Type) {a_WT:WhyType a} :=
  | mk_buffer : Z -> Z -> (@array a a_WT) -> (list a) -> buffer a.
Axiom buffer_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (buffer a).
Existing Instance buffer_WhyType.
Implicit Arguments mk_buffer [[a] [a_WT]].

(* Why3 assumption *)
Definition sequence {a:Type} {a_WT:WhyType a} (v:(@buffer
  a a_WT)): (list a) := match v with
  | (mk_buffer x x1 x2 x3) => x3
  end.

(* Why3 assumption *)
Definition data {a:Type} {a_WT:WhyType a} (v:(@buffer a a_WT)): (@array
  a a_WT) := match v with
  | (mk_buffer x x1 x2 x3) => x2
  end.

(* Why3 assumption *)
Definition len {a:Type} {a_WT:WhyType a} (v:(@buffer a a_WT)): Z :=
  match v with
  | (mk_buffer x x1 x2 x3) => x1
  end.

(* Why3 assumption *)
Definition first {a:Type} {a_WT:WhyType a} (v:(@buffer a a_WT)): Z :=
  match v with
  | (mk_buffer x x1 x2 x3) => x
  end.

(* Why3 assumption *)
Definition size {a:Type} {a_WT:WhyType a} (b:(@buffer a a_WT)): Z :=
  (length (data b)).

Require Import Why3. Ltac ae := why3 "alt-ergo" timelimit 3.

(* Why3 goal *)
Theorem WP_parameter_pop : forall {a:Type} {a_WT:WhyType a}, forall (b:Z)
  (b1:Z) (b2:Z) (b3:(@map.Map.map Z _ a a_WT)) (b4:(list a)),
  (((((0%Z <= b)%Z /\ (b < b2)%Z) /\ (((0%Z <= b1)%Z /\ (b1 <= b2)%Z) /\
  ((b1 = (list.Length.length b4)) /\ forall (i:Z), ((0%Z <= i)%Z /\
  (i < b1)%Z) -> ((((b + i)%Z < b2)%Z -> ((list.Nth.nth i
  b4) = (Some (map.Map.get b3 (b + i)%Z)))) /\
  ((0%Z <= ((b + i)%Z - b2)%Z)%Z -> ((list.Nth.nth i
  b4) = (Some (map.Map.get b3 ((b + i)%Z - b2)%Z)))))))) /\ (0%Z <= b2)%Z) /\
  (0%Z < b1)%Z) ->
  match b4 with
  | nil => True
  | (cons _ s) => forall (rho:(list a)), (rho = s) -> (((0%Z <= b)%Z /\
      (b < b2)%Z) -> forall (rho1:Z), (rho1 = (b1 - 1%Z)%Z) ->
      forall (rho2:Z), (rho2 = (b + 1%Z)%Z) -> ((rho2 = b2) ->
      forall (rho3:Z), (rho3 = 0%Z) -> ((((0%Z <= rho3)%Z /\
      (rho3 < b2)%Z) /\ (((0%Z <= rho1)%Z /\ (rho1 <= b2)%Z) /\
      ((rho1 = (list.Length.length rho)) /\ forall (i:Z), ((0%Z <= i)%Z /\
      (i < rho1)%Z) -> ((((rho3 + i)%Z < b2)%Z -> ((list.Nth.nth i
      rho) = (Some (map.Map.get b3 (rho3 + i)%Z)))) /\
      ((0%Z <= ((rho3 + i)%Z - b2)%Z)%Z -> ((list.Nth.nth i
      rho) = (Some (map.Map.get b3 ((rho3 + i)%Z - b2)%Z)))))))) ->
      match b4 with
      | nil => True
      | (cons x l) => ((map.Map.get b3 b) = x)
      end)))
  end.
(* Why3 intros a a_WT b b1 b2 b3 b4 ((((h1,h2),((h3,h4),(h5,h6))),h7),h8). *)
unfold get; simpl.
intros a _a b rho rho1 rho2 rho3.
intros ((((h1,h2),(h3,(h4,h5))),_),h6).
destruct rho3; auto.
intros; subst.
intuition.
generalize (h5 (0%Z)).
ae.
Qed.


Require Import Thread Arrays8 MoreArrays.

Local Hint Extern 1 (@eq W _ _) => words.

Module Type S.
  Variables globalSched globalSock : W.
End S.

Module Make(M : S).
Import M.

Module M'''.
  Definition globalSched := M.globalSched.

  Open Scope Sep_scope.

  Definition globalInv (fs : files) : HProp := Ex fr, globalSock =*> fr * [| fr %in fs |].
End M'''.

Ltac unf := unfold M'''.globalSched, M'''.globalInv in *.

Module T := Thread.Make(M''').

Import T M'''.
Export T M'''.

Definition hints : TacPackage.
  prepare (materialize_buffer, buffer_split_tagged) buffer_join_tagged.
Defined.

Ltac sep := T.sep unf hints.

Definition handlerS := SPEC reserving 49
  Al fs, PREmain[_] sched fs * globalInv fs * mallocHeap 0.

Definition mainS := SPEC reserving 49
  PREmain[_] globalSched =?> 1 * globalSock =?> 1 * mallocHeap 0.

Definition writeSomeS := SPEC("fr", "buf", "len") reserving 36
  Al fs, Al len,
  PRE[V] [| V "fr" %in fs |] * V "buf" =?>8 len * [| (wordToNat (V "len") <= len)%nat |]
    * sched fs * globalInv fs * mallocHeap 0
  POST[_] Ex fs', [| fs %<= fs' |] * V "buf" =?>8 len * sched fs' * globalInv fs' * mallocHeap 0.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS],
                           "scheduler"!"init" @ [initS], "scheduler"!"exit" @ [exitS],
                           "scheduler"!"spawn" @ [spawnS], "scheduler"!"listen" @ [listenS],
                           "scheduler"!"accept" @ [acceptS], "scheduler"!"read" @ [readS],
                           "scheduler"!"write" @ [writeS], "scheduler"!"close" @ [closeS] ]]
  bmodule "test" {{
    bfunction "writeSome"("fr", "buf", "len") [writeSomeS]
      Assert [Al fs, Al len,
        PRE[V] [| V "fr" %in fs |] * buffer_splitAt (wordToNat (V "len")) (V "buf") len
          * [| (wordToNat (V "len") <= len)%nat |] * sched fs * globalInv fs * mallocHeap 0
        POST[_] Ex fs', [| fs %<= fs' |] * buffer_joinAt (wordToNat (V "len")) (V "buf") len
          * sched fs' * globalInv fs' * mallocHeap 0];;

      Call "scheduler"!"write"("fr", "buf", "len")
      [PRE[_] Emp POST[_] Emp];;
      Return 0
    end with bfunctionNoRet "handler"("buf", "fr", "n") [handlerS]
      "buf" <-- Call "malloc"!"malloc"(0, 10)
      [Al fs, PREmain[_, R] R =?> 10 * sched fs * globalInv fs * mallocHeap 0];;

      Note [please_materialize_buffer 10];;

      [Al fs, PREmain[V] V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
      While (0 = 0) {
        "fr" <-- Call "scheduler"!"accept"($[globalSock])
        [Al fs, PREmain[V, R] [| R %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0];;

        "n" <-- Call "scheduler"!"read"("fr", "buf", 40)
        [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0];;

        [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
        While ("n" <> 0) {
          If ("n" <= 40) {
            Call "test"!"writeSome"("fr", "buf", "n")
            [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
          } else {
            Skip
          };;

          "n" <-- Call "scheduler"!"read"("fr", "buf", 40)
          [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
        };;

        Call "scheduler"!"close"("fr")
        [Al fs, PREmain[V] V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
      }
    end with bfunctionNoRet "main"("fr", "x") [mainS]
      Init
      [Al fs, Al v, PREmain[_] sched fs * globalSock =*> v * mallocHeap 0];;

      "fr" <-- Call "scheduler"!"listen"(8080%N)
      [Al fs, Al v, PREmain[_, R] [| R %in fs |] * sched fs * globalSock =*> v * mallocHeap 0];;

      globalSock *<- "fr";;

      Spawn("test"!"handler", 50)
      [Al fs, PREmain[_] sched fs * globalInv fs * mallocHeap 0];;

      Spawn("test"!"handler", 50)
      [Al fs, PREmain[_] sched fs * globalInv fs * mallocHeap 0];;

      Exit 50
    end
  }}.

Opaque allocated.

Lemma single_cell : forall p,
  (p =?> 1 = (Ex v, p =*> v) * Emp)%Sep.
  auto.
Qed.

Lemma le_40 : forall w : W,
  w <= natToW 40
  -> (wordToNat w <= 40)%nat.
  intros; pre_nomega.
  rewrite wordToNat_natToWord_idempotent in * by reflexivity; omega.
Qed.

Hint Immediate le_40.

Ltac t' := try rewrite (single_cell globalSock); sep; auto.
Ltac t := solve [ t'
  | post; evaluate hints; descend; try match_locals; t' ].

Theorem ok : moduleOk m.
  vcgen; abstract t.
Qed.

End Make.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module ConfigParamsBaseProofs (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

(* ConfigParamsBase_Ф_getCurValidatorData *)

Lemma ConfigParamsBase_Ф_getCurValidatorData_exec : forall (l: Ledger),
    exec_state ( ↓ ConfigParamsBase_Ф_getCurValidatorData ) l = l.
Proof.
  intros. destruct l. compute. auto.
Qed.

 Lemma ConfigParamsBase_Ф_getCurValidatorData_eval : forall (l: Ledger) ,
 let (Л_cell, Л_ok) := eval_state (tvm_rawConfigParam_34) l in
 let hash := tvm_hash Л_cell in
 let sliceRaw := toSlice Л_cell in
 let res := decode_uint8_uint32_uint32 sliceRaw in

 eval_state ( ↓ ConfigParamsBase_Ф_getCurValidatorData ) l =
  if Л_ok then Value (hash , snd (fst (fst res)) , snd (fst res))
          else Error InternalErrors_ι_ERROR508.
 Proof.
   intros. destruct l. compute.  auto.
 Qed.

Axiom tvm_rawConfigParam_34_evalAx: forall  (l: Ledger) ,
let (raw34, b) := eval_state (tvm_rawConfigParam_34) l in
let unknown34 := eval_state (↑16 ε VMState_ι_unknown34) l in
let utime_since := eval_state (↑16 ε VMState_ι_utime_since ) l in
let utime_until := eval_state (↑16 ε VMState_ι_utime_until ) l in
fst (decode_uint8_uint32_uint32 (toSlice raw34)) = (unknown34, utime_since, utime_until).

 Lemma ConfigParamsBase_Ф_getCurValidatorData_eval2 : forall (l: Ledger) ,
(*  let (_, Л_ok) := eval_state (tvm_rawConfigParam_34) l in *)
 let сurValidatorDataCell := eval_state (↑16 ε VMState_ι_curValidatorData) l in
 let utime_since := eval_state (↑16 ε VMState_ι_utime_since ) l in
 let utime_until := eval_state (↑16 ε VMState_ι_utime_until ) l in
 let hash := tvm_hash сurValidatorDataCell in
 let sliceRaw := toSlice сurValidatorDataCell in
 let res := decode_uint8_uint32_uint32 sliceRaw in

  eval_state ( ↓ ConfigParamsBase_Ф_getCurValidatorData ) l =
  (* if Л_ok then  *)Value (hash , utime_since , utime_until )
         (*  else Error (eval_state ( ↑8 ε InternalErrors_ι_ERROR508) l) *).
 Proof.
   intros.
   remember (tvm_rawConfigParam_34_evalAx l) as A.
   rewrite ConfigParamsBase_Ф_getCurValidatorData_eval.
   destruct l.
   destruct Ledger_ι_VMState.
   compute. compute in A.
   clear HeqA.
   rewrite A.
   auto.
 Qed.

(* ConfigParamsBase_Ф_getPrevValidatorHash *)

Lemma ConfigParamsBase_Ф_getPrevValidatorHash_exec : forall (l: Ledger) ,
 	 exec_state ( ↓ ConfigParamsBase_Ф_getPrevValidatorHash ) l = l .
 Proof.
   intros. destruct l. auto.
 Qed.

Lemma ConfigParamsBase_Ф_getPrevValidatorHash_eval : forall (l: Ledger)  ,
let (_, Л_ok) := eval_state tvm_rawConfigParam_32 l in
let Л_cell := eval_state (↑ε16 VMState_ι_prevValidatorData) l in
let hash := tvm_hash Л_cell in

    eval_state ( ↓ ConfigParamsBase_Ф_getPrevValidatorHash ) l =
    if Л_ok then Value hash
            else Error InternalErrors_ι_ERROR507 .
 Proof.
   intros. compute. auto.
 Qed.

Lemma ConfigParamsBase_Ф_getPrevValidatorHash_eval2 : forall (l: Ledger)  ,
(* let (_, Л_ok) := eval_state tvm_rawConfigParam_32 l in *)
let Л_cell := eval_state (↑ε16 VMState_ι_prevValidatorData) l in
let hash := tvm_hash Л_cell in

    eval_state ( ↓ ConfigParamsBase_Ф_getPrevValidatorHash ) l =
    (* if Л_ok then  *)Value hash
            (* else Error InternalErrors_ι_ERROR507 *) .
 Proof.
   intros. compute. auto.
 Qed.

 (* ConfigParamsBase_Ф_roundTimeParams *)

 Lemma ConfigParamsBase_Ф_roundTimeParams_exec : forall (l: Ledger) ,
 	 exec_state (↓ ConfigParamsBase_Ф_roundTimeParams ) l = l .
 Proof.
   intros. destruct l. auto.
 Qed.

Lemma ConfigParamsBase_Ф_roundTimeParams_eval : forall (l: Ledger) ,
let (_ , ок) := eval_state (tvm_configParam_15) l in

let validatorsElectedFor := eval_state (↑16 ε VMState_ι_validatorsElectedFor) l in
let electionsStartBefore := eval_state (↑16 ε VMState_ι_electionsStartBefore) l in
let electionsEndBefore := eval_state (↑16 ε VMState_ι_electionsEndBefore) l in
let stakeHeldFor := eval_state (↑16 ε VMState_ι_stakeHeldFor) l in

   eval_state (↓ ConfigParamsBase_Ф_roundTimeParams) l =
   if ок then Value (validatorsElectedFor, electionsStartBefore, electionsEndBefore, stakeHeldFor)
         else Error InternalErrors_ι_ERROR509 .
 Proof.
   intros. destruct l.  compute. auto.
 Qed.

Lemma ConfigParamsBase_Ф_roundTimeParams_eval2 : forall (l: Ledger) ,
(* let (_ , ок) := eval_state (tvm_configParam_15) l in
 *)
let validatorsElectedFor := eval_state (↑16 ε VMState_ι_validatorsElectedFor) l in
let electionsStartBefore := eval_state (↑16 ε VMState_ι_electionsStartBefore) l in
let electionsEndBefore := eval_state (↑16 ε VMState_ι_electionsEndBefore) l in
let stakeHeldFor := eval_state (↑16 ε VMState_ι_stakeHeldFor) l in

   eval_state (↓ ConfigParamsBase_Ф_roundTimeParams) l =
   (* if ок then  *)Value (validatorsElectedFor, electionsStartBefore, electionsEndBefore, stakeHeldFor)
         (* else Error InternalErrors_ι_ERROR509 *).
 Proof.
   intros. destruct l.  compute. auto.
 Qed.

 (* ConfigParamsBase_Ф_getMaxStakeFactor *)

Lemma ConfigParamsBase_Ф_getMaxStakeFactor_exec : forall (l: Ledger) ,
  exec_state (↓ ConfigParamsBase_Ф_getMaxStakeFactor) l = l .
Proof.
  intros. destruct l. auto.
Qed.

Lemma ConfigParamsBase_Ф_getMaxStakeFactor_eval : forall (l: Ledger)  ,
let (Л_cell, Л_ok) := eval_state tvm_rawConfigParam_17 l in
let sliceRaw := toSlice Л_cell in
let t1 := tvm_loadTons (tvm_loadTons (tvm_loadTons sliceRaw)) in
let res := fst (decode_uint32 t1) in
    eval_state (↓ ConfigParamsBase_Ф_getMaxStakeFactor ) l =
    if Л_ok then Value res
            else Error InternalErrors_ι_ERROR516 .
Proof.
  intros. destruct l.
  compute. auto.
Qed.

(* VMState_ι_unknown17_1 : I8 ; (*check the type*)
		VMState_ι_unknown17_2 : I8 ;
		VMState_ι_unknown17_3 : I8 ;
		VMState_ι_maxStakeFactor : I32; *)

Axiom tvm_rawConfigParam_17_evalAx: forall  (l: Ledger) ,
let (raw17, b) := eval_state tvm_rawConfigParam_17 l in
(* let unknown17_1 := eval_state (↑16 ε VMState_ι_unknown17_1) l in
let unknown17_2 := eval_state (↑16 ε VMState_ι_unknown17_2 ) l in
let unknown17_3 := eval_state (↑16 ε VMState_ι_unknown17_3 ) l in  *)
let maxStakeFactor := eval_state (↑16 ε VMState_ι_maxStakeFactor ) l in

fst (decode_uint32 (tvm_loadTons (tvm_loadTons (tvm_loadTons (toSlice raw17))))) = maxStakeFactor.

Lemma ConfigParamsBase_Ф_getMaxStakeFactor_eval2 : forall (l: Ledger)  ,
let maxStakeFactor := eval_state (↑16 ε VMState_ι_maxStakeFactor ) l in
    eval_state (↓ ConfigParamsBase_Ф_getMaxStakeFactor ) l =  Value maxStakeFactor.
Proof.
  intros.
  remember (tvm_rawConfigParam_17_evalAx l) as A.
  rewrite ConfigParamsBase_Ф_getMaxStakeFactor_eval.
  destruct l.
  destruct Ledger_ι_VMState.
  compute. compute in A.
  clear HeqA.
  rewrite A.
  auto.
Qed.

(* ConfigParamsBase_Ф_getElector *)

Lemma ConfigParamsBase_Ф_getElector_exec : forall (l: Ledger) ,
  exec_state (↓ ConfigParamsBase_Ф_getElector) l = l .
Proof.
  intros. destruct l. auto.
Qed.

Lemma ConfigParamsBase_Ф_getElector_eval : forall (l: Ledger) ,
let (Л_cell, Л_ok) := eval_state (tvm_rawConfigParam_1) l in
let sliceRaw := toSlice Л_cell in
let v := fst (decode_uint256 sliceRaw) in
let res := address_makeAddrStd (-1)%Z v in

eval_state (↓ ConfigParamsBase_Ф_getElector) l =
if Л_ok then Value res
        else Error InternalErrors_ι_ERROR517 .
Proof.
  intros. destruct l.
  compute. auto.
Qed.

Axiom tvm_rawConfigParam_1_evalAx: forall  (l: Ledger) ,
let (raw1, b) := eval_state tvm_rawConfigParam_1 l in
let electorRawAddress := eval_state (↑16 ε VMState_ι_electorRawAddress ) l in

fst (decode_uint256 (toSlice raw1)) = electorRawAddress.

Lemma ConfigParamsBase_Ф_getElector_eval2 : forall (l: Ledger) ,
let electorRawAddress := eval_state (↑16 ε VMState_ι_electorRawAddress ) l in
let res := address_makeAddrStd (-1)%Z electorRawAddress in
  eval_state (↓ ConfigParamsBase_Ф_getElector) l = Value res.
Proof.
  intros.
  remember (tvm_rawConfigParam_1_evalAx l) as A.
  rewrite ConfigParamsBase_Ф_getElector_eval.
  destruct l.
  destruct Ledger_ι_VMState.
  compute. compute in A.
  clear HeqA.
  rewrite A.
  auto.
Qed.

End ConfigParamsBaseProofs.


Require Import Bool List String PeanoNat.
Require Import Common FMap Syntax.

Require Export MessagePool.

Set Implicit Arguments.

Local Open Scope list.
Local Open Scope fmap.

Definition extRqsOf `{DecValue} `{OStateIfc}
           (sys: System) (mp: MessagePool Msg) :=
  qsOf (sys_merqs sys) mp.

Definition extRssOf `{DecValue} `{OStateIfc}
           (sys: System) (mp: MessagePool Msg) :=
  qsOf (sys_merss sys) mp.

Section Validness.
  Context `{DecValue} `{OStateIfc}.

  (* A set of messages are "well-distributed" iff the sources of
   * all messages are different from each others.
   *)
  Definition WellDistrMsgs (msgs: list (Id Msg)) :=
    NoDup (idsOf msgs).

  (* A set of messages are "valid internal inputs" iff
   * 1) each source is internal and
   * 2) they are well-distributed.
   *)
  Definition ValidMsgsIn (sys: System) (msgs: list (Id Msg)) :=
    SubList (idsOf msgs) (sys_minds sys ++ sys_merqs sys) /\
    WellDistrMsgs msgs.

  (* A set of messages are "valid outputs" iff
   * 1) each message is using either an internal or
   *    an external-response queue.
   * 2) they are well-distributed.
   *)
  Definition ValidMsgsOut (sys: System) (msgs: list (Id Msg)) :=
    SubList (idsOf msgs) (sys_minds sys ++ sys_merss sys) /\
    WellDistrMsgs msgs.

  (* A set of messages are "valid external inputs" iff
   * 1) each message uses an external request queue and
   * 2) they are well-distributed.
   *)
  Definition ValidMsgsExtIn (sys: System) (msgs: list (Id Msg)) :=
    SubList (idsOf msgs) (sys_merqs sys) /\
    WellDistrMsgs msgs.

  (* A set of messages are "valid external outputs" iff
   * 1) each message uses an external response queue and
   * 2) they are well-distributed.
   *)
  Definition ValidMsgsExtOut (sys: System) (msgs: list (Id Msg)) :=
    SubList (idsOf msgs) (sys_merss sys) /\
    WellDistrMsgs msgs.

End Validness.

Section HasLabel.
  Context `{DecValue}.

  Inductive Label :=
  | LblIns (mins: list (Id Msg)): Label
  | LblOuts (mouts: list (Id Msg)): Label.

  Class HasLabel (LabelT: Type) :=
    { getLabel: LabelT -> option Label }.

End HasLabel.

Section Transition.
  Variables (SystemT StateT LabelT: Type).

  Definition Step := SystemT -> StateT -> LabelT -> StateT -> Prop.
  Definition Steps := SystemT -> StateT -> list LabelT -> StateT -> Prop.

  (* NOTE: the head is the youngest *)
  Inductive steps (step: Step) (sys: SystemT): StateT -> list LabelT -> StateT -> Prop :=
  | StepsNil: forall st, steps step sys st nil st
  | StepsCons:
      forall st1 ll st2,
        steps step sys st1 ll st2 ->
        forall lbl st3,
          step sys st2 lbl st3 ->
          steps step sys st1 (lbl :: ll) st3.

  Definition psteps (step: Step)
             (P: StateT -> list LabelT -> StateT -> Prop)
             (sys: SystemT) (st1: StateT) (ll: list LabelT) (st2: StateT) :=
    steps step sys st1 ll st2 /\
    P st1 ll st2.

End Transition.

Section Behavior.

  Section Labeled.
    Context {LabelT} `{HasLabel LabelT}.

    Definition Trace := list Label.

    Definition Reachable {SystemT StateT} `{HasInit SystemT StateT}
               (ss: Steps SystemT StateT LabelT) (sys: SystemT) (st: StateT): Prop :=
      exists ll, ss sys (initsOf sys) ll st.

    Fixpoint behaviorOf  (ll: list LabelT): Trace :=
      match ll with
      | nil => nil
      | l :: ll' => (getLabel l) ::> (behaviorOf ll')
      end.

    Inductive Behavior {SystemT StateT} `{HasInit SystemT StateT}
              (ss: Steps SystemT StateT LabelT) : SystemT -> Trace -> Prop :=
    | Behv: forall sys ll st,
        ss sys (initsOf sys) ll st ->
        forall tr,
          tr = behaviorOf ll ->
          Behavior ss sys tr.

  End Labeled.

  Definition Refines `{dv: DecValue} {SystemI StateI LabelI SystemS StateS LabelS}
             `{HasInit SystemI StateI} `{HasInit SystemS StateS}
             `{@HasLabel dv LabelI} `{@HasLabel dv LabelS}
             (ssI: Steps SystemI StateI LabelI) (ssS: Steps SystemS StateS LabelS)
             (impl: SystemI) (spec: SystemS) :=
    forall tr, Behavior ssI impl tr ->
               Behavior ssS spec tr.

End Behavior.

Notation "StI # StS |-- I <= S" := (Refines StI StS I S) (at level 30).
Notation "StI # StS |-- I ⊑ S" := (Refines StI StS I S) (at level 30).

(** Some concrete state and label definitions *)

Record State `{DecValue} `{OStateIfc} :=
  { st_oss: OStates;
    st_orqs: ORqs Msg;
    st_msgs: MessagePool Msg
  }.

Definition getStateInit `{DecValue} `{OStateIfc} (sys: System): State :=
  {| st_oss := initsOf sys;
     st_orqs := initsOf sys;
     st_msgs := emptyMP _ |}.

Global Instance State_HasInit `{DecValue} `{OStateIfc}: HasInit System State :=
  {| initsOf := getStateInit |}.

Definition GoodORqsInit `{DecValue} (iorqs: ORqs Msg): Prop :=
  forall oidx,
    iorqs@[oidx] >>=[True] (fun orq => orq = []).

Definition IntMsgsEmpty `{DecValue} `{OStateIfc}
           (sys: System) (msgs: MessagePool Msg) :=
  forall midx,
    In midx sys.(sys_minds) ->
    findQ midx msgs = nil.

(* [RLabel] represents "internal rule-driven labels" that reveal which message
 * is being handled now.
 *)
Section RLabel.
  Context `{DecValue}.

  Inductive RLabel :=
  | RlblEmpty
  | RlblIns (mins: list (Id Msg)): RLabel
  | RlblInt (oidx ridx: IdxT) (mins: list (Id Msg)) (mouts: list (Id Msg)): RLabel
  | RlblOuts (mouts: list (Id Msg)): RLabel.

  Definition rToLabel (l: RLabel): option Label :=
    match l with
    | RlblEmpty => None
    | RlblIns mins => Some (LblIns mins)
    | RlblInt _ _ _ _ => None
    | RlblOuts mouts => Some (LblOuts mouts)
    end.

  Global Instance RLabel_HasLabel: HasLabel RLabel :=
    { getLabel := rToLabel }.

End RLabel.

Definition History `{DecValue} := list RLabel.


(** * Parallelization of the Maximum Prefix Sum Application *)

Require Import SyDPaCC.Core.Bmf SyDPaCC.Core.Parallelization.
Require Import SyDPaCC.Applications.Count.

Require Import SyDPaCC.Bsml.Model.Core SyDPaCC.Bsml.Model.Pid
        SyDPaCC.Bsml.DataStructures.DistributedList
        SyDPaCC.Bsml.DataStructures.ReplicatedValue
        SyDPaCC.Bsml.Skeletons.StdLib
        SyDPaCC.Bsml.Skeletons.MapReduce.

Set Implicit Arguments.

Open Scope sydpacc_scope.

Module Make (Import Bsml: Core.BSML).

  Module Pid       := Pid.Make Bsml.Bsp.
  Module StdLib    := StdLib.Make Bsml Pid.
  Module Import ParList   := DistributedList.C Bsml Pid.
  Module Import ReplPar   := ReplicatedValue.C Bsml Pid.
  Module Import MapReduce := MapReduce.Make Bsml Pid StdLib ParList ReplPar.

  Section Count.

    Variable A : Type.
    Variable predicate : { pred: A -> bool & { a : A | pred a = true} }.

    (** ** Version where the result is a scalar *)

    Definition par_count_img : par(list A) -> img (count_spec predicate) :=
      Eval sydpacc in
        parallel (hom_to_map_reduce (count_spec predicate)).

    Definition par_count : par(list A) -> nat :=
      Eval sydpacc in
        of_img ∘ par_count_img.

    (** ** Version where the result is a parallel vector *)
    Definition par_count_img' :=
      Eval sydpacc in
        parallel (hom_to_map_reduce (count_spec predicate)).

    Definition par_count' : par(list A) -> par nat :=
      Eval sydpacc in
        (StdLib.parfun of_img) ∘ (@proj1_sig _ _) ∘ par_count_img'.

  End Count.

End Make.

Close Scope sydpacc_scope.


Require Import Rupicola.Lib.Api.
Require Import Crypto.Bedrock.Specs.ScalarField.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Local Open Scope Z_scope.

Section Compile.
  Context {semantics : Semantics.parameters}
          {semantics_ok : Semantics.parameters_ok semantics}.
  Context {scalar_field_parameters : ScalarFieldParameters}.
  Context {scalar_representaton : ScalarRepresentation}.
  Existing Instance spec_of_sctestbit.

  Lemma compile_sctestbit :
    forall (locals: Semantics.locals) (mem: Semantics.mem)
           (locals_ok : Semantics.locals -> Prop)
           tr retvars R R' functions
           T (pred: T -> list word -> Semantics.mem -> Prop)
      x x_ptr x_var i wi i_var k k_impl var,
      spec_of_sctestbit functions ->
      (Scalar x_ptr x * R')%sep mem ->
      map.get locals x_var = Some x_ptr ->
      map.get locals i_var = Some wi ->
      word.unsigned wi = Z.of_nat i ->
      let v := Z.testbit (F.to_Z (sceval x)) (Z.of_nat i) in
      (let head := v in
       forall m,
         (Scalar x_ptr x * R')%sep m ->
         (find k_impl
          implementing (pred (k head))
          and-returning retvars
          and-locals-post locals_ok
          with-locals (map.put locals var (word.of_Z (Z.b2z head)))
          and-memory m and-trace tr and-rest R
          and-functions functions)) ->
      (let head := v in
       find (cmd.seq
               (cmd.call [var] sctestbit [expr.var x_var; expr.var i_var])
               k_impl)
       implementing (pred (dlet head k))
       and-returning retvars
       and-locals-post locals_ok
       with-locals locals and-memory mem and-trace tr and-rest R
       and-functions functions).
  Proof.
    repeat straightline'.
    handle_call; [ solve [eauto] ..
                 | cbv [dlet.dlet] in *|-; sepsimpl ].
    cbn [length] in *. destruct_lists_of_known_length.
    subst_lets_in_goal. subst.
    match goal with H : word.unsigned _ = Z.of_nat _ |- _ =>
                    rewrite H in *
    end.
    repeat straightline'; eauto.
  Qed.
End Compile.

Ltac scfield_compile_step := simple eapply compile_sctestbit.