Test whether the selection is a subexpression

Question

I am writing a button that applies some transformation to the current selection, in a spirit similar to the question "Apply a function to the current selection in place". However, I would like to only allow cases where the selection is a subexpression of the full cell. How?

For instance, if the cell contains "ab+cd" (its box representation is RowBox[{"ab","+","cd"}] I think) then the selection could be "b+c", which means that applying a function f to that part would give "a f[b+c] d", unrelated to the original expression "ab+cd".

A naive approach would be to test if NotebookRead[NotebookSelection[]] appears within NotebookRead[First[[SelectedCells[]]]]. Some care is needed to cover RowBox with fewer arguments, such as RowBox[{"a","+","b"}] contained in RowBox[{"a","+","b","+","c"}]. This obviously fails in cases such as "(ab+cd)/(b+c)": if the first "b+c" is selected the test would wrongly consider it as a subexpression.

A slight improvement is to only increase the size of the selection using SelectionMove[nb,All,Expression] (rather than directly going to the SelectedCells[]), and only allow a limited number of patterns for the relation between the original selection and the bigger selection. This still fails for "ab+cd+b+c" (both if we work with boxes and if work with expressions). It also changes the selection, which makes it harder to apply something to the selection.

There may be a way to do things by saving the contents of the SelectedCells[], saving the box expression of the selection and replacing it by a recognizable marker using NotebookApply, and comparing the saved SelectedCells[] to the new one to find which part changed. But I am not fluent enough with boxes yet to succeed.

(The following test that boxes can be turned into an expression may be useful: Quiet[MakeExpression[boxes,StandardForm]==$Failed] as a preliminary check to filter out crazy cases such as selecting "y)/(a+" in "(x+y)/(a+b)" and thus limit the number of possible forms that subexpressions can take.)

Answer 1

(The full code is at the end of this post, put together into a shortcut ctrl-| that copies the cell containing the selection, wraps the selection in brackets, and places the cursor before the brackets so as to allow the user to type some function to apply to that subexpression.)

My solution is by no means pretty nor bulletproof. Most checks are done by replacing the selection by a blank pattern and comparing the new cell contents to the old one, both in terms of the boxes and as expressions. It also checks things like whether the selection is a (standalone) expression.

The first test is to check that the selection does not span more than a cell (and is non-empty). Any selection within a cell is accepted. For error recovery it will be useful to save the original contents of the selectedcells (which are a list of CellObjects) as a (list of) Cell expression(s) cells.

nb = EvaluationNotebook[];
selectedcells = SelectedCells[nb];
cells = NotebookRead[selectedcells];
If[Length[selectedcells] == 1,

The next step is to replace the selection by a recognizable marker, obtained using Unique[]. But first save the current selection (as Boxes) as we will alter it. We also check whether the selection starts with - or +, either at the "bottom level" of a RowBox or in a nested one (improvements welcome): this extrasign is used to add + when e.g., -b+c is selected in a-b+c.

    selection = NotebookRead[nb];
    extrasign = 
     MatchQ[selection, 
      RowBox[{"-" | "+" | RowBox[{("-" | "+"), ___}], ___}]];
    unique = Unique[];
    NotebookApply[nb,
     If[extrasign,
      RowBox[{"+", placeholderBox["\[SelectionPlaceholder]"]}],
      placeholderBox["\[SelectionPlaceholder]"]]];

The placeholderBox auxiliary builds essentially $123[<selection>] (as boxes) where $123 is the unique symbol produced above. Thus, NotebookApply wraps the selection as an argument of $123, with an additional + if needed.

Also check now that the selection is a valid expression (this auxiliary tests whether the result of MakeExpression is an ErrorBox). Presumably I could do that test earlier.

    If[validExpression[selection],

Set up the various box data: boxdata corresponds to the original cell; newboxdata corresponds to the cell after the action of NotebookApply; boxdatapattern is boxdata with the selection replaced by a BlankNullSequence. We will check that boxdata matches boxdatapattern to catch cases such as "b+b" being selected in "b+b^2".

     boxdata = cells[[1, 1]];
     newboxdata = NotebookRead[selectedcells][[1, 1]];
     boxdatapattern = If[extrasign,
       ReplaceAll[newboxdata,
        f_Symbol[a___, "+", placeholderBox[___], b___] :> 
         f[a, ___, b]],
       ReplaceAll[newboxdata, placeholderBox[___] :> ___]];

The same for expressions: expr and newexpr are the expressions corresponding to the initial cell contents and the altered ones.

     expr = MakeExpression[boxdata, StandardForm];
     newexpr = MakeExpression[newboxdata, StandardForm];

Check that the initial boxdata matches the pattern obtained by replacing the selection by ___, that we started with an actual expression (otherwise the project is doomed) and that we got an expression out, which contains unique: this catches cases where $123 got glued with a symbol before it, giving a symbol a$123.

     If[MatchQ[boxdata, boxdatapattern] &&
       (Head[expr] =!= ErrorBox) &&
       (Head[newexpr] =!= ErrorBox) &&
       Not[FreeQ[newexpr, unique]] &&

Finally, the topic of another question I asked, about MatchQ and Orderless functions. This last test essentially checks that the original expression matches the pattern obtained by replacing the selection with ___. The pattern matcher does not respect Hold for patterns containing Orderless functions (such as Plus, Times), so I hide these Orderless functions inside Verbatim.

       MatchQ[expr,
         ReplaceAll[newexpr,
           {unique[___] :> ___,
            (h_Symbol /; MemberQ[Attributes[h], Orderless]) :>
            Verbatim[h]}]]
       ,

This is the end of checking that the selection is a nice subexpression. The rest of the code manipulates cells to write a copy of the original cell back in the notebook, and to replace unique by a function func (by default FullSimplify) so that the user can just do shift-Enter to make this common transformation of the input, or can edit FullSimplify to something else, in place. There is also some error recovery to avoid losing data.

Please do not consider the version number as any guarantee of any kind.

(*Version 2*)
(*The "FrontEndExecute" business is from
"https://mathematica.stackexchange.com/questions/6224"/*)
(*The "CreateDialog" and "FrontEnd`BoxReferenceFind" business is
based on
http://community.wolfram.com/groups/-/m/t/489487 by Kuba Podkalicki*)

Module[
 {unique, nb, selectedcells, cells, selection, extrasign,
  boxdata, newboxdata, boxdatapattern, placeholder,
  pos, func, expr, newexpr,
  doEW, placeholderBox, validExpression,
  errorMultiCell, errorNotExpr, errorNotSubExpr, errorUnique},
 func = FullSimplify;
 System`FrontEndExecute[
  FrontEnd`ResetMenusPacket[{Automatic}]];
 System`FrontEndExecute[
  FrontEnd`AddMenuCommands[
   "SubsessionEvaluateCells",
   {System`MenuItem["Evaluate &With", FrontEnd`KernelExecute[doEW],
     System`MenuKey["|", System`Modifiers -> {"Control"}],
     System`MenuEvaluator -> Automatic]}]];
 placeholderBox[sel_] := RowBox[{ToString[unique], "[", sel, "]"}];
 doEW := (
   unique = Unique[];
   nb = EvaluationNotebook[];(*todo: 
   several parts of this code need that selection stays static*)
   selectedcells = SelectedCells[nb];
   cells = NotebookRead[selectedcells];
   If[Length[selectedcells] == 1,
    selection = NotebookRead[nb];
    extrasign = 
     MatchQ[selection, 
      RowBox[{"-" | "+" | RowBox[{("-" | "+"), ___}], ___}]];
    NotebookApply[nb,
     If[extrasign,
      RowBox[{"+", placeholderBox["\[SelectionPlaceholder]"]}],
      placeholderBox["\[SelectionPlaceholder]"]]];
    If[validExpression[selection],
     boxdata = cells[[1, 1]];
     newboxdata = NotebookRead[selectedcells][[1, 1]];
     boxdatapattern = If[extrasign,
       ReplaceAll[newboxdata,
        f_Symbol[a___, "+", placeholderBox[___], b___] :> 
         f[a, ___, b]],
       ReplaceAll[newboxdata, placeholderBox[___] :> ___]];
     expr = MakeExpression[boxdata, StandardForm];(*todo*)
     newexpr = MakeExpression[newboxdata, StandardForm];
     If[MatchQ[boxdata, boxdatapattern] &&
       (Head[expr] =!= ErrorBox) &&
       (Head[newexpr] =!= ErrorBox) &&
       Not[FreeQ[newexpr, unique]] &&
       MatchQ[expr, ReplaceAll[newexpr, {unique[___] :> ___,
          (h_Symbol /; MemberQ[Attributes[h], Orderless]) :> 
           Verbatim[h]}]],
      pos = Most[First[Position[newexpr, unique]]];
      SelectionMove[selectedcells[[1]], Before, Cell, 
       AutoScroll -> False];
      NotebookWrite[nb, cells, After, AutoScroll -> False];
      SelectionMove[selectedcells[[1]], After, CellContents, 
       AutoScroll -> False];
      NotebookWrite[nb, 
       "//EvaluateAt[" <> StringTake[ToString[Rest[pos]], {2, -2}] <> 
        "]", AutoScroll -> False];
      NotebookFind[nb, ToString[unique], Previous, 
       AutoScroll -> False];
      NotebookWrite[nb, func, All]
      ,
      NotebookWrite[selectedcells[[1]], cells[[1]]];
      errorNotSubExpr],
     NotebookWrite[selectedcells[[1]], cells[[1]]];
     errorNotExpr],
    errorMultiCell];
   );
 errorMultiCell := 
  MessageDialog[
   "The selection is bigger than one cell.  Please choose a smaller \
selection."];
 errorNotExpr := 
  MessageDialog[
   StringForm[
    "The selection `1` is not an expression, please choose a \
different selection.", DisplayForm[selection]]];
 errorNotSubExpr := 
  MessageDialog[
   StringForm[
    "The selection `1` is not a subexpression of the full expression, \
please choose a different selection.", DisplayForm[selection]]];
 errorUnique := 
  MessageDialog[
   StringForm[
    "The expression contains the placeholder `1`, which would \
interfere with the code of EvaluateWith", DisplayForm[unique]]];
 validExpression[
   boxes_] := (Head[MakeExpression[boxes, StandardForm]] =!= ErrorBox);
 EvaluateAt[pos__] := Function[arg,
   expr = HoldComplete[arg];
   func = expr[[1, pos, 0]];
   ReleaseHold@ReplacePart[expr, List[pos] -> expr[[1, pos]]],
   {HoldAllComplete}
   ];
 ]