Images In PopupMenu

• Tweet
• 

        This Mathematica code corresponds to a question at the Mathematica Stackexchange site ( http://mathematica.stackexchange.com/questions/5014/why-do-images-in-a-popupmenu-sometimes-make-a-program-load-sluggishly).
The code builds on code originally developed by Eric Schulz (http://demonstrations.wolfram.com/NumberLineSolutionsToAbsoluteValueEquationsAndInequalities/).


Here I used characters in the popup menu.  I would like to use images, as explained in the post.

Manipulate[
 
 If[newProblem, {op2, a2, b2, newProblem} = {RandomInteger[{1, 6}], 
    RandomInteger[{-5, 5}], RandomInteger[4], False}];
 (*If[reset,{a,b,reset}={1,2,False}];*)
 
 If[a >= 0, a = Min[a, 10 - Abs[b]], a = Max[a, -10 + Abs[b]]];
 solution = solutions[op2, a2, b2];
 attempt = solutions[s, a, b];
 If[ problemDisplay != 3 && solution === attempt, success, plunk[]];
 
 Pane[Grid[DeleteCases[{
     
     If[problemDisplay == 
       1, {Style[
         solution /. {Or[b7_, a7__] :> 
            Row[ Riffle[{b7, a7}, Style["  Or  ", Gray]]]}, 19, 
         FontFamily -> "Times"] // Panel}], 
     If[problemDisplay == 2, {absValueEquation[op2, a2, b2] // Panel}],
     
     
     {Show[{
        axes[{{-10.9, 10.9}, {-.5, 
           If[MemberQ[display, 3] \[Or] MemberQ[display, 4], 2.5, 
            1]}}],
        arrows[a, b],
        segments[s(*oper*), Blue, a, b]},
       BaseStyle -> 16, ImageSize -> 550, AspectRatio -> Automatic]
      },
     
     
     
     If[MemberQ[display, 
       1], {Style[
        attempt /. {Or[b_, a__] :> 
           Row[ Riffle[{b, a}, Style["  Or  ", Gray]]]}, 19, 
        FontFamily -> "Times"]}],
     If[MemberQ[display, 2], {absValueEquation[s, a, b]}],
     
     (*{Row[{"center:",a}]},
     {Row[{"span:",b}]},*)
     
     }, Null],
   
   Spacings -> {2, 1} ], 540, Alignment -> Center],
 
 
 {{problemDisplay, 3, "problem:"}, {1 -> "solutions", 
   2 -> "equation or inequality", 3 -> "none"},
  ControlType -> RadioButtonBar, ControlPlacement -> Top},
 
 (*{{showProblem,True},{False,True},ControlPlacement->Top},
 *)
 {{newProblem, False}, {False, True}, 
  Enabled -> problemDisplay != 3, ControlPlacement -> Top},
 
 
 {{s, 2, ""}, {1 -> "=", 2 -> "<", 3 -> "\[LessEqual]", 4 -> ">", 
   5 -> "\[GreaterEqual]", 6 -> "\[NotEqual]"}, PopupMenu, 
  ControlPlacement -> Bottom},
 
 {{display, {1}, "display:"}, {1 -> "solutions", 
   2 -> "equation or inequality", 3 -> "a", 4 -> "b  "},
  ControlType -> CheckboxBar, ControlPlacement -> Bottom},
 
 {{a, 1}, -10, 10, 1, Appearance -> "Labeled", ImageSize -> 500, 
  ControlPlacement -> Bottom},
 {{b, 2}, -10, 10, 1, Appearance -> "Labeled", ImageSize -> 500, 
  ControlPlacement -> Bottom},
 
 
 
 {{a, 1}, -10, 10, 1, ControlType -> None},
 {{b, 2}, -10, 10, 1, ControlType -> None},
 {{a2, 3}, -10, 10, 1, ControlType -> None},
 {{b2, 4}, -10, 10, 1, ControlType -> None},
 {{op2, 1}, 1, 6, 1, ControlType -> None},
 (*{{pts,{{1,0},{3,0}}},ControlType-> None},*)
 
 
 
 (*{{reset,False},{False,True},ControlPlacement->Bottom},*)
 
 AutorunSequencing -> {1, {2, 3}, {3, 3}},
 TrackedSymbols :> Manipulate,
 (*SaveDefinitions->True,*)
 
 Initialization :> {
   
   axes[plotRange_] := 
    Plot[0, {x, -10, 10}, Axes -> {True, False}, 
     Ticks -> {Range[-10, 10, 1], None}, PlotRange -> plotRange,
     BaseStyle -> 16, ImageSize -> {550, 55}, 
     AspectRatio -> Automatic];
   
   absValueEquation[operator_, center_, span_] := 
    Tooltip[Style[If[MemberQ[display, 3],
       Row[{"|", Style["x", Italic], " - (", center, ")|",
         operator /. {1 -> " = ", 2 -> " < ", 3 -> " \[LessEqual] ", 
           4 -> " > ", 5 -> " \[GreaterEqual] ", 
           6 -> " \[NotEqual] "}, span}],
       Row[{"|", Style["x", Italic], 
         Which[center < 0, " + ", center == 0, "", center > 0, 
          " - "],
         Which[center < 0, Abs[center], center == 0, "", center > 0, 
          center], "|",
         operator /. {1 -> " = ", 2 -> " < ", 3 -> " \[LessEqual] ", 
           4 -> " > ", 5 -> " \[GreaterEqual] ", 
           6 -> " \[NotEqual] "}, span}]], 19, FontFamily -> "Times"],
      Row[{Style["|", 14], Style["x-a", 12, Italic], Style["| ", 14], 
       operator /. opRules, Style["b", 12, Italic]}]];
   
   
   arrows[center_, span_] := Graphics[
     (* center arrow *)
     {If[
       MemberQ[display, 
        3], {{AbsoluteThickness[2], Gray, Arrowheads[.03], 
         Arrow[{{center, 2.2}, {center, 0}}, .25]},
        Text[Style["a", Italic], {center, 2.2}]}, Black],
      
      (* +b arrow *)
      
      If[MemberQ[display, 4] && 
        span != 0, {{Brown, AbsoluteThickness[1], Arrowheads[{.02}], 
         Arrow[{{center, 1.25}, {center + span, 1.25}}, .05]},
        Text[Style["+b", Italic], {center + span/2, 1.65}]}, Black],
      
      (* -b arrow *)
      
      If[MemberQ[display, 4] && 
        span != 0, {{Brown, AbsoluteThickness[1], Arrowheads[{.02}], 
         Arrow[{{center, 1.25}, {center - span, 1.25}}, .05]},
        Text[Style["-b", Italic], {center - span/2, 1.65}]}, Black],
      
      (* (b+a) arrow *)
      
      If[MemberQ[display, 3] && MemberQ[display, 4] && 
        span != 0, {{AbsoluteThickness[2], Gray, Arrowheads[.03], 
         Arrow[{{span + center, 2.2}, {span + center, 0}}, .25]},
        Text[Style["a+b", Italic], {span + center, 2.2}]}, Black],
      
      (* (a-b) arrow *)
      
      If[MemberQ[display, 3] && MemberQ[display, 4] && 
        span != 0, {{AbsoluteThickness[2], Gray, Arrowheads[.03], 
         Arrow[{{center - span, 2.2}, {center - span, 0}}, .25]},
        Text[Style["a-b", Italic], {center - span, 2.2}]}, Black],
      
      (* b=0 *)
      
      If[MemberQ[display, 4] && 
        span == 0, {Text[Style["b=0", Italic], {center, 1.65}]}, 
       Black]}];
   
   solutions[op_, center_, span_] := 
    Module[{operator = 
       op /. {1 -> Equal, 2 -> Less, 3 -> LessEqual, 4 -> Greater, 
         5 -> GreaterEqual, 6 -> Unequal}}, 
     Reduce[operator[Abs[x - center], span], x, Reals]];
   
   plunk[n_: 0] := EmitSound@Sound[SoundNote[n, .25, "Woodblock"]];
   success := EmitSound@Sound[SoundNote["F", 1, 99]];
   
   radius = 0.2;
   opRules = {1 -> Style["=  ", 14], 2 -> Style["<  ", 14], 
     3 -> Style["\[LessEqual]  ", 14], 4 -> Style[">  ", 13], 
     5 -> Style["\[GreaterEqual] ", 14], 
     6 -> Style["\[NotEqual] ", 14]};
   
   pt[loc_, type_: "Closed"] := 
    If[type == "Open", Circle[loc, radius], Disk[loc, radius]];
   
   segments[o_, c_, a1_, b1_] :=
    Graphics[{{
       (* Open interval *)
       
       If[And[o == 2 || o == 4 || o == 6, b1 >= 0], {c, 
         pt[{b1 + a1, 0}, "Open"], pt[{-b1 + a1, 0}, "Open"]}, c],
       
       (* Closed interval or points *)
       
       If[And[o == 1 || o == 3 || o == 5, b1 >= 0], {c, 
         pt[{b1 + a1, 0}], pt[{-b1 + a1, 0}]}, c], 
       AbsoluteThickness[4],
       
       (*interval between key points *)
       
       If[And[o == 2 || o == 3 || o == 6, b1 > 0],
        {Line[{{Abs[b1] + a1 - radius, 0}, {-Abs[b1] + a1 + radius, 
            0}}]},
        Black],
       If[And[o == 4 || o == 5 || o == 6, b1 >= 0],
        {c, Arrow[{{Abs[b1] + a1 + radius, 0}, {10.9, 0}}], 
         Arrow[{{-Abs[b1] + a1 - radius, 0}, {-10.9, 0}}]}, Black],
       
       (*Draw complete number line: always True *)
       
       If[And[o == 4 || o == 5 || o == 6, b1 < 0],
        {c, Line[{{a1 - radius, 0}, {a1 + radius, 0}}], 
         Arrow[{{a1 + radius, 0}, {10.9, 0}}], 
         Arrow[{{a1 - radius, 0}, {-10.9, 0}}]},
        Black]}(*,Black]*)}]}]

Tags:
• interface
• mathematica