Require Import Fiat.QueryStructure.Automation.MasterPlan.
Require Import Fiat.QueryStructure.Specification.Constraints.DuplicateFree.

Definition int := nat.
Definition ERROR := 2. (* should have been defined as -1 *)
Definition FAILURE := 0.
Definition SUCCESS := 1.

Definition any := string.

Definition sSUBSCRIPTIONS := "Subscriptions".
Definition sPUBLICATIONS := "Publications".
Definition sSERVICES := "Services".
Definition sTOPICS := "Topics".
Definition sTOPIC := "topic".
Definition sNODE_ID := "node_id".
Definition sNODE_API := "node_api".
Definition sSERVICE_API := "service_api".
Definition sSERVICE := "service".
Definition sTOPIC_TYPE := "topic_type".
Definition sNODES := "Nodes".
Definition sPARAMS := "Parameters".
Definition sKEY := "key".
Definition sVALUE := "value".
Definition sPARAMSUBSCRIPTIONS := "ParamSubscriptions".

(* what happen if the same tuple is repeatedly inserted in sNODES? *)
(* want drop it when the same thing comes in *)

Definition stringPrefix str str' : Prop :=
  prefix str str' = true.

Instance prefixDecideable {B} (f : B -> _) str'
    : DecideableEnsemble (fun str => stringPrefix (f str) str')
    := { dec str := prefix (f str) str'}.
  intros.
  unfold stringPrefix. destruct (prefix (f a) str'); simpl; split; eauto.
Defined.

Instance prefixDecideable' {B} (f : B -> _) str'
  : DecideableEnsemble (fun str => stringPrefix str' (f str))
    := { dec str := prefix str' (f str)}.
  intros.
  unfold stringPrefix. destruct (prefix str' (f a)); simpl; split; eauto.
Defined.

Definition RosMasterSchema :=
  Query Structure Schema
        [
          relation sNODES has
                   schema <sNODE_ID :: string, sNODE_API :: string>
          where attributes [sNODE_API] depend on [sNODE_ID];

            relation sTOPICS has
                     schema <sTOPIC :: string, sTOPIC_TYPE :: string>
          where attributes [sTOPIC_TYPE] depend on [sTOPIC];

            relation sPARAMS has
                     schema <sKEY :: string, sVALUE :: any>
          where attributes [sVALUE] depend on [sKEY];

            relation sSUBSCRIPTIONS has
                     schema <sNODE_ID :: string, sTOPIC :: string>
          where DuplicateFree;

            relation sPARAMSUBSCRIPTIONS has
                     schema <sNODE_ID :: string, sKEY :: string>
          where DuplicateFree;

            relation sPUBLICATIONS has
                     schema <sNODE_ID :: string, sTOPIC :: string>
          where DuplicateFree;

            relation sSERVICES has
                     schema <sNODE_ID :: string, sSERVICE :: string, sSERVICE_API :: string>
          where attributes [sNODE_ID; sSERVICE_API] depend on [sSERVICE]
        ]
        enforcing [ attribute sNODE_ID for sSUBSCRIPTIONS references sNODES;
                    attribute sTOPIC for sSUBSCRIPTIONS references sTOPICS;
                    attribute sNODE_ID for sPUBLICATIONS references sNODES;
                    attribute sTOPIC for sPUBLICATIONS references sTOPICS;
                    attribute sNODE_ID for sPARAMSUBSCRIPTIONS references sNODES;
                    attribute sKEY for sPARAMSUBSCRIPTIONS references sPARAMS ].

Definition RosMasterSig : ADTSig :=
  ADTsignature {
      Constructor "Init" : rep,

      (* register/unregister methods *)

      Method "registerService" : rep * string * string * string * string
                                    -> rep * (int * string * int),

      Method "unregisterService" : rep * string * string * string
                                    -> rep * (int * string * int),

      Method "registerSubscriber" : rep * string * string * string * string
                                    -> rep * (int * string * list string),

      Method "unregisterSubscriber" : rep * string * string * string
                                      -> rep * (int * string * int),

      Method "registerPublisher" : rep * string * string * string * string
                                    -> rep * (int * string * list string),

      Method "unregisterPublisher" : rep * string * string * string
                                      -> rep * (int * string * int),

      (* name service and system state *)

      Method "lookupNode" : rep * string * string
                          -> rep * (int * string * string),

      Method "getPublishedTopics" : rep * string * string
                          -> rep * (int * string * list (string * string)),

      Method "getTopicTypes" : rep * string
                               -> rep * (int * string * list (string * string)),

      Method "getSystemState" : rep * string
                          -> rep * (int * string * list ( list (string * list string) ) ),

      Method "getUri" : rep * string
                          -> rep * (int * string * string),

      Method "lookupService" : rep * string * string
                          -> rep * (int * string * string),

      (* parameter server API *)

      Method "deleteParam" : rep * string * string
                             -> rep * (int * string * int),

      Method "setParam" : rep * string * string * any
                          -> rep * (int * string * int),

      Method "getParam" : rep * string * string
                          -> rep * (int * string * any),

      Method "searchParam" : rep * string * string
                             -> rep * (int * string * string),

      Method "subscribeParam" : rep * string * string * string
                              -> rep * (int * string * any),

      Method "unsubscribeParam" : rep * string * string * string
                                  -> rep * (int * string * int),

      Method "hasParam" : rep * string * string
                          -> rep * (int * string * bool),

      Method "getParamNames" : rep * string
                               -> rep * (int * string * list string)
  }.

Definition RosMasterSpec : ADT RosMasterSig :=
  Eval simpl in
    Def ADT {
      rep := QueryStructure RosMasterSchema,

    Def Constructor0 "Init" : rep := empty,,

    Def Method4 "registerService"
      (r : rep) (caller_id : string) (service : string) (service_api : string) (caller_api : string)
      : rep * (int * string * int)%type
      :=

        res1 <- Insert <sNODE_ID::caller_id, sSERVICE::service_api, sNODE_API::caller_api> into r ! sSERVICES;
        If snd res1 Then
          res2 <- Insert <sNODE_ID :: caller_id, sNODE_API :: caller_api> into (fst res1) ! sNODES;
          If snd res2 Then
            ret(fst res2, (SUCCESS, "Service registered.", 0))
          Else
            ret(r, (FAILURE, "That node exists but with a different api.", 0))
        Else
          ret(r, (FAILURE, "That service is already being provided", 0))
    ,

    Def Method3 "unregisterService"
      (r : rep) (caller_id : string) (service : string) (service_api : string)
      : rep * (int * string * int)%type
      :=
        res1 <- Delete serv from r ! sSERVICES
                where (serv ! sNODE_ID = caller_id /\ serv ! sSERVICE = service /\ serv ! sSERVICE_API = service_api );

        c1 <- ret (List.length (snd res1));

        (* c1 should be either 0 or 1. How can it be guaranteed?*)

        if beq_nat c1 0 then
          ret (fst res1, (SUCCESS, "Service was not registered in the first place.", c1))
        else
          ret (fst res1, (SUCCESS, "Service unsubscribed.", c1))
    ,

    Def Method4 "registerSubscriber"
      (r : rep) (caller_id : string) (topic : string) (topic_type : string) (caller_api : string)
      : rep * (int * string * list string)%type
      :=
        res1 <- Insert <sNODE_ID :: caller_id, sTOPIC :: topic> into r ! sSUBSCRIPTIONS;

        if (snd res1) then
          (res2 <- Insert <sNODE_ID :: caller_id, sNODE_API :: caller_api> into (fst res1) ! sNODES;
           if (snd res2) then
             (res3 <- Insert <sTOPIC :: topic, sTOPIC_TYPE :: topic_type> into (fst res2) ! sTOPICS;
              if snd res3 then
                (publishers <- For (pub in r ! sPUBLICATIONS) (node in r ! sNODES)
                            Where ( pub ! sTOPIC = topic  /\  pub ! sNODE_ID = node ! sNODE_ID )
                            Return ( node ! sNODE_API );
                 ret(fst res3, (SUCCESS, "You are now subscribed.  Publishers are:", publishers)))
              else
                ret(r, (FAILURE, "That topic exists but with a different type.", [])))
           else
             ret(r, (FAILURE, "That node exists but with a different api.", [])))
        else
          ret(r, (FAILURE, "You are already subscribed to that topic.", []))
    ,

    Def Method3 "unregisterSubscriber"
      (r : rep) (caller_id : string) (topic : string) (caller_api : string)
      : rep * (int * string * int)%type
      :=
        res1 <- Delete sub from r ! sSUBSCRIPTIONS
                where (sub ! sNODE_ID = caller_id /\ sub ! sTOPIC = topic );

        c1 <- ret (List.length (snd res1)); (* or, c1 <- Count (ret (snd res1)); *)

        if beq_nat c1 0 then
          ret (fst res1, (SUCCESS, "You weren't subscribed to begin with.", c1))
        else
          ret (fst res1, (SUCCESS, "You are now unsubscribed.", c1))
    ,

    Def Method4 "registerPublisher"
      (r : rep) (caller_id : string) (topic : string) (topic_type : string) (caller_api : string)
      : rep * (int * string * list string)%type
      :=
        res1 <- Insert <sNODE_ID :: caller_id, sTOPIC :: topic> into r ! sPUBLICATIONS;
        If snd res1 Then
           (res2 <- Insert <sNODE_ID :: caller_id, sNODE_API :: caller_api> into (fst res1) ! sNODES;
            If snd res2 Then
               (res3 <- Insert <sTOPIC :: topic, sTOPIC_TYPE :: topic_type> into (fst res2) ! sTOPICS;
                If snd res3 Then
                   subscribers <- For (sub in r ! sSUBSCRIPTIONS) (node in r ! sNODES)
                   Where ( sub ! sTOPIC = topic  /\  sub ! sNODE_ID = node ! sNODE_ID )
                   Return ( node ! sNODE_API );

                   ret(fst res3, (SUCCESS, "You are now publishing.  Subscribers are:", subscribers))
               Else
               ret(r, (FAILURE, "That topic exists but with a different type.", [])))
           Else
           ret(r, (FAILURE, "That node exists but with a different api.", [])))
           Else
           ret(r, (FAILURE, "You are already publishing to that topic.", [])),

    Def Method3 "unregisterPublisher"
      (r : rep) (caller_id : string) (topic : string) (caller_api : string)
      : rep * (int * string * int)%type
      :=
        res1 <- Delete pub from r ! sPUBLICATIONS
                where (pub ! sNODE_ID = caller_id /\ pub ! sTOPIC = topic );

        c1 <- ret (List.length (snd res1));

        if beq_nat c1 0 then
          ret (fst res1, (SUCCESS, "You weren't publishing to begin with.", c1))
        else
          ret (fst res1, (SUCCESS, "You are now unregistered.", c1))
    ,

    Def Method2 "lookupNode"
      (r : rep) (caller_id : string) (node_name : string)
      : rep * (int * string * string)%type
      (* Returns (code, statusMessage, URI) *)
      :=
        apis <- For (node in r ! sNODES)
              Where ( node ! sNODE_ID = node_name )
              Return ( node ! sNODE_API );

        api <- ret (List.hd "" apis);
        c <- ret (List.length apis); (* should be either 0 or 1 *)

        if beq_nat c 0 then
          ret (r, (FAILURE, "Node not found.", api))
        else
          ret (r, (SUCCESS, "Node URI is :", api))
    ,

    Def Method2 "getPublishedTopics"
      (r : rep) (caller_id : string) (subgraph : string)
      : rep * (int * string * list (string * string))%type
      (* Returns (code, statusMessage, [(topic,type)]) *)
                                                           :=
        res <- For (topic in r ! sTOPICS) (pub in r ! sPUBLICATIONS)
            Where ( topic ! sTOPIC = pub ! sTOPIC)
            Where (stringPrefix topic!sTOPIC subgraph )
              Return ( (topic ! sTOPIC, topic ! sTOPIC_TYPE) );
        ret (r, (SUCCESS, "Topics with publishers are :", res))  (* should remove duplicates *)
    ,

    Def Method1 "getTopicTypes"
      (r : rep) (caller_id : string)
      : rep * (int * string * list (string * string))%type
      :=
        res <- For (topic in r ! sTOPICS)
              Return ( (topic ! sTOPIC, topic ! sTOPIC_TYPE) );
        ret (r, (SUCCESS, "Topics are :", res))
    ,

    Def Method1 "getSystemState"
      (r : rep) (caller_id : string)
      : rep * (int * string * list (list (string * list string)) )%type
        :=
        publishers <- For (topic in r ! sTOPICS)
                 (
                   pubs <- For (pub in r ! sPUBLICATIONS)
                             Where (topic ! sTOPIC = pub ! sTOPIC)
                             Return (pub ! sNODE_ID);
                   Return ( (topic ! sTOPIC, pubs) )
                 );

        subscribers <- For (topic in r ! sTOPICS)
                 (
                   subs <- For (sub in r ! sSUBSCRIPTIONS)
                             Where (topic ! sTOPIC = sub ! sTOPIC)
                             Return (sub ! sNODE_ID);
                   Return ( (topic ! sTOPIC, subs) )
                 );

        services <- For (serv in r ! sSERVICES)
                      Return (serv ! sSERVICE, [serv ! sNODE_ID]);

        ret (r, (SUCCESS, "System state is :", [publishers; subscribers; services]))
    ,

    Def Method1 "getUri"
      (r : rep) (caller_id : string)
      : rep * (int * string * string)%type
      :=
        ret (r, (SUCCESS, "My URI is :", "http://localhost:11311"))
    ,

    Def Method2 "lookupService"
      (r : rep) (caller_id : string) (service : string)
      : rep * (int * string * string)%type
      :=
        ids <- For (serv in r ! sSERVICES)
              Where ( serv ! sSERVICE = service )
              Return ( serv ! sNODE_ID );

        id <- ret (List.hd "" ids);
        c <- ret (List.length ids); (* should be either 0 or 1 *)

        if beq_nat c 0 then (* could use 'match ... with' instead of if *)
          ret (r, (FAILURE, "No one is provind that service.", id))
        else
          ret (r, (SUCCESS, "Service provider is :", id)),

            Def Method2 "deleteParam"
      (r : rep) (caller_id : string) (key : string)
      : rep * (int * string * int)%type
      :=
        res <- Delete param from r ! sPARAMS
                where (param ! sKEY = key);
        ret (fst res, (SUCCESS, "Parameter deleted", 0))
    ,

    Def Method3 "setParam"
      (r : rep) (caller_id : string) (key : string) (value : any)
      : rep * (int * string * int)%type
      :=
        res1 <- Delete param from r ! sPARAMS
                where (param ! sKEY = key);

        res2 <- Insert <sKEY :: key, sVALUE :: value> into (fst res1) ! sPARAMS;

        ret (fst res2, (SUCCESS, "Parameter set", 0))
    ,

    Def Method2 "getParam" (* not supported for key being a namespace *)
      (r : rep) (caller_id : string) (key : string)
      : rep * (int * string * any)%type
      := values <- For (param in r ! sPARAMS)
                    Where ( param ! sKEY = key )
                    Return ( param ! sVALUE  );
        Ifopt hd_error values as v
        Then
        ret (r, (SUCCESS, "Parameter value is :", v))
        Else
        ret (r, (FAILURE, "Parameter not set yet", ""))
    ,

    Def Method2 "searchParam" (* unimplemented *)
      (r : rep) (caller_id : string) (key : string)
      : rep * (int * string * string)%type
      := ret (r, (ERROR, "This API is not implemented.", ""))
    ,

    Def Method3 "subscribeParam"
      (r : rep) (caller_id : string) (caller_api : string) (key : string)
      : rep * (int * string * any)%type
      :=

        res1 <- Insert <sNODE_ID :: caller_id, sKEY :: key> into r ! sPARAMSUBSCRIPTIONS;
        If snd res1 Then
           res2 <- Insert <sNODE_ID :: caller_id, sNODE_API :: caller_api> into (fst res1) ! sNODES;
        If snd res2 Then
            values <- For (param in r ! sPARAMS)
                    Where ( param ! sKEY = key )
                    Return ( param ! sVALUE  );
        Ifopt hd_error values as v Then
           ret (fst res2, (SUCCESS, "Parameter is not set yet.", v))
           Else ret (fst res2, (SUCCESS, "Parameter value is :", ""))
          Else
            ret(r, (FAILURE, "That node exists but with a different api.", ""))
        Else
          ret(r, (FAILURE, "You are already subscribing to that parameter.", ""))
    ,

    Def Method3 "unsubscribeParam"
      (r : rep) (caller_id : string) (caller_api : string) (key : string)
      : rep * (int * string * int)%type
      :=
        res1 <- Delete paramsub from r ! sPARAMSUBSCRIPTIONS
                where (paramsub ! sNODE_ID = caller_id /\ paramsub ! sKEY = key);

        c1 <- ret (List.length (snd res1));

        if beq_nat c1 0 then
          ret (fst res1, (SUCCESS, "You weren't subscribed to begin with.", c1))
        else
          ret (fst res1, (SUCCESS, "You are now unsubscribed.", c1))
    ,

    Def Method2 "hasParam"
      (r : rep) (caller_id : string) (key : string)
      : rep * (int * string * bool)%type
      := values <- For (param in r ! sPARAMS)
                    Where ( param ! sKEY = key )
                    Return ();
        Ifopt hd_error values as _ Then
          ret (r, (SUCCESS, "Parameter is set.", true))
          Else ret (r, (FAILURE, "Parameter is not set.", false))
                             ,

    Def Method1 "getParamNames"
      (r : rep) (caller_id : string)
      : rep * (int * string * list string)%type
      :=
        keys <- For (param in r ! sPARAMS)
                  Return (param ! sKEY);
        ret (r, (SUCCESS, "Parameter names are :", keys))

        }%methDefParsing.

Theorem SharpenedRosMaster :
  FullySharpened RosMasterSpec.
Proof.
  start sharpening ADT.
  start_honing_QueryStructure''.
  - simpl.
    GenerateIndexesForAll
      EqExpressionAttributeCounter
      ltac:(fun attrlist =>
              let attrlist' := eval compute in (PickIndexes _ (CountAttributes' attrlist)) in make_simple_indexes attrlist'
                                                                                ltac:(LastCombineCase6 BuildEarlyEqualityIndex)
                                                                                ltac:(LastCombineCase5 BuildLastEqualityIndex)).
    + plan EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
           EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
      implement_nested_Query EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                             EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
      doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
      implement_nested_Query EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                             EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
      doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
               ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
                      ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
        ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + doAny'
        ltac:(implement_insert'
                EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
                EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep)
               ltac:(master_implement_drill EqIndexUse createEarlyEqualityTerm createLastEqualityTerm)
               ltac:(repeat subst_refine_evar; try finish honing).
    + Finish_Master BuildEarlyBag BuildLastBag.
Time Defined.

Time Definition ROSMasterImpl : ComputationalADT.cADT _ :=
  Eval simpl in projT1 SharpenedRosMaster.

Print ROSMasterImpl.


(* begin hide *)
Require Import Psatz.

From Coq Require Import
     Lists.List
     Strings.String
     Morphisms
     ZArith
     Setoid
     RelationClasses.

From ITree Require Import
     Basics.Category
     Basics.HeterogeneousRelations
     ITree
     ITreeFacts
     Events.MapDefault
     Events.MapDefaultFacts
     Events.State.

Import ITreeNotations.

From ExtLib Require Import
     Core.RelDec
     Structures.Monad
     Structures.Maps
     Programming.Show
     Data.Map.FMapAList.

Import ListNotations.
Open Scope string_scope.

Import CatNotations.
Local Open Scope cat_scope.
Local Open Scope itree_scope.

From ITreeTutorial Require Import Fin Asm AsmCombinators Utils_tutorial.

(* end hide *)

(* optimizations ------------------------------------------------------------ *)

(** A (simple) optimization is just a function from asm units to asm units. *)

Definition optimization {A B} := asm A B -> asm A B.

(** An optimization is correct if it yields an equivalent computation.

    - Note that eq_asm requires that resulting register environment and
      the resulting heap must be equivalent, so this formulation of
      correctness does not permit the elimination of local variables or
      differences in the state.  Those optimizations would require
      more contextual information.
*)

(** We define an appropriate notion of equivalence on these state components.
    This will be useful for defining optimizations at the [Asm] level. *)

Definition EQ_registers (d:value) (regs1 regs2 : registers) : Prop :=
  @eq_map _ _ _ _ d regs1 regs2.

Global Instance EQ_registers_refl {d} : Reflexive (EQ_registers d).
unfold EQ_registers. typeclasses eauto.
Qed.

Global Instance EQ_registers_sym {d} : Symmetric (EQ_registers d).
unfold EQ_registers. typeclasses eauto.
Qed.

Global Instance EQ_registers_trans {d} : Transitive (EQ_registers d).
unfold EQ_registers. typeclasses eauto.
Qed.

Global Instance EQ_registers_eqv {d} : Equivalence (EQ_registers d).
constructor; typeclasses eauto.
Qed.

Definition EQ_memory (mem1 mem2 : memory) : Prop :=
  @eq_map _ _ _ _ 0 mem1 mem2.

Global Instance EQ_memory_refl : Reflexive (EQ_memory).
unfold EQ_memory. typeclasses eauto.
Qed.

Global Instance EQ_memory_sym : Symmetric (EQ_memory).
unfold EQ_memory. typeclasses eauto.
Qed.

Global Instance EQ_memory_trans : Transitive (EQ_memory).
unfold EQ_memory. typeclasses eauto.
Qed.

Global Instance EQ_memory_eqv : Equivalence (EQ_memory).
constructor; typeclasses eauto.
Qed.

Definition rel_asm {B} : memory * (registers * B) -> memory * (registers * B) -> Prop :=
  prod_rel EQ_memory (prod_rel (EQ_registers 0) eq).

Global Hint Unfold rel_asm: core.

(** The definition [interp_asm] also induces a notion of equivalence (open)
    _asm_ programs, which is just the equivalence of the ktree category *)
Definition eq_asm_denotations_EQ {E A B} (t1 t2 : Kleisli (itree (Reg +' Memory +' E)) A B) : Prop :=
  forall a mem1 mem2 regs1 regs2,
    EQ_memory mem1 mem2 ->
    EQ_registers 0 regs1 regs2 ->
    (eutt rel_asm)
      (interp_asm (t1 a) mem1 regs1)
      (interp_asm (t2 a) mem2 regs2).

Definition eq_asm_EQ {A B} (p1 p2 : asm A B) : Prop :=
  eq_asm_denotations_EQ (denote_asm p1) (denote_asm p2).

Definition optimization_correct A B (opt:optimization) :=
  forall (p : asm A B),
    eq_asm_EQ p (opt p).

Definition EQ_asm {E A} (f g : memory -> registers -> itree E (memory * (registers * A))) : Prop :=
  forall mem1 mem2 regs1 regs2,
    EQ_memory mem1 mem2 ->
    EQ_registers 0 regs1 regs2 ->
    eutt (@rel_asm A) (f mem1 regs1) (g mem2 regs2).

Infix "≡" := EQ_asm (at level 70).

Lemma interp_asm_ret_tt : forall (t : itree (Reg +' Memory +' Exit) unit),
    (interp_asm t) ≡ (interp_asm (t ;; Ret tt)).
Proof.
  intros t mem1 mem2 regs1 regs2 H1 H2.
  rewrite interp_asm_bind.
  rewrite <- bind_ret_r at 1.
  apply (@eutt_clo_bind _ _ _ _ _ _ rel_asm).
  { unfold interp_asm.
    unfold rel_asm.
    eapply interp_map_proper; try typeclasses eauto; auto.
    eapply interp_map_proper; try typeclasses eauto; auto.
    reflexivity.
  }
  intros.
  inversion H; subst.
  inversion H3. subst.
  unfold interp_asm.
  unfold interp_map.
  rewrite interp_ret.
  do 2 rewrite interp_state_ret.
  apply eqit_Ret. constructor. auto. destruct b3.
  assumption.
Qed.

Lemma interp_asm_ret {E A} (x:A) mem reg :
  interp_asm (Ret x) mem reg ≈ (Ret (mem, (reg, x)) : itree E _).
Proof.
  unfold interp_asm, interp_map.
  rewrite interp_ret.
  repeat rewrite interp_state_ret.
  reflexivity.
Qed.

Global Instance rel_asm_eqv :
  forall A, Equivalence (@rel_asm A).
Proof.
  intros.
  unfold rel_asm. eapply prod_rel_eqv; try typeclasses eauto.
Qed.

Lemma interp_asm_GetReg {E A} f r mem reg :
  @eutt E _ _ (@rel_asm A)
       (interp_asm (val <- trigger (GetReg r) ;; f val) mem reg)
       ((interp_asm (f (lookup_default r 0 reg))) mem reg).
Proof.
  unfold interp_asm, interp_map.
  rewrite interp_bind.
  setoid_rewrite interp_trigger.
  repeat rewrite interp_state_bind. cbn.
  unfold subevent, resum, ReSum_inl, resum, ReSum_id, id_.
  unfold Id_IFun.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold lookup_def.
  unfold embed, Embeddable_forall, embed, Embeddable_itree.
  unfold trigger. rewrite interp_vis. setoid_rewrite interp_ret.
  unfold subevent, resum.
  repeat rewrite interp_state_bind.
  repeat setoid_rewrite interp_state_ret.
  unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
  rewrite interp_state_trigger_eqit. cbn.
  rewrite !bind_ret_l, !tau_eutt.
  rewrite interp_state_ret.
  rewrite !bind_ret_l, !tau_eutt.
  rewrite !interp_state_ret; cbn.
  rewrite bind_ret_l; cbn.
  reflexivity.
Qed.

Lemma interp_asm_SetReg {E A} f r v mem reg :
  @eutt E _ _ (@rel_asm A)
       (interp_asm (trigger (SetReg r v) ;; f) mem reg)
       ((interp_asm f) mem (Maps.add r v reg)).
Proof.
  unfold interp_asm, interp_map.
  rewrite interp_bind.
  unfold trigger.
  rewrite interp_vis.
  unfold subevent, resum, ReSum_inl, resum, ReSum_id, id_. cbn.
  setoid_rewrite interp_ret.
  rewrite bind_bind.
  setoid_rewrite tau_eutt.
  setoid_rewrite bind_ret_l.
  repeat rewrite interp_state_bind.
  unfold Id_IFun.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
  unfold insert.
  setoid_rewrite interp_trigger.
  repeat rewrite interp_state_trigger_eqit.  cbn.
  rewrite bind_ret_l, tau_eutt.
  setoid_rewrite interp_state_ret.
  rewrite bind_ret_l. cbn.
  reflexivity.
Qed.

Lemma interp_asm_Load {E A} f a mem reg :
  @eutt E _ _ (@rel_asm A)
       (interp_asm (val <- trigger (Load a) ;; f val) mem reg)
       ((interp_asm (f (lookup_default a 0 mem))) mem reg).
Proof.
  unfold interp_asm, interp_map.
  rewrite interp_bind.
  rewrite interp_trigger.
  unfold subevent, resum, ReSum_inr, resum, ReSum_inl, resum, ReSum_id, id_. cbn.
  repeat rewrite interp_state_bind.
  unfold Id_IFun.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
  unfold inr_, Inr_sum1_Handler, Handler.inr_, Handler.htrigger.
  unfold lookup_def.
  repeat (setoid_rewrite interp_trigger; rewrite tau_eutt).
  repeat rewrite interp_state_trigger_eqit.
  cbn. unfold pure_state, embed, Embeddable_forall, embed, Embeddable_itree, trigger.
  do 2 rewrite interp_vis, bind_vis.
  rewrite interp_state_vis. cbn. rewrite bind_vis, interp_state_vis. cbn.
  rewrite !bind_ret_l, !tau_eutt. rewrite !interp_ret, !interp_state_ret.
  rewrite bind_ret_l; cbn.
  reflexivity.
Qed.

Lemma interp_asm_Store {E A} f a v mem reg :
  @eutt E _ _ (@rel_asm A)
       (interp_asm (trigger (Store a v) ;; f) mem reg)
       ((interp_asm f) (Maps.add a v mem) reg).
Proof.
  unfold interp_asm, interp_map.
  rewrite interp_bind.
  rewrite interp_trigger.
  unfold subevent, resum, ReSum_inr, resum, ReSum_inl, resum, ReSum_id, id_. cbn.
  repeat rewrite interp_state_bind.
  unfold Id_IFun.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
  unfold inr_, Inr_sum1_Handler, Handler.inr_, Handler.htrigger.
  unfold insert, embed, Embeddable_forall, embed, Embeddable_itree.
  rewrite interp_trigger.
  setoid_rewrite interp_trigger.
  rewrite interp_state_trigger_eqit. cbn.
  cbn. unfold pure_state, embed, Embeddable_forall, embed, Embeddable_itree, trigger.
  rewrite bind_vis, interp_state_vis. cbn. rewrite !bind_ret_l, !tau_eutt.
  rewrite interp_state_ret, bind_ret_l; cbn.
  reflexivity.
Qed.

(* peephole optimizations --------------------------------------------------- *)

(** A (simple) peephole optmization transforms one instruction into a
   (possibly empty) list of equivalent instructions. *)
Definition peephole_optimization := instr -> list instr.

(** We lift peephole optimizations to _asm_ pointwise through the structures. *)
Fixpoint peephole_optimize_block {lbl} (ph : peephole_optimization) (b:block lbl) : block lbl :=
  match b with
  | bbi i k => blk_append (ph i) (peephole_optimize_block ph k)
  | bbb l => bbb l
  end.

Definition peephole_optimize_bks {A B} (ph : peephole_optimization) (bs : A -> block B) :=
  fun (a:A) => peephole_optimize_block ph (bs a).

Definition peephole_optimize_asm {A B} (ph : peephole_optimization) (p : asm A B) : asm A B :=
  Build_asm A B (p.(internal)) (peephole_optimize_bks ph (p.(code))).

(* peephole correctness ----------------------------------------------------- *)

Section Correctness.

  (** A peephole optimizer is correct if it replaces an instruction with
    a semantically equivalent sequence of instructions. *)
  Definition ph_correct (ph : peephole_optimization) :=
  forall (i:instr),
    @eq_asm_denotations_EQ Exit unit _ (fun _ => denote_instr i) (fun _ => denote_list (ph i)).

  Lemma ph_blk_append_correct : forall (ph : peephole_optimization) (H : ph_correct ph)
    lbl1 lbl2 b1 b2 i,
    (@eq_asm_denotations_EQ Exit (fin lbl1) (fin lbl2) (fun _ => denote_bk b1) (fun _ => denote_bk b2)) ->
    (@eq_asm_denotations_EQ Exit (fin lbl1) (fin lbl2)
                         (fun _ => denote_instr i ;; denote_bk b1)
                         (fun _ => denote_bk (blk_append (ph i) b2))).
  Proof.
    intros ph H lbl1 lbl2 b1 b2 i HP.
    unfold eq_asm_denotations_EQ.
    intros a mem1 mem2 regs1 regs2 EQ_mem EQ_reg.
    rewrite denote_blk_append.
    unfold ph_correct in H.
    unfold eq_asm_denotations_EQ in H.
    specialize H with (i:=i).
    pose proof (H tt) as H2.
    do 2 rewrite interp_asm_bind.
    eapply eutt_clo_bind.
    apply H2; auto.
    intros.
    inversion H0; subst. inversion H3; subst.
    apply HP; auto.
  Qed.

Lemma peephole_block_correct :
  forall (ph : peephole_optimization)
    (H : ph_correct ph)
    (lbl1 lbl2 : nat)
    (b : block (fin lbl2)),
    @eq_asm_denotations_EQ Exit (fin lbl1) (fin lbl2)
                        (fun _ => denote_bk b)
                        (fun _ => denote_bk (peephole_optimize_block ph b)).
Proof.
  intros ph H lbl1 lbl2 b.
  induction b.
  - simpl.
    unfold eq_asm_denotations_EQ.
    intros.
    eapply ph_blk_append_correct; try assumption. exact IHb. assumption.
  - unfold eq_asm_denotations_EQ.
    intros.
    destruct b; simpl.
    + unfold interp_asm.
      rewrite interp_ret.
      unfold interp_map.
      repeat rewrite interp_state_ret.
      apply eqit_Ret. constructor; auto; constructor; auto.
    + setoid_rewrite interp_asm_GetReg.
      rewrite H1.
      unfold value in *.
      remember (lookup_default r 0 regs2) as x.
      destruct x.
      repeat rewrite interp_asm_ret.
      apply eqit_Ret. constructor; auto.
      repeat rewrite interp_asm_ret.
      apply eqit_Ret. constructor; auto.
    + unfold interp_asm, interp_map.
      unfold id_, Id_Handler, Handler.id_.
      unfold exit.
      rewrite interp_vis.
      cbn. rewrite interp_state_bind.
      unfold CategoryOps.cat, Cat_Handler, Handler.cat, inr_, Inr_sum1_Handler, Handler.inr_, Handler.htrigger.
      setoid_rewrite interp_trigger.
      unfold inr_.
      rewrite interp_trigger.
      rewrite interp_state_trigger_eqit.
      rewrite interp_state_bind.
      cbn. unfold pure_state.
      rewrite bind_vis, interp_state_vis. cbn.
      repeat rewrite bind_vis.
      rewrite interp_state_bind.
      rewrite interp_state_trigger_eqit. cbn.
      rewrite !bind_vis, interp_state_vis. cbn.
      rewrite bind_vis.
      apply eqit_Vis; intros [].
Qed.

Lemma peephole_optimization_correct : forall A B (ph : peephole_optimization) (H : ph_correct ph),
    optimization_correct A B (peephole_optimize_asm ph).
Proof.
  intros A B ph H.
  unfold optimization_correct.
  intros p.
  unfold eq_asm, eq_asm_denotations, denote_asm.
  intros a mem1 mem2 regs1 regs2 H1 H2.
  unfold interp_asm, interp_map.
  repeat setoid_rewrite interp_bind.
  repeat rewrite interp_state_bind.
  apply (@eutt_clo_bind _ _ _ _ _ _ rel_asm).

  { apply (@eutt_clo_bind _ _ _ _ _ _ rel_asm).
    -  unfold inr_, Inr_Kleisli, lift_ktree_.
       unfold ret, Monad_itree.
       repeat rewrite interp_ret.
       repeat rewrite interp_state_ret.
       apply eqit_Ret. constructor; auto.
    -  intros. inversion H0.
       subst. cbn.
       unfold CategorySub.from_bif, FromBifunctor_ktree_fin.
       repeat rewrite interp_ret.
       repeat rewrite interp_state_ret.
       apply eqit_Ret.
       inversion H4; subst.
       constructor; auto. }

  intros.
  inversion H0; subst.
  simpl in *.
  unfold denote_bks.
  unfold iter, CategorySub.Iter_sub.
  repeat rewrite interp_iter.
  unfold iter, Iter_Kleisli.
  cbn.
  pose proof @interp_state_iter'.
  red in H5.
  unfold Basics.iter, MonadIter_stateT0, Basics.iter, MonadIter_itree in *.
  cbn in *.
  repeat rewrite H5.

  eapply eutt_iter' with (RI := rel_asm); cbn.
  2: destruct H4; auto.
  intros j1 j2 [ ? ? ? ? ? [? ? ? ? ? []]]; cbn.
  rewrite !interp_bind, !interp_state_bind, !bind_bind. (* Slow! *)

  apply (@eutt_clo_bind _ _ _ _ _ _ rel_asm);
    [|intros ? ? [? ? ? ? ? [? ? ? ? ? []]]]; cbn.
  { eapply @peephole_block_correct; eauto. }

  unfold CategorySub.to_bif, ToBifunctor_ktree_fin.
  apply (@eutt_clo_bind _ _ _ _ _ _ rel_asm);
    [|intros ? ? [? ? ? ? ? [? ? ? ? ? []]]]; cbn.
  {
    rewrite bind_ret_l.
    unfold case_, Case_sum1, Case_Kleisli, case_sum.
    unfold CategoryOps.cat, CategorySub.Cat_sub, CategoryOps.cat, Cat_Kleisli.
    unfold inl_, CategorySub.Inl_sub, inl_, Inl_Kleisli, lift_ktree_.
    unfold inr_, CategorySub.Inr_sub, inr_, Inr_Kleisli, lift_ktree_.
    unfold id_, CategorySub.Id_sub, id_, Id_Kleisli, lift_ktree_.
    cbn.
    unfold CategorySub.from_bif, FromBifunctor_ktree_fin.
    destruct split_fin_sum.
    all: rewrite !bind_ret_l, interp_ret, !interp_state_ret.
    all: apply eqit_Ret; auto; constructor; auto.
    all : constructor; auto.
  }

  rewrite interp_ret, !interp_state_ret, !bind_ret_l.
  rewrite !interp_state_ret, !bind_ret_l; cbn.
  apply eqit_Ret.
  destruct split_fin_sum; auto; constructor; auto.
  all : econstructor; auto.
  all : constructor; auto.
Qed.

(* concrete optimizations --------------------------------------------------- *)

Definition simple (i:instr) : list instr :=
  match i with
  | Imov dest (Oreg src) =>
    if Nat.eqb dest src then [] else [i]
  | _ => [i]
  end.

(* SAZ: Belongs in the utilities? (but depends on EQ_registers)
   EQ_Registers is now just an alias for eq_map, so this can be moved to MapDefaultFacts.
*)
Lemma EQ_registers_add:
  forall (r : reg) (d:value) (regs1 regs2 : registers),
    EQ_registers d regs1 regs2 ->
    EQ_registers d (alist_add r (lookup_default r d regs1) regs1) regs2.
Proof.
  intros r d regs1 regs2 H.
  unfold EQ_registers.
  unfold eq_map.
  intros.
  unfold lookup_default at 1, lookup, Map_alist.
  destruct (Nat.eq_dec k r).
  - subst. rewrite In_add_eq.
    apply H.
  - unfold lookup_default, lookup, Map_alist.
    rewrite alist_find_neq; auto.
    apply H.
Qed.

Lemma simple_correct : ph_correct simple.
Proof.
  unfold ph_correct.
  intros i.
  unfold eq_asm_denotations_EQ.
  intros.
  destruct i; simpl; try apply interp_asm_ret_tt; auto; try reflexivity.

  destruct src.
  + simpl. rewrite !bind_ret_l.
    apply interp_asm_ret_tt; auto; try reflexivity.

  + simpl.
    destruct (Nat.eq_dec dest r).
    * subst.
      rewrite Nat.eqb_refl.
      simpl.
      rewrite interp_asm_ret.
      rewrite interp_asm_GetReg.

      unfold trigger.
      unfold interp_asm, interp_map.
      rewrite interp_vis.
      cbn.
      repeat rewrite interp_state_bind.
      unfold CategoryOps.cat, Cat_Handler, Handler.cat. simpl.
      unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
      unfold insert.
      unfold embed, Embeddable_itree, Embeddable_forall, inl_, embed.
      rewrite interp_trigger.
      rewrite interp_state_trigger_eqit.
      cbn.
      rewrite bind_ret_l, tau_eutt.
      rewrite interp_state_ret, bind_ret_l, interp_ret. cbn.
      rewrite tau_eutt, 2 interp_state_ret.
      apply eqit_Ret.
      constructor; auto; constructor; auto.
      auto using EQ_registers_add.
    * apply Nat.eqb_neq in n.
      rewrite n.
      apply interp_asm_ret_tt; auto.
Qed.

End Correctness.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.AsciiOpt.
Require Import
        Bedrock.Word
        Coq.ZArith.ZArith
        Coq.Strings.Ascii
        Coq.Strings.String.

Section String.
  (* this has an exact idential structure to _FixList_ *)
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Fixpoint format_string (xs : string) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    match xs with
    | EmptyString => ret (mempty, addE ce 0)
    | String x xs' => `(b1, env1) <- format_ascii x ce;
                      `(b2, env2) <- format_string xs' env1;
                      ret (mappend b1 b2, env2)
    end%comp.

    Fixpoint encode_string (xs : string) (ce : CacheFormat) : B * CacheFormat :=
    match xs with
    | EmptyString => (mempty, addE ce 0)
    | String x xs' => let (b1, env1) := encode_ascii x ce in
                      let (b2, env2) := encode_string xs' env1 in
                          (mappend b1 b2, env2)
    end.

  Fixpoint decode_string (s : nat) (b : B) (cd : CacheDecode) : option (string * B * CacheDecode) :=
    match s with
    | O => Some (EmptyString, b, addD cd 0)
    | S s' => `(x, b1, e1) <- decode_ascii b cd;
              `(xs, b2, e2) <- decode_string s' b1 e1;
              Some (String x xs, b2, e2)
    end.

  Local Opaque format_ascii.
  Local Opaque encode_ascii.

  Theorem String_decode_correct
          {P : CacheDecode -> Prop}
          (P_OK : forall b cd, P cd -> P (addD cd b))
    : forall sz,
      CorrectDecoder
        monoid
        (fun ls => length ls = sz)
        (fun ls => length ls = sz)
        eq
        format_string (decode_string sz) P
        format_string.
  Proof.
    split.
    { intros env env' xenv l l' ext ? Eeq Ppred Penc.
      subst.
      generalize dependent env.
      revert env' xenv l' env_OK.
      induction l.
      { intros.
        inversion Penc; subst; clear Penc.
        rewrite mempty_left; eexists _, _; intuition eauto.
        simpl; eauto.
        apply add_correct; eauto.
      }
      { intros.
        simpl in *.
        unfold Bind2 in *; computes_to_inv; subst.
        injection Penc''; intros; subst.
        destruct v; destruct v0.
        destruct (proj1 (Ascii_decode_correct P_OK) _ _ _ _ _ (mappend b0 ext) env_OK Eeq I Penc) as [? [? [? xenv_OK] ] ].
      simpl. rewrite <- mappend_assoc, H; simpl; split_and; subst.
      destruct (IHl _ _ _ H4 _ H1 Penc') as [? [? ?] ].
      split_and; subst.
      setoid_rewrite H3; simpl; eexists _, _;
        intuition eauto.
      simpl; unfold Bind2; eauto.
      }
    }
    { induction sz; simpl; intros.
      { split; eauto;
          injections; repeat eexists; simpl; eauto using mempty_left.
        apply add_correct; eauto.
      }
      { destruct (decode_ascii t env') as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate.
        destruct (decode_string sz b c) as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate; injections.
        eapply (proj2 (Ascii_decode_correct P_OK)) in Heqo; eauto;
          destruct Heqo; destruct_ex; intuition; subst;
            eapply IHsz in Heqo0; eauto; destruct Heqo0;
              destruct_ex; intuition; subst.
        simpl.
        eexists _, _; intuition eauto.
        computes_to_econstructor; eauto.
        computes_to_econstructor; eauto.
        rewrite mappend_assoc; reflexivity.
      }
    }
  Qed.

  Theorem decode_string_lt
    : forall len (lt_len : lt 0 len)
             (b3 : B)
             (cd0 : CacheDecode)
             (a : string) (b' : B)
             (cd' : CacheDecode),
      decode_string len b3 cd0 = Some (a, b', cd') -> lt_B b' b3.
  Proof.
    induction len; simpl; intros; try omega.
    destruct (decode_ascii b3 cd0) as [ [ [? ?] ?] | ] eqn: ? ;
      simpl in *; try discriminate.
    eapply ascii_decode_lt in Heqo.
    destruct (decode_string len b c) as [ [ [? ?] ?] | ] eqn: ? ;
      simpl in *; try discriminate.
    injections.
    inversion lt_len; subst; simpl in *.
    - injections; eauto.
    - eapply IHlen in Heqo0; eauto; unfold lt_B in *; omega.
  Qed.

End String.


From iris_io Require Export lang.

Module Ghostlang.
  Inductive expr :=
  | Var (x : var)
  | Rec (e : {bind 2 of expr})
  | Lam (e : {bind expr})
  | LetIn (e : expr) (e : {bind expr})
  | GRLetIn (e : expr) (e : {bind expr})
  | Seq (e1 e2 : expr)
  | GRSeq (e1 e2 : expr)
  | App (e1 e2 : expr)
  (* Base Types *)
  | Unit
  | Nat (n : nat)
  | Bool (b : bool)
  | BinOp (op : binop) (e1 e2 : expr)
  (* If then else *)
  | If (e0 e1 e2 : expr)
  (* Products *)
  | Pair (e1 e2 : expr)
  | Fst (e : expr)
  | Snd (e : expr)
  (* Sums *)
  | InjL (e : expr)
  | InjR (e : expr)
  | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
  (* Recursive Types *)
  | Fold (e : expr)
  | Unfold (e : expr)
  (* Polymorphic Types *)
  | TLam (e : expr)
  | TApp (e : expr)
  (* Concurrency *)
  | Fork (e : expr)
  (* Reference Types *)
  | Loc (l : loc)
  | IOtag (t : ioTag)
  | Alloc (e : expr)
  | Load (e : expr)
  | Store (e1 : expr) (e2 : expr)
  (* Compare and swap used for fine-grained concurrency *)
  | CAS (e0 : expr) (e1 : expr) (e2 : expr)
  (* Instrumenting Prophecies *)
  | Pr (l : loc)
  | Create_Pr
  | Assign_Pr (e1 e2 : expr)
  (* Random bit *)
  | Rand
  (* I/O *)
  | IO (e1 e2 : expr).

  Fixpoint instr(e: expr): Plang.expr :=
    match e with
      Var x => Plang.Var x
    | Rec e => Plang.Rec (instr e)
    | Lam e => Plang.Lam (instr e)
    | LetIn e1 e2 => Plang.LetIn (instr e1) (instr e2)
    | GRLetIn e1 e2 => Plang.LetIn (instr e1) (instr e2)
    | Seq e1 e2 => Plang.Seq (instr e1) (instr e2)
    | GRSeq e1 e2 => Plang.Seq (instr e1) (instr e2)
    | App e1 e2 => Plang.App (instr e1) (instr e2)
    | Unit => Plang.Unit
    | Nat n => Plang.Nat n
    | Bool b => Plang.Bool b
    | BinOp op e1 e2 => Plang.BinOp op (instr e1) (instr e2)
    | If e0 e1 e2 => Plang.If (instr e0) (instr e1) (instr e2)
    | Pair e1 e2 => Plang.Pair (instr e1) (instr e2)
    | Fst e => Plang.Fst (instr e)
    | Snd e => Plang.Snd (instr e)
    | InjL e => Plang.InjL (instr e)
    | InjR e => Plang.InjR (instr e)
    | Case e0 e1 e2 => Plang.Case (instr e0) (instr e1) (instr e2)
    | Fold e => Plang.Fold (instr e)
    | Unfold e => Plang.Unfold (instr e)
    | TLam e => Plang.TLam (instr e)
    | TApp e => Plang.TApp (instr e)
    | Fork e => Plang.Fork (instr e)
    | Loc l => Plang.Loc l
    | IOtag t => Plang.IOtag t
    | Alloc e => Plang.Alloc (instr e)
    | Load e => Plang.Load (instr e)
    | Store e1 e2 => Plang.Store (instr e1) (instr e2)
    | CAS e0 e1 e2 => Plang.CAS (instr e0) (instr e1) (instr e2)
    | Pr l => Plang.Pr l
    | Create_Pr => Plang.Create_Pr
    | Assign_Pr e1 e2 => Plang.Assign_Pr (instr e1) (instr e2)
    | Rand => Plang.Rand
    | IO e1 e2 => Plang.IO (instr e1) (instr e2)
    end.

  Fixpoint ghost_ok(e: expr): Prop :=
    match e with
    | Var x => True
    | Create_Pr => True
    | Assign_Pr e1 e2 => ghost_ok e1 /\ ghost_ok e2
    | _ => False
    end.

  Inductive var_erases_to: list bool -> var -> var -> Prop :=
  | var_erases_to_real_O gs:
    var_erases_to (false :: gs) O O
  | var_erases_to_real_S gs x x':
    var_erases_to gs x x' ->
    var_erases_to (false :: gs) (S x) (S x')
  | var_erases_to_ghost_S gs x x':
    var_erases_to gs x x' ->
    var_erases_to (true :: gs) (S x) x'
  .

  Inductive erases_to: list bool -> expr -> Plang.expr -> Prop :=
  | Var_erases_to gs x x':
    var_erases_to gs x x' ->
    erases_to gs (Var x) (Plang.Var x')
  | Rec_erases_to gs e e':
    erases_to (false :: false :: gs) e e' ->
    erases_to gs (Rec e) (Plang.Rec e')
  | Lam_erases_to gs e e':
    erases_to (false :: gs) e e' ->
    erases_to gs (Lam e) (Plang.Lam e')
  | LetIn_erases_to gs e1 e2 e1' e2':
    erases_to gs e1 e1' ->
    erases_to (false :: gs) e2 e2' ->
    erases_to gs (LetIn e1 e2) (Plang.LetIn e1' e2')
  | GRLetIn_erases_to gs e1 e2 e2':
    ghost_ok e1 ->
    erases_to (true :: gs) e2 e2' ->
    erases_to gs (GRLetIn e1 e2) e2'
  | Seq_erases_to gs e1 e2 e1' e2':
    erases_to gs e1 e1' ->
    erases_to gs e2 e2' ->
    erases_to gs (Seq e1 e2) (Plang.Seq e1' e2')
  | GRSeq_erases_to gs e1 e2 e2':
    ghost_ok e1 ->
    erases_to gs e2 e2' ->
    erases_to gs (GRSeq e1 e2) e2'
  | App_erases_to gs e1 e2 e1' e2':
    erases_to gs e1 e1' ->
    erases_to gs e2 e2' ->
    erases_to gs (App e1 e2) (Plang.App e1' e2')
  | Unit_erases_to gs:
    erases_to gs Unit Plang.Unit
  | Nat_erases_to gs n:
    erases_to gs (Nat n) (Plang.Nat n)
  | Bool_erases_to gs b:
    erases_to gs (Bool b) (Plang.Bool b)
  | BinOp_erases_to gs op e1 e2 e1' e2':
    erases_to gs e1 e1' ->
    erases_to gs e2 e2' ->
    erases_to gs (BinOp op e1 e2) (Plang.BinOp op e1' e2')
  | If_erases_to gs e0 e1 e2 e0' e1' e2':
    erases_to gs e0 e0' ->
    erases_to gs e1 e1' ->
    erases_to gs e2 e2' ->
    erases_to gs (If e0 e1 e2) (Plang.If e0' e1' e2')
  | Pair_erases_to gs e1 e2 e1' e2':
    erases_to gs e1 e1' ->
    erases_to gs e2 e2' ->
    erases_to gs (Pair e1 e2) (Plang.Pair e1' e2')
  | Fst_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (Fst e) (Plang.Fst e')
  | Snd_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (Snd e) (Plang.Snd e')
  | InjL_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (InjL e) (Plang.InjL e')
  | InjR_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (InjR e) (Plang.InjR e')
  | Case_erases_to gs e0 e1 e2 e0' e1' e2':
    erases_to gs e0 e0' ->
    erases_to (false :: gs) e1 e1' ->
    erases_to (false :: gs) e2 e2' ->
    erases_to gs (Case e0 e1 e2) (Plang.Case e0' e1' e2')
  | Fold_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (Fold e) (Plang.Fold e')
  | Unfold_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (Unfold e) (Plang.Unfold e')
  | TLam_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (TLam e) (Plang.TLam e')
  | TApp_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (TApp e) (Plang.TApp e')
  | Fork_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (Fork e) (Plang.Fork e')
  | Loc_erases_to gs l:
    erases_to gs (Loc l) (Plang.Loc l)
  | IOtag_erases_to gs t:
    erases_to gs (IOtag t) (Plang.IOtag t)
  | Alloc_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (Alloc e) (Plang.Alloc e')
  | Load_erases_to gs e e':
    erases_to gs e e' ->
    erases_to gs (Load e) (Plang.Load e')
  | Store_erases_to gs e1 e2 e1' e2':
    erases_to gs e1 e1' ->
    erases_to gs e2 e2' ->
    erases_to gs (Store e1 e2) (Plang.Store e1' e2')
  | CAS_erases_to gs e0 e1 e2 e0' e1' e2':
    erases_to gs e0 e0' ->
    erases_to gs e1 e1' ->
    erases_to gs e2 e2' ->
    erases_to gs (CAS e0 e1 e2) (Plang.CAS e0' e1' e2')
  | Rand_erases_to gs:
    erases_to gs Rand Plang.Rand
  | IO_erases_to gs e1 e2 e1' e2':
    erases_to gs e1 e1' ->
    erases_to gs e2 e2' ->
    erases_to gs (IO e1 e2) (Plang.IO e1' e2')
  .

End Ghostlang.